;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 home)
  #:use-module (guix derivations)
  #:use-module (guix grafts)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:use-module (guix status)
  #:use-module (guix store)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (home)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:export (guix-home))

;;;
;;; Command-line options.
;;;

(define %options
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix edit")))))

(define (show-help)
  (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE]
Manage a user home environment according to FILE and ACTION.  Some actions
support additional ARGs.\n"))
  (display (G_ "The valid values for ACTION are:\n"))
  (newline)
  (display (G_ "\
   reconfigure      switch to or create a new home configuration\n"))
  (display (G_ "\
   build            build the home configuration without installing anything\n"))
  (display (G_ "\
   list-generations list the home generations\n"))
  (show-build-options-help)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specifications of the command-line options.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix system")))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
         (option '(#\d "derivation") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'derivations-only? #t result)))
         (option '("on-error") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'on-error (string->symbol arg)
                               result)))
         (option '(#\t "file-system-type") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file-system-type arg
                               result)))
         (option '("image-size") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'image-size (size->number arg)
                               result)))
         (option '(#\N "network") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'container-shared-network? #t result)))
         (option '("no-bootloader" "no-grub") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'install-bootloader? #f result)))
         (option '("full-boot") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'full-boot? #t result)))
         (option '("skip-checks") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'skip-safety-checks? #t result)))

         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         (option '(#\r "root") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'gc-root arg result)))
         %standard-build-options))

(define %default-options
  ;; Alist of default option values.
  `((system . ,(%current-system))
    (substitutes? . #t)
    (build-hook? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (graft? . #t)
    (debug . 0)
    (verbosity . #f)                              ;default
    (file-system-type . "ext4")
    (image-size . guess)
    (install-bootloader? . #t)))

;;;
;;; Profiles
;;;

(define %user-module
  ;; Module in which the machine description file is loaded.
  (make-user-module '()))

(define %home (getenv "HOME"))

(define %current-home
  (string-append %profile-directory "/home"))

(define (ensure-home-profile data-directory)
  "Ensures $HOME is a symlink to the profile.  If it is not yet the case, move
it to the @var{data-directory} directory, unless it already exists, in which case
report an error."
  (ensure-profile-directory)

  (when (and %home %current-home)
    (let ((home (false-if-exception (lstat %home))))
      (cond
        ((equal? (stat:type home) 'symlink)
         (unless (equal? (readlink %home) %current-home)
           (delete-file %home)
           (symlink %current-home %home)))
        ((false-if-exception (lstat data-directory))
         (leave (G_ "Your $HOME directory (~a) is not a symlink to the home
profile, and it cannot be moved as ~a already exists on the filesystem.~%")
                %home data-directory))
        ((not home)
         (symlink %current-home %home))
        (else
         (rename-file %home data-directory)
         (symlink %current-home %home))))))

(define (list-generations pattern)
  "Display in a human-readable format all the home generations matching
PATTERN, a string.  When PATTERN is #f, display all the home generations."
  (cond ((not (file-exists? %current-home))             ; XXX: race condition
	 (raise (condition (&profile-not-found-error
			     (profile %current-home)))))
	((not pattern)
	 (for-each (lambda (number) (display-generation %current-home number)) (profile-generations %current-home)))
	((matching-generations pattern %current-home)
	 =>
	 (lambda (numbers)
	   (if (null-list? numbers)
	       (exit 1)
	       (leave-on-EPIPE
		 (for-each (lambda (number) (display-generation %current-home number)) numbers)))))))


;;;
;;; Entry point.
;;;

(define* (perform-action action home
                         #:key
                         dry-run? derivations-only?
                         use-substitutes?)
  "Perform ACTION for HOME.  When DERIVATIONS-ONLY? is true, print the
derivation file name(s) without building anything."
  (define println
    (cut format #t "~a~%" <>))

  (with-store store
    (let* ((drv      (run-with-store store (home->derivation home)))
           (profile  (derivation->output-path drv)))
      (show-what-to-build store (list drv)
                          #:use-substitutes? use-substitutes?
                          #:dry-run? dry-run?)

      (unless (or dry-run? derivations-only?)
          (begin
            (build-derivations store (list drv))
            (case action
              ((reconfigure)
               (newline)
               (format #t (G_ "Activating home...~%"))
               (ensure-home-profile (home-data-directory home))
               (let* ((number (generation-number %current-home))
                      (generation (generation-file-name %current-home (+ 1 number))))
                 (switch-symlinks generation profile)
                 (switch-symlinks %current-home generation))
                 (format #t (G_ "Your home directory has been reconfigured.~%")))
              (else
                (display profile)
                (newline))))))))

(define (process-action action args opts)
  "Process ACTION, a sub-command, with the arguments are listed in ARGS.
ACTION must be one of the sub-commands that takes an operating system
declaration as an argument (a file name.)  OPTS is the raw alist of options
resulting from command-line parsing."
  (define (ensure-home-configuration file-or-exp obj)
    (unless (home? obj)
      (leave (G_ "'~a' does not return a home configuration~%")
             file-or-exp))
    obj)

  (let* ((file        (match args
                        (() #f)
                        ((x . _) x)))
         (expr        (assoc-ref opts 'expression))
         (system      (assoc-ref opts 'system))
         (home        (ensure-home-configuration
                       (or file expr)
                       (cond
                        ((and expr file)
                         (leave
                          (G_ "both file and expression cannot be specified~%")))
                        (expr
                         (read/eval expr))
                        (file
                         (load* file %user-module
                                #:on-error (assoc-ref opts 'on-error)))
                        (else
                         (leave (G_ "no configuration specified~%"))))))

         (dry?        (assoc-ref opts 'dry-run?)))

    (with-store store
      (set-build-options-from-command-line store opts)

      (set-guile-for-build (default-guile))

      (case action
        (else
         (unless (eq? action 'build)
           (warn-about-old-distro #:suggested-command
                                  "guix home reconfigure"))

         (perform-action action home
                         #:dry-run? dry?
                         #:derivations-only? (assoc-ref opts
                                                        'derivations-only?)
                         #:use-substitutes? (assoc-ref opts 'substitutes?)))))
    (warn-about-disk-space)))

(define (resolve-subcommand name)
  (let ((module (resolve-interface
                 `(guix scripts home ,(string->symbol name))))
        (proc (string->symbol (string-append "guix-home-" name))))
    (module-ref module proc)))

