Merge branch 'master' into core-updates

6 files changed, 296 insertions, 153 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ec58ba871b..3ee0b737fe 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -341,10 +341,15 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using
   (define (replace old url commit)
     (package
       (inherit old)
-      (version (string-append "git."
-                              (if (< (string-length commit) 7)
-                                  commit
-                                  (string-take commit 7))))
+      (version (if (and (> (string-length commit) 1)
+                        (string-prefix? "v" commit)
+                        (char-set-contains? char-set:digit
+                                            (string-ref commit 1)))
+                   (string-drop commit 1)        ;looks like a tag like "v1.0"
+                   (string-append "git."
+                                  (if (< (string-length commit) 7)
+                                      commit
+                                      (string-take commit 7)))))
       (source (git-checkout (url url) (commit commit)
                             (recursive? #t)))))
 
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 978cfb2a81..52bba3f3bf 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -23,6 +23,8 @@
   #:use-module (guix scripts build)
   #:use-module (guix store)
   #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix grafts)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
@@ -40,6 +42,8 @@
 (define (show-help)
   (display (G_ "Usage: guix deploy [OPTION] FILE...
 Perform the deployment specified by FILE.\n"))
+  (display (G_ "
+  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (show-build-options-help)
   (newline)
   (display (G_ "
@@ -54,10 +58,14 @@ Perform the deployment specified by FILE.\n"))
                  (lambda args
                    (show-help)
                    (exit 0)))
+         (option '(#\s "system") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'system arg
+                               (alist-delete 'system result eq?))))
          %standard-build-options))
 
 (define %default-options
-  '((system . ,(%current-system))
+  `((system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
     (graft? . #t)
@@ -80,5 +88,7 @@ Perform the deployment specified by FILE.\n"))
       (set-build-options-from-command-line store opts)
       (for-each (lambda (machine)
                   (info (G_ "deploying to ~a...") (machine-display-name machine))
-                  (run-with-store store (deploy-machine machine)))
+                  (parameterize ((%current-system (assq-ref opts 'system))
+                                 (%graft? (assq-ref opts 'graft?)))
+                    (run-with-store store (deploy-machine machine))))
                 machines))))
diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm
index 8771e7b0eb..c9daf65479 100644
--- a/guix/scripts/import/json.scm
+++ b/guix/scripts/import/json.scm
@@ -93,7 +93,7 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n"))
            (let ((json (json-string->scm
                         (with-input-from-file file-name read-string))))
              ;; TODO: also print define-module boilerplate
-             (package->code (alist->package (hash-table->alist json)))))
+             (package->code (alist->package json))))
          (lambda _
            (leave (G_ "invalid JSON in file '~a'~%") file-name))))
       (()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8d958b550f..f0cf593814 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -479,7 +479,7 @@ the image."
 
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
-    (with-extensions (list guile-json guile-gcrypt)
+    (with-extensions (list guile-json-3 guile-gcrypt)
       (with-imported-modules `(((guix config) => ,(make-config.scm))
                                ,@(source-module-closure
                                   `((guix docker)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 67a4071684..9fc3a10e98 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -178,43 +179,9 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
-  "Run INSTALLER, a bootloader installation script, with error handling, in
-%STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
-
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
-                  bootloader-installer install-bootloader?
-                  bootcfg bootcfg-file)
+                  install-bootloader? bootloader bootcfg)
   "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
 directory TARGET.  TARGET must be an absolute directory name since that's what
 'register-path' expects.
@@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader local-eval bootloader bootcfg
+                              #:target target)
+          (return
+           (info (G_ "bootloader successfully installed on '~a'~%")
+                 (bootloader-configuration-target bootloader))))))))
 
 
 ;;;
@@ -335,82 +303,6 @@ unload."
        (warning (G_ "failed to obtain list of shepherd services~%"))
        (return #f)))))
 
-(define (upgrade-shepherd-services os)
-  "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
-services specified in OS and not currently running.
-
-This is currently very conservative in that it does not stop or unload any
-running service.  Unloading or stopping the wrong service ('udev', say) could
-bring the system down."
-  (define new-services
-    (service-value
-     (fold-services (operating-system-services os)
-                    #:target-type shepherd-root-service-type)))
-
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
-
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
     (lambda ()
@@ -505,18 +397,13 @@ STORE is an open connection to the store."
                      ((bootloader-configuration-file-generator bootloader)
                       bootloader-config entries
                       #:old-entries old-entries)))
-           (bootcfg-file -> (bootloader-configuration-file bootloader))
-           (target -> "/")
            (drvs -> (list bootcfg)))
         (mbegin %store-monad
           (show-what-to-build* drvs)
           (built-derivations drvs)
-          ;; Only install bootloader configuration file. Thus, no installer is
-          ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          ;; Only install bootloader configuration file.
+          (install-bootloader local-eval bootloader-config bootcfg
+                              #:run-installer? #f))))))
 
 
 ;;;
@@ -820,8 +707,17 @@ and TARGET arguments."
                                         (condition-message c))
                                 (exit 1)))
                        (#$installer #$bootloader #$device #$target)
-                       (format #t "bootloader successfully installed on '~a'~%"
-                               #$device))))))
+                       (info (G_ "bootloader successfully installed on '~a'~%")
+                             #$device))))))
+
+(define (local-eval exp)
+  "Evaluate EXP, a G-Expression, in-place."
+  (mlet* %store-monad ((lowered (lower-gexp exp))
+                       (_ (built-derivations (lowered-gexp-inputs lowered))))
+    (save-load-path-excursion
+     (set! %load-path (lowered-gexp-load-path lowered))
+     (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
+     (return (primitive-eval (lowered-gexp-sexp lowered))))))
 
 (define* (perform-action action os
                          #:key skip-safety-checks?
@@ -858,19 +754,12 @@ static checks."
         (map boot-parameters->menu-entry (profile-boot-parameters))))
 
   (define bootloader
-    (bootloader-configuration-bootloader (operating-system-bootloader os)))
+    (operating-system-bootloader os))
 
   (define bootcfg
     (and (memq action '(init reconfigure))
          (operating-system-bootcfg os menu-entries)))
 
-  (define bootloader-script
-    (let ((installer (bootloader-installer bootloader))
-          (target    (or target "/")))
-      (bootloader-installer-script installer
-                                   (bootloader-package bootloader)
-                                   bootloader-target target)))
-
   (when (eq? action 'reconfigure)
     (maybe-suggest-running-guix-pull))
 
@@ -897,9 +786,7 @@ static checks."
        ;; See <http://bugs.gnu.org/21068>.
        (drvs      (mapm %store-monad lower-object
                         (if (memq action '(init reconfigure))
-                            (if install-bootloader?
-                                (list sys bootcfg bootloader-script)
-                                (list sys bootcfg))
+                            (list sys bootcfg)
                             (list sys))))
        (%         (if derivations-only?
                       (return (for-each (compose println derivation-file-name)
@@ -909,28 +796,32 @@ static checks."
 
     (if (or dry-run? derivations-only?)
         (return #f)
-        (let ((bootcfg-file (bootloader-configuration-file bootloader)))
+        (begin
           (for-each (compose println derivation->output-path)
                     drvs)
 
           (case action
             ((reconfigure)
+             (newline)
+             (format #t (G_ "activating system...~%"))
              (mbegin %store-monad
-               (switch-to-system os)
+               (switch-to-system local-eval os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader local-eval bootloader bootcfg
+                                     #:target (or target "/"))
+                 (return
+                  (info (G_ "bootloader successfully installed on '~a'~%")
+                        (bootloader-configuration-target bootloader))))
+               (with-shepherd-error-handling
+                  (upgrade-shepherd-services local-eval os))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
                      target)
              (install sys (canonicalize-path target)
                       #:install-bootloader? install-bootloader?
-                      #:bootcfg bootcfg
-                      #:bootcfg-file bootcfg-file
-                      #:bootloader-installer bootloader-script))
+                      #:bootloader bootloader
+                      #:bootcfg bootcfg))
             (else
              ;; All we had to do was to build SYS and maybe register an
              ;; indirect GC root.
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 0000000000..8c7d461585
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,237 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services)
+  #:use-module (gnu services herd)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:export (switch-system-program
+            switch-to-system
+
+            upgrade-services-program
+            upgrade-shepherd-services
+
+            install-bootloader-program
+            install-bootloader))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+
+;;;
+;;; Profile creation.
+;;;
+
+(define* (switch-system-program os #:optional profile)
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of OS, switch to it
+atomically, and run OS's activation script."
+  (program-file
+   "switch-to-system.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules (source-module-closure '((guix config)
+                                                     (guix profiles)
+                                                     (guix utils)))
+       #~(begin
+           (use-modules (guix config)
+                        (guix profiles)
+                        (guix utils))
+
+           (define profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (primitive-load #$(operating-system-activation-script os))))))))
+
+(define* (switch-to-system eval os #:optional profile)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+create a new generation of PROFILE pointing to the directory of OS, switch to
+it atomically, and run OS's activation script."
+  (eval #~(primitive-load #$(switch-system-program os profile))))
+
+
+;;;
+;;; Services.
+;;;
+
+(define (running-services eval)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+return the <live-service> objects that are currently running on MACHINE."
+  (define exp
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd))
+          (let ((services (current-services)))
+            (and services
+                 ;; 'live-service-running' is ignored, as we can't necessarily
+                 ;; serialize arbitrary objects. This should be fine for now,
+                 ;; since 'machine-current-services' is not exposed publicly,
+                 ;; and the resultant <live-service> objects are only used for
+                 ;; resolving service dependencies.
+                 (map (lambda (service)
+                        (list (live-service-provision service)
+                              (live-service-requirement service)))
+                      services))))))
+  (mlet %store-monad ((services (eval exp)))
+    (return (map (match-lambda
+                   ((provision requirement)
+                    (live-service provision requirement #f)))
+                 services))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program service-files to-start to-unload to-restart)
+  "Return an executable store item that, upon being evaluated, will upgrade
+the Shepherd (PID 1) by unloading obsolete services and loading new
+services. SERVICE-FILES is a list of Shepherd service files to load, and
+TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
+canonical names (symbols)."
+  (program-file
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        ;; Load the service files for any new services.
+        (load-services/safe '#$service-files)
+
+        ;; Unload obsolete services and start new services.
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
+
+(define* (upgrade-shepherd-services eval os)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
+services as defined by OS."
+  (define target-services
+    (service-value
+     (fold-services (operating-system-services os)
+                    #:target-type shepherd-root-service-type)))
+
+  (mlet* %store-monad ((live-services (running-services eval)))
+    (let*-values (((to-unload to-restart)
+                   (shepherd-service-upgrade live-services target-services)))
+      (let* ((to-unload (map live-service-canonical-name to-unload))
+             (to-restart (map shepherd-service-canonical-name to-restart))
+             (to-start (lset-difference eqv?
+                                        (map shepherd-service-canonical-name
+                                             target-services)
+                                        (map live-service-canonical-name
+                                             live-services)))
+             (service-files
+              (map shepherd-service-file
+                   (filter (lambda (service)
+                             (memq (shepherd-service-canonical-name service)
+                                   to-start))
+                           target-services))))
+        (eval #~(primitive-load #$(upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))))))
+
+
+;;;
+;;; Bootloader configuration.
+;;;
+
+(define (install-bootloader-program installer bootloader-package bootcfg
+                                    bootcfg-file device target)
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
+at TARGET, a mount point, and subsequently run INSTALLER from
+BOOTLOADER-PACKAGE."
+  (program-file
+   "install-bootloader.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules (source-module-closure '((gnu build bootloader)
+                                                     (gnu build install)
+                                                     (guix store)
+                                                     (guix utils)))
+       #~(begin
+           (use-modules (gnu build bootloader)
+                        (gnu build install)
+                        (guix build utils)
+                        (guix store)
+                        (guix utils)
+                        (ice-9 binary-ports)
+                        (srfi srfi-34)
+                        (srfi srfi-35))
+           (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+             (switch-symlinks temp-gc-root gc-root)
+             (install-boot-config #$bootcfg #$bootcfg-file #$target)
+             ;; Preserve the previous activation's garbage collector root
+             ;; until the bootloader installer has run, so that a failure in
+             ;; the bootloader's installer script doesn't leave the user with
+             ;; a broken installation.
+             (when #$installer
+               (catch #t
+                 (lambda ()
+                   (#$installer #$bootloader-package #$device #$target))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
+
+(define* (install-bootloader eval configuration bootcfg
+                             #:key
+                             (run-installer? #t)
+                             (target "/"))
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+configure the bootloader on TARGET such that OS will be booted by default and
+additional configurations specified by MENU-ENTRIES can be selected."
+  (let* ((bootloader (bootloader-configuration-bootloader configuration))
+         (installer (and run-installer?
+                         (bootloader-installer bootloader)))
+         (package (bootloader-package bootloader))
+         (device (bootloader-configuration-target configuration))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (eval #~(primitive-load #$(install-bootloader-program installer
+                                                          package
+                                                          bootcfg
+                                                          bootcfg-file
+                                                          device
+                                                          target)))))