scripts: Add 'guix home'.

* guix/scripts/home.scm: New file.
* Makefile.am (MODULES): Add it.

Signed-off-by: Oleg Pykhalov <go.wigust@gmail.com>

1 files changed, 512 insertions, 0 deletions

diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
new file mode 100644
index 0000000000..9eb5c0c917
--- /dev/null
+++ b/guix/scripts/home.scm
@@ -0,0 +1,512 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 (gnu packages admin)
+  #:use-module ((gnu services) #:hide (delete))
+  #:use-module (gnu packages)
+  #:use-module (gnu home)
+  #:use-module (gnu home-services)
+  #:use-module (guix channels)
+  #:use-module (guix derivations)
+  #:use-module (guix ui)
+  #:use-module (guix grafts)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts package)
+  #:use-module (guix scripts build)
+  #:use-module (guix scripts system search)
+  #:autoload   (guix scripts pull) (channel-commit-hyperlink)
+  ;; #:use-module (guix scripts home import)
+  #:use-module ((guix status) #:select (with-status-verbosity))
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:export (guix-home))
+
+
+;;;
+;;; Options.
+;;;
+
+(define %user-module
+  (make-user-module '((gnu home))))
+
+(define %guix-home
+  (string-append %profile-directory "/guix-home"))
+
+(define (show-help)
+  (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE]
+Build the home environment declared in FILE according to ACTION.
+Some ACTIONS support additional ARGS.\n"))
+    (newline)
+  (display (G_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (G_ "\
+   search             search for existing service types\n"))
+  (display (G_ "\
+   reconfigure        switch to a new home environment configuration\n"))
+  (display (G_ "\
+   roll-back          switch to the previous home environment configuration\n"))
+  (display (G_ "\
+   describe           describe the current home environment\n"))
+  (display (G_ "\
+   list-generations   list the home environment generations\n"))
+  (display (G_ "\
+   switch-generation  switch to an existing home environment configuration\n"))
+  (display (G_ "\
+   delete-generations delete old home environment generations\n"))
+  (display (G_ "\
+   build              build the home environment without installing anything\n"))
+  (display (G_ "\
+   import             generates a home environment definition from dotfiles\n"))
+
+  (show-build-options-help)
+  (display (G_ "
+  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define (verbosity-level opts)
+  "Return the verbosity level based on OPTS, the alist of parsed options."
+  (or (assoc-ref opts 'verbosity)
+      (if (eq? (assoc-ref opts 'action) 'build)
+          2 1)))
+
+(define %options
+  ;; Specification 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 show")))
+         (option '(#\v "verbosity") #t #f
+                 (lambda (opt name arg result)
+                   (let ((level (string->number* arg)))
+                     (alist-cons 'verbosity level
+                                 (alist-delete 'verbosity result)))))
+         %standard-build-options))
+
+(define %default-options
+  `((build-mode . ,(build-mode normal))
+    (graft? . #t)
+    (substitutes? . #t)
+    (offload? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
+    (verbosity . 3)
+    (debug . 0)))
+
+
+;;;
+;;; Actions.
+;;;
+
+(define* (perform-action action he
+                         #:key
+                         dry-run?
+                         derivations-only?
+                         use-substitutes?)
+  "Perform ACTION for home environment. "
+
+  (define println
+    (cut format #t "~a~%" <>))
+
+  (mlet* %store-monad
+      ((he-drv   (home-environment-derivation he))
+       (drvs     (mapm/accumulate-builds lower-object (list he-drv)))
+       (%        (if derivations-only?
+                     (return
+                      (for-each (compose println derivation-file-name) drvs))
+                     (built-derivations drvs)))
+
+       (he-out-path -> (derivation->output-path he-drv)))
+    (if (or dry-run? derivations-only?)
+        (return #f)
+        (begin
+          (for-each (compose println derivation->output-path) drvs)
+
+          (case action
+            ((reconfigure)
+             (let* ((number (generation-number %guix-home))
+                    (generation (generation-file-name
+                                 %guix-home (+ 1 number))))
+
+               (switch-symlinks generation he-out-path)
+               (switch-symlinks %guix-home generation)
+               (setenv "GUIX_NEW_HOME" he-out-path)
+               (primitive-load (string-append he-out-path "/activate"))
+               (setenv "GUIX_NEW_HOME" #f)
+               (return he-out-path)))
+            (else
+             (newline)
+             (return he-out-path)))))))
+
+(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 a home environment
+declaration as an argument (a file name.)  OPTS is the raw alist of options
+resulting from command-line parsing."
+  (define (ensure-home-environment file-or-exp obj)
+    (unless (home-environment? obj)
+      (leave (G_ "'~a' does not return a home environment ~%")
+             file-or-exp))
+    obj)
+
+  (let* ((file   (match args
+                   (() #f)
+                   ((x . _) x)))
+         (expr   (assoc-ref opts 'expression))
+         (system (assoc-ref opts 'system))
+
+         (transform   (lambda (obj)
+                        (home-environment-with-provenance obj file)))
+
+         (home-environment
+          (transform
+           (ensure-home-environment
+            (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)
+      (with-build-handler (build-notifier #:use-substitutes?
+                                          (assoc-ref opts 'substitutes?)
+                                          #:verbosity
+                                          (verbosity-level opts)
+                                          #:dry-run?
+                                          (assoc-ref opts 'dry-run?))
+
+        (run-with-store store
+          (mbegin %store-monad
+            (set-guile-for-build (default-guile))
+
+            (case action
+              (else
+               (perform-action action home-environment
+                               #:dry-run? dry?
+                               #:derivations-only? (assoc-ref opts 'derivations-only?)
+                               #:use-substitutes? (assoc-ref opts 'substitutes?))
+               ))))))
+    (warn-about-disk-space)))
+
+
+(define (process-command command args opts)
+  "Process COMMAND, one of the 'guix home' sub-commands.  ARGS is its
+argument list and OPTS is the option alist."
+  (define-syntax-rule (with-store* store exp ...)
+    (with-store store
+      (set-build-options-from-command-line store opts)
+      exp ...))
+  (case command
+    ;; The following commands do not need to use the store, and they do not need
+    ;; an home environment file.
+    ((search)
+     (apply search args))
+    ((import)
+     (let* ((profiles (delete-duplicates
+                      (match (filter-map (match-lambda
+                                           (('profile . p) p)
+                                           (_              #f))
+                                         opts)
+                        (() (list %current-profile))
+                        (lst (reverse lst)))))
+           (manifest (concatenate-manifests
+                      (map profile-manifest profiles))))
+       (import-manifest manifest (current-output-port))))
+    ((describe)
+     (match (generation-number %guix-home)
+       (0
+        (error (G_ "no home environment generation, nothing to describe~%")))
+       (generation
+        (display-home-environment-generation generation))))
+    ((list-generations)
+     (let ((pattern (match args
+                      (() #f)
+                      ((pattern) pattern)
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (list-generations pattern)))
+    ((switch-generation)
+     (let ((pattern (match args
+                      ((pattern) pattern)
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (with-store* store
+                    (switch-to-home-environment-generation store pattern))))
+    ((roll-back)
+     (let ((pattern (match args
+                      (() "")
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (with-store* store
+                    (roll-back-home-environment store))))
+    ((delete-generations)
+     (let ((pattern (match args
+                      (() #f)
+                      ((pattern) pattern)
+                      (x (leave (G_ "wrong number of arguments~%"))))))
+       (with-store*
+        store
+        (delete-matching-generations store %guix-home pattern))))
+    (else (process-action command args opts))))
+
+(define-command (guix-home . args)
+  (synopsis "build and deploy home environments")
+
+  (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
+              extension-graph shepherd-graph
+              list-generations describe
+              delete-generations roll-back
+              switch-generation search
+              import)
+             (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 (or (= count 1)
+                     (and expr (= count 0)))
+           (fail)))
+        ((init)
+         (unless (= count 2)
+           (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 (verbosity-level opts)
+          (process-command command args opts))))))
+
+
+;;;
+;;; Searching.
+;;;
+
+(define service-type-name*
+  (compose symbol->string service-type-name))
+
+(define (service-type-description-string type)
+  "Return the rendered and localised description of TYPE, a service type."
+  (and=> (service-type-description type)
+         (compose texi->plain-text P_)))
+
+(define %service-type-metrics
+  ;; Metrics used to estimate the relevance of a search result.
+  `((,service-type-name* . 3)
+    (,service-type-description-string . 2)
+    (,(lambda (type)
+        (match (and=> (service-type-location type) location-file)
+          ((? string? file)
+           (basename file ".scm"))
+          (#f
+           "")))
+     . 1)))
+
+(define (find-service-types regexps)
+  "Return a list of service type/score pairs: service types whose name or
+description matches REGEXPS sorted by relevance, and their score."
+  (let ((matches (fold-home-service-types
+                  (lambda (type result)
+                    (match (relevance type regexps
+                                      %service-type-metrics)
+                      ((? zero?)
+                       result)
+                      (score
+                       (cons (cons type score) result))))
+                  '())))
+    (sort matches
+          (lambda (m1 m2)
+            (match m1
+              ((type1 . score1)
+               (match m2
+                 ((type2 . score2)
+                  (if (= score1 score2)
+                      (string>? (service-type-name* type1)
+                                (service-type-name* type2))
+                      (> score1 score2))))))))))
+
+(define (search . args)
+  (with-error-handling
+    (let* ((regexps (map (cut make-regexp* <> regexp/icase) args))
+           (matches (find-service-types regexps)))
+      (leave-on-EPIPE
+       (display-search-results matches (current-output-port)
+                               #:print service-type->recutils
+                               #:command "guix home search")))))
+
+
+;;;
+;;; Generations.
+;;;
+
+(define* (display-home-environment-generation
+          number
+          #:optional (profile %guix-home))
+  "Display a summary of home-environment generation NUMBER in a
+human-readable format."
+  (define (display-channel channel)
+    (format #t     "    ~a:~%" (channel-name channel))
+    (format #t (G_ "      repository URL: ~a~%") (channel-url channel))
+    (when (channel-branch channel)
+      (format #t (G_ "      branch: ~a~%") (channel-branch channel)))
+    (format #t (G_ "      commit: ~a~%")
+            (if (supports-hyperlinks?)
+                (channel-commit-hyperlink channel)
+                (channel-commit channel))))
+
+  (unless (zero? number)
+    (let* ((generation  (generation-file-name profile number)))
+      (define-values (channels config-file)
+        ;; The function will work for home environments too, we just
+        ;; need to keep provenance file.
+        (system-provenance generation))
+
+      (display-generation profile number)
+      (format #t (G_ "  file name: ~a~%") generation)
+      (format #t (G_ "  canonical file name: ~a~%") (readlink* generation))
+      ;; TRANSLATORS: Please preserve the two-space indentation.
+
+      (unless (null? channels)
+        ;; TRANSLATORS: Here "channel" is the same terminology as used in
+        ;; "guix describe" and "guix pull --channels".
+        (format #t (G_ "  channels:~%"))
+        (for-each display-channel channels))
+      (when config-file
+        (format #t (G_ "  configuration file: ~a~%")
+                (if (supports-hyperlinks?)
+                    (file-hyperlink config-file)
+                    config-file))))))
+
+(define* (list-generations pattern #:optional (profile %guix-home))
+  "Display in a human-readable format all the home environment
+generations matching PATTERN, a string.  When PATTERN is #f, display
+all the home environment generations."
+  (cond ((not (file-exists? profile))             ; XXX: race condition
+         (raise (condition (&profile-not-found-error
+                            (profile profile)))))
+        ((not pattern)
+         (for-each display-home-environment-generation (profile-generations profile)))
+        ((matching-generations pattern profile)
+         =>
+         (lambda (numbers)
+           (if (null-list? numbers)
+               (exit 1)
+               (leave-on-EPIPE
+                (for-each display-home-environment-generation numbers)))))))
+
+
+;;;
+;;; Switch generations.
+;;;
+
+;; TODO: Make it public in (guix scripts system)
+(define-syntax-rule (unless-file-not-found exp)
+  (catch 'system-error
+    (lambda ()
+      exp)
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          #f
+          (apply throw args)))))
+
+(define (switch-to-home-environment-generation store spec)
+  "Switch the home-environment profile to the generation specified by
+SPEC.  STORE is an open connection to the store."
+  (let* ((number (relative-generation-spec->number %guix-home spec))
+         (generation (generation-file-name %guix-home number))
+         (activate (string-append generation "/activate")))
+    (if number
+        (begin
+          (setenv "GUIX_NEW_HOME" (readlink generation))
+          (switch-to-generation* %guix-home number)
+          (unless-file-not-found (primitive-load activate))
+          (setenv "GUIX_NEW_HOME" #f))
+        (leave (G_ "cannot switch to home environment generation '~a'~%") spec))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-home-environment store)
+  "Roll back the home-environment profile to its previous generation.
+STORE is an open connection to the store."
+  (switch-to-home-environment-generation store "-1"))