;;; 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