(define (process-command command args opts)
  "Process COMMAND, one of the 'guix system' sub-commands.  ARGS is its
argument list and OPTS is the option alist."
  (case command
    ;; The following commands do not need to use the store, and they do not need
    ;; an operating system configuration file.
    ((list-generations)
     (let ((pattern (match args
			   (() #f)
			   ((pattern) pattern)
			   (x (leave (G_ "wrong number of arguments~%"))))))
       (list-generations pattern)))
    ;; The following commands need to use the store, but they do not need an
    ;; operating system configuration file.
    ;; The following commands need to use the store, and they also
    ;; need an operating system configuration file.
    (else (process-action command args opts))))

(define (guix-home . args)
  (define (parse-sub-command arg result)
    ;; Parse sub-command ARG and augment RESULT accordingly.
    (if (assoc-ref result 'action)
        (alist-cons 'argument arg result)
        (let ((action (string->symbol arg)))
          (case action
            ((build reconfigure list-generations)
             (alist-cons 'action action result))
            (else (leave (G_ "~a: unknown action~%") action))))))

  (define (match-pair car)
    ;; Return a procedure that matches a pair with CAR.
    (match-lambda
      ((head . tail)
       (and (eq? car head) tail))
      (_ #f)))

  (define (option-arguments opts)
    ;; Extract the plain arguments from OPTS.
    (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
           (count  (length args))
           (action (assoc-ref opts 'action))
           (expr   (assoc-ref opts 'expression)))
      (define (fail)
        (leave (G_ "wrong number of arguments for action '~a'~%")
               action))

      (unless action
        (format (current-error-port)
                (G_ "guix home: missing command name~%"))
        (format (current-error-port)
                (G_ "Try 'guix home --help' for more information.~%"))
        (exit 1))

      (case action
        ((build reconfigure)
         (unless (= count 1)
           (fail))))
      args))

  (with-error-handling
    (let* ((opts     (parse-command-line args %options
                                         (list %default-options)
                                         #:argument-handler
                                         parse-sub-command))
           (args     (option-arguments opts))
           (command  (assoc-ref opts 'action)))
      (parameterize ((%graft? (assoc-ref opts 'graft?)))
        (with-status-verbosity (or (assoc-ref opts 'verbosity)
                                   (if (eq? command 'build) 2 1))
          (process-command command args opts))))))

;;; home.scm ends here