Merge branch 'master' into staging

8 files changed, 411 insertions, 192 deletions

diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index f38de16cf7..7d363a18a5 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
+;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,6 +40,21 @@
 ;;
 ;; Code:
 
+;; TODO: Move this to (guix build cargo-utils). Will cause a full rebuild
+;; of all rust compilers.
+
+(define (generate-all-checksums dir-name)
+  (for-each
+    (lambda (filename)
+      (let* ((dir (dirname filename))
+             (checksum-file (string-append dir "/.cargo-checksum.json")))
+        (when (file-exists? checksum-file) (delete-file checksum-file))
+        (display (string-append
+                   "patch-cargo-checksums: generate-checksums for "
+                   dir "\n"))
+        (generate-checksums dir)))
+    (find-files dir-name "Cargo.toml$")))
+
 (define (manifest-targets)
   "Extract all targets from the Cargo.toml manifest"
   (let* ((port (open-input-pipe "cargo read-manifest"))
@@ -94,8 +110,7 @@ Cargo.toml file present at its root."
               ;; so that we can generate any cargo checksums.
               ;; The --strip-components argument is needed to prevent creating
               ;; an extra directory within `crate-dir`.
-              (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1")
-              (generate-checksums crate-dir)))))
+              (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1")))))
     inputs)
 
   ;; Configure cargo to actually use this new directory.
