;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2023 Danny Milosavljevic <dannym@scratchpost.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts contrib)
  #:use-module (guix ui)
  #:use-module (guix diagnostics) ; #:select (location leave report-error)
  #:use-module (guix scripts environment)
  #:autoload   (guix scripts build) (show-build-options-help
                                     show-native-build-options-help)
  #:autoload   (guix transformations) (options->transformation
                                       transformation-option-key?
                                       show-transformation-options-help)
  #:use-module (guix scripts)
  #:use-module (guix git)
  #:use-module (guix build utils)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 textual-ports)
  #:autoload   (ice-9 rdelim) (read-line)
  #:autoload   (guix base32) (bytevector->base32-string)
  #:autoload   (rnrs bytevectors) (string->utf8)
  #:autoload   (guix utils) (config-directory cache-directory)
  #:autoload   (guix describe) (current-channels)
  #:autoload   (guix channels) (channel-commit)
  #:autoload   (gcrypt hash) (sha256)
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module (guix cache)
  #:use-module ((ice-9 ftw) #:select (scandir))
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:autoload   (gnu packages) (cache-is-authoritative?
                               package-unique-version-prefix
                               specification->package
                               specification->package+output
                               specifications->manifest)
  #:export (guix-contrib))

(define (show-help)
  (display (G_ "Usage: guix contrib edit PACKAGES...
Create/update a development environment for guix and open a text editor with
PACKAGES inside it.\n"))
  (newline)

  ;; These two options differ from 'guix environment'.

  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

;;; FIXME:

(define (tag-package-arg opts arg)
  "Return a two-element list with the form (TAG ARG) that tags ARG with either
'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
  (if (assoc-ref opts 'ad-hoc?)
      `(ad-hoc-package ,arg)
      `(package ,arg)))

(define (ensure-ad-hoc alist)
  (if (assq-ref alist 'ad-hoc?)
      alist
      `((ad-hoc? . #t) ,@alist)))

(define (wrapped-option opt)
  "Wrap OPT, a SRFI-37 option, such that its processor always adds the
'ad-hoc?' flag to the resulting alist."
  (option (option-names opt)
          (option-required-arg? opt)
          (option-optional-arg? opt)
          (compose ensure-ad-hoc (option-processor opt))))

(define %options
  ;; Specification of the command-line options.
  (let ((to-remove '("ad-hoc" "inherit" "load" "help" "version")))
    (append
        (list (option '(#\h "help") #f #f
                      (lambda args
                        (show-help)
                        (exit 0)))
              (option '(#\V "version") #f #f
                      (lambda args
                        (show-version-and-exit "guix contrib"))))
        (filter-map (lambda (opt)
                      (and (not (any (lambda (name)
                                       (member name to-remove))
                                     (option-names opt)))
                           (wrapped-option opt)))
                    %environment-options))))

(define %default-options
 `())

(define (parse-args args)
  "Parse the list of command line arguments ARGS."
  (define (handle-argument arg result)
    (alist-cons 'package (tag-package-arg result arg)
                (ensure-ad-hoc result)))

  ;; The '--' token is used to separate the command to run from the rest of
  ;; the operands.
  (let ((args command (break (cut string=? "--" <>) args)))
    (parse-command-line args %options (list %default-options))))

(define (invoke-and-read . args)
  "Invoke ARGS and read its stdout into a string"
  (let* ((pipe (apply open-pipe* OPEN_READ args))
         (result (string-trim-right (get-string-all pipe)))
         (close-pipe pipe))
    result))

(define (ensure-git-setting name default-value)
  (let ((current-value (invoke-and-read "git" "config" "--global" name)))
    (format #t "Current setting of ~s is ~s~%" name current-value)
    (let ((default-value (if (string=? current-value "") default-value current-value)))
      (format #t "What value do you want for git setting ~s? [~a] " name default-value)
      (force-output)
      (let ((new-value (string-trim-right (read-line))))
        (unless (string=? new-value current-value)
          (invoke "git" "config" "--global" name (if (string=? new-value "") default-value new-value)))))))

(define (configure-git)
  ; Or just ask user to do `guix shell -C` in the guix checkout directory
  (format #t "This will set up your user's git. If you don't want us to do that, cancel now.~%")

  (if (string=? (invoke-and-read "git" "-h") "")
      (exit 1))
;      Please install `git'--for example by entering the guix environment using `guix shell -C'"

  (if (string=? (invoke-and-read "git" "send-email" "-h") "")
      (exit 1))
 ;     (leave "Please install `git send-email'--for example by entering the guix environment using `guix shell -C'")

  (ensure-git-setting "user.email" "")
  (ensure-git-setting "user.name" "")

  (ensure-git-setting "sendemail.smtpserver" "")
  (ensure-git-setting "sendemail.smtpencryption" "tls")
  (ensure-git-setting "sendemail.smtpserverport" "587")
  (ensure-git-setting "sendemail.smtpuser" "")
  (ensure-git-setting "sendemail.smtppass" ""))

; duplicate
(define (authorized-directory-file)
  "Return the name of the file listing directories for which 'guix shell' may
automatically load 'guix.scm' or 'manifest.scm' files."
  (string-append (config-directory) "/shell-authorized-directories"))

; duplicate
(define (authorized-shell-directory? directory)
  "Return true if DIRECTORY is among the authorized directories for automatic
loading.  The list of authorized directories is read from
'authorized-directory-file'; each line must be either: an absolute file name,
a hash-prefixed comment, or a blank line."
  (catch 'system-error
    (lambda ()
      (call-with-input-file (authorized-directory-file)
        (lambda (port)
          (let loop ()
            (match (read-line port)
              ((? eof-object?) #f)
              ((= string-trim line)
               (cond ((string-prefix? "#" line)   ;comment
                      (loop))
                     ((string-prefix? "/" line)   ;absolute file name
                      (or (string=? line directory)
                          (loop)))
                     ((string-null? (string-trim-right line)) ;blank line
                      (loop))
                     (else                        ;bogus line
                      (let ((loc (location (port-filename port)
                                           (port-line port)
                                           (port-column port))))
                        (warning loc (G_ "ignoring invalid file name: '~a'~%")
                                 line))))))))))
    (const #f)))

(define (prepare-guix-checkout destination-directory)
  (mkdir-p destination-directory)
  ; TODO: Somehow divine ssh URL ?
  ; TODO: Resolve /gnu/store/w77psnbryxvpjxh54y1q7l7gby5dr5vk-guix-module-union/share/guile/site/3.0/gnu/packages/android.scm back to channel git url and commit; then check (at least) that out.
  ;       So: iterate over channels; find where the source file corresponding to the package is?
  ;       Then: Use starting-commit from the respective channel? Not sure what that's for in the first place
  ;       Then: Dynamically set destination-directory
  ; TODO: ref '(branch . "master")
  ; TODO: --depth 1 or something
  (update-cached-checkout "https://git.savannah.gnu.org/git/guix.git" #:ref '() #:cache-directory destination-directory)
  ; More guix-environment* options:
  ;  (package ad-hoc-package "nano")
  ;  (ad-hoc? . #t)
  ;  (system . "x86_64-linux")
  ;  (substitutes? . #t)
  ;  (symlinks)
  ;  (offload? . #t)
  ;  (graft? . #t)
  ;  (print-build-trace? . #t)
  ;  (print-extended-build-trace? . #t)
  ;  (multiplexed-build-output? . #t)
  ;  (debug . 0)
  ;  (verbosity . 1)
  (define (in-guix-checkout command)
    (guix-environment* `((package package "guix") (ad-hoc? . #f) (debug . 0) (verbosity . 1) (exec . ,command)))) ; TODO: opts instead of '()

  ;; Append destination-directory to (authorized-directory-file)
  (unless (authorized-shell-directory? destination-directory)
    (let ((output-port (open-file (authorized-directory-file) "a")))
      (newline output-port)
      (display destination-directory output-port)
      (newline output-port)
      (close output-port)))

  ; TODO: ask whether to do a dev mode setup and hint that it will change user-global settings!
  (format #t "Do you want to reconfigure the `git' version control system? (if you want to contribute your changes, this is useful) [y] ")
  (force-output)
  (let ((answer (string-trim-right (read-line))))
    (when (or (string=? answer "y")
              (string=? answer "yes"))
      (configure-git)))

  ; Build Guix
  (in-guix-checkout '("sh" "-c" "./bootstrap && ./configure --localstatedir=/var --sysconfdir=/etc --disable-daemon && make -j"))
  ; FIXME: we died because of the exec, but we still wanted to print a hint
)


\f
(define-command (guix-contrib . args)
  (category development)
  (synopsis "contribute to Guix")

  (with-error-handling
    (define opts
      (parse-args args))
    (let ((arguments (reverse (filter-map (match-lambda ((argument . b) b)) opts))))
      (match arguments
       (("edit" packages ...)
        (begin
          (let ((destination-directory (string-append (getenv "HOME") "/src/guix")))
            (prepare-guix-checkout destination-directory)
            (display-hint (G_ "In the future, if you want a much faster workflow, please directly edit files in ~s and also invoke `./pre-inst-env guix ~a' in there.") destination-directory (string-join args " "))
            (display-hint (G_ "If you are done and you want to email patches for review, you can use `git send-email -r origin/master --cover-letter --annotate' or similar."))
            #t
            )))))))