Merge branch 'master' into staging

2 files changed, 94 insertions, 85 deletions

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ed876b2592..7f087a3a3c 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -88,6 +88,19 @@ found."
             %compressors)
       (leave (G_ "~a: compressor not found~%") name)))
 
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix _ ...) #t)
+    (('gnu _ ...) #t)
+    (_ #f)))
+
+(define guile-sqlite3&co
+  ;; Guile-SQLite3 and its propagated inputs.
+  (cons guile-sqlite3
+        (package-transitive-propagated-inputs guile-sqlite3)))
+
 (define* (self-contained-tarball name profile
                                  #:key target
                                  deduplicate?
@@ -102,13 +115,6 @@ with a properly initialized store database.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
-  (define not-config?
-    (match-lambda
-      (('guix 'config) #f)
-      (('guix _ ...) #t)
-      (('gnu _ ...) #t)
-      (_ #f)))
-
   (define libgcrypt
     (module-ref (resolve-interface '(gnu packages gnupg))
                 'libgcrypt))
@@ -128,9 +134,7 @@ added to the pack."
                                   (guix build store-copy)
                                   (gnu build install))
                                 #:select? not-config?))
-      (with-extensions (cons guile-sqlite3
-                             (package-transitive-propagated-inputs
-                              guile-sqlite3))
+      (with-extensions guile-sqlite3&co
         #~(begin
             (use-modules (guix build utils)
                          ((guix build union) #:select (relative-file-name))
@@ -248,71 +252,83 @@ points for virtual file systems (like procfs), and optional symlinks.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
+  (define libgcrypt
+    ;; XXX: Not strictly needed, but pulled by (guix store database).
+    (module-ref (resolve-interface '(gnu packages gnupg))
+                'libgcrypt))
+
+
   (define build
-    (with-imported-modules '((guix build utils)
-                             (guix build store-copy)
-                             (gnu build install))
-      #~(begin
-          (use-modules (guix build utils)
-                       (gnu build install)
-                       (guix build store-copy)
-                       (srfi srfi-1)
-                       (srfi srfi-26)
-                       (ice-9 match))
+    (with-imported-modules `(((guix config)
+                              => ,(make-config.scm
+                                   #:libgcrypt libgcrypt))
+                             ,@(source-module-closure
+                                '((guix build utils)
+                                  (guix build store-copy)
+                                  (gnu build install))
+                                #:select? not-config?))
+      (with-extensions guile-sqlite3&co
+        #~(begin
+            (use-modules (guix build utils)
+                         (gnu build install)
+                         (guix build store-copy)
+                         (srfi srfi-1)
+                         (srfi srfi-26)
+                         (ice-9 match))
 
-          (setenv "PATH" (string-append #$archiver "/bin"))
-
-          ;; We need an empty file in order to have a valid file argument when
-          ;; we reparent the root file system.  Read on for why that's
-          ;; necessary.
-          (with-output-to-file ".empty" (lambda () (display "")))
-
-          ;; Create the squashfs image in several steps.
-          ;; Add all store items.  Unfortunately mksquashfs throws away all
-          ;; ancestor directories and only keeps the basename.  We fix this
-          ;; in the following invocations of mksquashfs.
-          (apply invoke "mksquashfs"
-                 `(,@(map store-info-item
-                          (call-with-input-file "profile"
-                            read-reference-graph))
-                   ,#$output
-
-                   ;; Do not perform duplicate checking because we
-                   ;; don't have any dupes.
-                   "-no-duplicates"
-                   "-comp"
-                   ,#+(compressor-name compressor)))
-
-          ;; Here we reparent the store items.  For each sub-directory of
-          ;; the store prefix we need one invocation of "mksquashfs".
-          (for-each (lambda (dir)
-                      (apply invoke "mksquashfs"
-                             `(".empty"
-                               ,#$output
-                               "-root-becomes" ,dir)))
-                    (reverse (string-tokenize (%store-directory)
-                                              (char-set-complement (char-set #\/)))))
-
-          ;; Add symlinks and mount points.
-          (apply invoke "mksquashfs"
-                 `(".empty"
-                   ,#$output
-                   ;; Create SYMLINKS via pseudo file definitions.
-                   ,@(append-map
-                      (match-lambda
-                        ((source '-> target)
-                         (list "-p"
-                               (string-join
-                                ;; name s mode uid gid symlink
-                                (list source
-                                      "s" "777" "0" "0"
-                                      (string-append #$profile "/" target))))))
-                      '#$symlinks)
-
-                   ;; Create empty mount points.
-                   "-p" "/proc d 555 0 0"
-                   "-p" "/sys d 555 0 0"
-                   "-p" "/dev d 555 0 0")))))
+            (setenv "PATH" (string-append #$archiver "/bin"))
+
+            ;; We need an empty file in order to have a valid file argument when
+            ;; we reparent the root file system.  Read on for why that's
+            ;; necessary.
+            (with-output-to-file ".empty" (lambda () (display "")))
+
+            ;; Create the squashfs image in several steps.
+            ;; Add all store items.  Unfortunately mksquashfs throws away all
+            ;; ancestor directories and only keeps the basename.  We fix this
+            ;; in the following invocations of mksquashfs.
+            (apply invoke "mksquashfs"
+                   `(,@(map store-info-item
+                            (call-with-input-file "profile"
+                              read-reference-graph))
+                     ,#$output
+
+                     ;; Do not perform duplicate checking because we
+                     ;; don't have any dupes.
+                     "-no-duplicates"
+                     "-comp"
+                     ,#+(compressor-name compressor)))
+
+            ;; Here we reparent the store items.  For each sub-directory of
+            ;; the store prefix we need one invocation of "mksquashfs".
+            (for-each (lambda (dir)
+                        (apply invoke "mksquashfs"
+                               `(".empty"
+                                 ,#$output
+                                 "-root-becomes" ,dir)))
+                      (reverse (string-tokenize (%store-directory)
+                                                (char-set-complement (char-set #\/)))))
+
+            ;; Add symlinks and mount points.
+            (apply invoke "mksquashfs"
+                   `(".empty"
+                     ,#$output
+                     ;; Create SYMLINKS via pseudo file definitions.
+                     ,@(append-map
+                        (match-lambda
+                          ((source '-> target)
+                           (list "-p"
+                                 (string-join
+                                  ;; name s mode uid gid symlink
+                                  (list source
+                                        "s" "777" "0" "0"
+                                        (string-append #$profile "/" target))))))
+                        '#$symlinks)
+
+                     ;; Create empty mount points.
+                     "-p" "/proc d 555 0 0"
+                     "-p" "/sys d 555 0 0"
+                     "-p" "/dev d 555 0 0"))))))
 
   (gexp->derivation (string-append name
                                    (compressor-extension compressor)
@@ -332,14 +348,6 @@ image is a tarball conforming to the Docker Image Specification, compressed
 with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
 must a be a GNU triplet and it is used to derive the architecture metadata in
 the image."
-  ;; FIXME: Honor LOCALSTATEDIR?.
-  (define not-config?
-    (match-lambda
-      (('guix 'config) #f)
-      (('guix rest ...) #t)
-      (('gnu rest ...) #t)
-      (rest #f)))
-
   (define defmod 'define-module)                  ;trick Geiser
 
   (define config
@@ -364,9 +372,9 @@ the image."
   (define build
     ;; Guile-JSON is required by (guix docker).
     (with-extensions (list json)
-      (with-imported-modules `(,@(source-module-closure '((guix docker))
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (guix build store-copy))
                                                         #:select? not-config?)
-                               (guix build store-copy)
                                ((guix config) => ,config))
         #~(begin
             (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index a3f01636e6..14aedceac1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -3,6 +3,7 @@
 ;;; 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -352,8 +353,8 @@ bring the system down."
                            #: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 (operating-system-activation-script os)))
+  (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)))