@@ -121,6 +136,31 @@ directory = '" port)
   (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
   #t)
 
+;; The Cargo.lock file tells the build system which crates are required for
+;; building and hardcodes their version and checksum.  In order to build with
+;; the inputs we provide, we need to recreate the file with our inputs.
+(define* (update-cargo-lock #:key
+                            (vendor-dir "guix-vendor")
+                            #:allow-other-keys)
+  "Regenerate the Cargo.lock file with the current build inputs."
+  (when (file-exists? "Cargo.lock")
+    (begin
+      ;; Unfortunately we can't generate a Cargo.lock file until the checksums
+      ;; are generated, so we have an extra round of generate-all-checksums here.
+      (generate-all-checksums vendor-dir)
+      (delete-file "Cargo.lock")
+      (invoke "cargo" "generate-lockfile")))
+  #t)
+
+;; After the 'patch-generated-file-shebangs phase any vendored crates who have
+;; their shebangs patched will have a mismatch on their checksum.
+(define* (patch-cargo-checksums #:key
+                                (vendor-dir "guix-vendor")
+                                #:allow-other-keys)
+  "Patch the checksums of the vendored crates after patching their shebangs."
+  (generate-all-checksums vendor-dir)
+  #t)
+
 (define* (build #:key
                 skip-build?
                 (cargo-build-flags '("--release"))
@@ -162,7 +202,9 @@ directory = '" port)
     (replace 'configure configure)
     (replace 'build build)
     (replace 'check check)
-    (replace 'install install)))
+    (replace 'install install)
+    (add-after 'configure 'update-cargo-lock update-cargo-lock)
+    (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums)))
 
 (define* (cargo-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 858068ba98..3dac43c18a 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -135,6 +135,9 @@ of the package being built and its dependencies, and GOBIN, which determines
 where executables (\"commands\") are installed to.  This phase is sometimes used
 by packages that use (guix build-system gnu) but have a handful of Go
 dependencies, so it should be self-contained."
+  ;; The Go cache is required starting in Go 1.12.  We don't actually use it but
+  ;; we need it to be a writable directory.
+  (setenv "GOCACHE" "/tmp/go-cache")
   ;; Using the current working directory as GOPATH makes it easier for packagers
   ;; who need to manipulate the unpacked source code.
   (setenv "GOPATH" (getcwd))
diff --git a/guix/discovery.scm b/guix/discovery.scm
index 468b6c59de..7c5fed7f0e 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -51,13 +51,15 @@ DIRECTORY is not accessible."
       ((? symbol? type)
        type)))
 
+  (define (dot-prefixed? file)
+    (string-prefix? "." file))
+
   ;; Use 'scandir*' so we can avoid an extra 'lstat' for each entry, as
   ;; opposed to Guile's 'scandir' or 'file-system-fold'.
   (fold-right (lambda (entry result)
                 (match entry
-                  (("." . _)
-                   result)
-                  ((".." . _)
+                  (((? dot-prefixed?) . _)
+                   ;; Exclude ".", "..", and hidden files such as backups.
                    result)
                   ((name . properties)
                    (let ((absolute (string-append directory "/" name)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index eef308b000..45cd5869f7 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -427,7 +427,9 @@ This is the declarative counterpart of 'gexp->script'."
     (($ <program-file> name gexp guile module-path)
      (gexp->script name gexp
                    #:module-path module-path
-                   #:guile (or guile (default-guile))))))
+                   #:guile (or guile (default-guile))
+                   #:system system
+                   #:target target))))
 
 (define-record-type <scheme-file>
   (%scheme-file name gexp splice?)
@@ -1345,6 +1347,7 @@ last one is created from the given <scheme-file> object."
 (define* (compiled-modules modules
                            #:key (name "module-import-compiled")
                            (system (%current-system))
+                           target
                            (guile (%guile-for-build))
                            (module-path %load-path)
                            (extensions '())
@@ -1355,7 +1358,8 @@ last one is created from the given <scheme-file> object."
                            (pre-load-modules? #t))
   "Return a derivation that builds a tree containing the `.go' files
 corresponding to MODULES.  All the MODULES are built in a context where
-they can refer to each other."
+they can refer to each other.  When TARGET is true, cross-compile MODULES for
+TARGET, a GNU triplet."
   (define total (length modules))
 
   (mlet %store-monad ((modules (imported-modules modules
@@ -1374,6 +1378,12 @@ they can refer to each other."
                       (srfi srfi-26)
                       (system base compile))
 
+         ;; TODO: Inline this on the next rebuild cycle.
+         (ungexp-splicing
+          (if target
+              (gexp ((use-modules (system base target))))
+              (gexp ())))
+
          (define (regular? file)
            (not (member file '("." ".."))))
 
@@ -1391,9 +1401,19 @@ they can refer to each other."
                                                    (gexp ()))))
                          (ungexp (* total (if pre-load-modules? 2 1)))
                          entry)
-                 (compile-file entry
-                               #:output-file output
-                               #:opts %auto-compilation-options)
+
+                 (ungexp-splicing
+                  (if target
+                      (gexp ((with-target (ungexp target)
+                               (lambda ()
+                                 (compile-file entry
+                                               #:output-file output
+                                               #:opts
+                                               %auto-compilation-options)))))
+                      (gexp ((compile-file entry
+                                           #:output-file output
+                                           #:opts %auto-compilation-options)))))
+
                  (+ 1 processed))))
 
          (define (process-directory directory output processed)
@@ -1494,7 +1514,7 @@ they can refer to each other."
               'guile-2.2))
 
 (define* (load-path-expression modules #:optional (path %load-path)
-                               #:key (extensions '()))
+                               #:key (extensions '()) system target)
   "Return as a monadic value a gexp that sets '%load-path' and
 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
@@ -1502,10 +1522,13 @@ are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
       (with-monad %store-monad
         (return #f))
       (mlet %store-monad ((modules  (imported-modules modules
-                                                      #:module-path path))
+                                                      #:module-path path
+                                                      #:system system))
                           (compiled (compiled-modules modules
                                                       #:extensions extensions
-                                                      #:module-path path)))
+                                                      #:module-path path
+                                                      #:system system
+                                                      #:target target)))
         (return (gexp (eval-when (expand load eval)
                         (set! %load-path
                           (cons (ungexp modules)
@@ -1527,14 +1550,18 @@ are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
 
 (define* (gexp->script name exp
                        #:key (guile (default-guile))
-                       (module-path %load-path))
+                       (module-path %load-path)
+                       (system (%current-system))
+                       target)
   "Return an executable script NAME that runs EXP using GUILE, with EXP's
 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
   (mlet %store-monad ((set-load-path
                        (load-path-expression (gexp-modules exp)
                                              module-path
                                              #:extensions
-                                             (gexp-extensions exp))))
+                                             (gexp-extensions exp)
+                                             #:system system
+                                             #:target target)))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
@@ -1554,6 +1581,8 @@ imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
 
                            (write '(ungexp exp) port)
                            (chmod port #o555))))
+                      #:system system
+                      #:target target
                       #:module-path module-path)))
 
 (define* (gexp->file name exp #:key
diff --git a/guix/git.scm b/guix/git.scm
index 289537dedf..de98fed40c 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -139,29 +139,44 @@ of SHA1 string."
   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
 OID (roughly the commit hash) corresponding to REF."
   (define obj
-    (match ref
-      (('branch . branch)
-       (let ((oid (reference-target
-                   (branch-lookup repository branch BRANCH-REMOTE))))
-         (object-lookup repository oid)))
-      (('commit . commit)
-       (let ((len (string-length commit)))
-         ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
-         ;; can't be sure it's available.  Furthermore, 'string->oid' used to
-         ;; read out-of-bounds when passed a string shorter than 40 chars,
-         ;; which is why we delay calls to it below.
-         (if (< len 40)
-             (if (module-defined? (resolve-interface '(git object))
-                                  'object-lookup-prefix)
-                 (object-lookup-prefix repository (string->oid commit) len)
-                 (raise (condition
-                         (&message
-                          (message "long Git object ID is required")))))
-             (object-lookup repository (string->oid commit)))))
-      (('tag    . tag)
-       (let ((oid (reference-name->oid repository
-                                       (string-append "refs/tags/" tag))))
-         (object-lookup repository oid)))))
+    (let resolve ((ref ref))
+      (match ref
+        (('branch . branch)
+         (let ((oid (reference-target
+                     (branch-lookup repository branch BRANCH-REMOTE))))
+           (object-lookup repository oid)))
+        (('commit . commit)
+         (let ((len (string-length commit)))
+           ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
+           ;; can't be sure it's available.  Furthermore, 'string->oid' used to
+           ;; read out-of-bounds when passed a string shorter than 40 chars,
+           ;; which is why we delay calls to it below.
+           (if (< len 40)
+               (if (module-defined? (resolve-interface '(git object))
+                                    'object-lookup-prefix)
+                   (object-lookup-prefix repository (string->oid commit) len)
+                   (raise (condition
+                           (&message
+                            (message "long Git object ID is required")))))
+               (object-lookup repository (string->oid commit)))))
+        (('tag-or-commit . str)
+         (if (or (> (string-length str) 40)
+                 (not (string-every char-set:hex-digit str)))
+             (resolve `(tag . ,str))              ;definitely a tag
+             (catch 'git-error
+               (lambda ()
+                 (resolve `(tag . ,str)))
+               (lambda _
+                 ;; There's no such tag, so it must be a commit ID.
+                 (resolve `(commit . ,str))))))
+        (('tag    . tag)
+         (let ((oid (reference-name->oid repository
+                                         (string-append "refs/tags/" tag))))
+           ;; Get the commit that the tag at OID refers to.  This is not
+           ;; strictly needed, but it's more consistent to always return the
+           ;; OID of a commit.
+           (object-lookup repository
+                          (tag-target-id (tag-lookup repository oid))))))))
 
   (reset repository obj RESET_HARD)
   (object-id obj))
@@ -218,8 +233,8 @@ please upgrade Guile-Git.~%"))))
 values: the cache directory name, and the SHA1 commit (a string) corresponding
 to REF.
 
-REF is pair whose key is [branch | commit | tag] and value the associated
-data, respectively [<branch name> | <sha1> | <tag name>].
+REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
+the associated data: [<branch name> | <sha1> | <tag name> | <string>].
 
 When RECURSIVE? is true, check out submodules as well, if any."
   (define canonical-ref
@@ -319,7 +334,7 @@ Log progress and checkout info to LOG-PORT."
   git-checkout?
   (url     git-checkout-url)
   (branch  git-checkout-branch (default "master"))
-  (commit  git-checkout-commit (default #f))
+  (commit  git-checkout-commit (default #f))      ;#f | tag | commit
   (recursive? git-checkout-recursive? (default #f)))
 
 (define* (latest-repository-commit* url #:key ref recursive? log-port)
@@ -358,7 +373,7 @@ Log progress and checkout info to LOG-PORT."
     (($ <git-checkout> url branch commit recursive?)
      (latest-repository-commit* url
                                 #:ref (if commit
-                                          `(commit . ,commit)
+                                          `(tag-or-commit . ,commit)
                                           `(branch . ,branch))
                                 #:recursive? recursive?
                                 #:log-port (current-error-port)))))
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/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..dee0c24bd2
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,232 @@
+;;; 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 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)))))