bug#18061: 'guix system init' should store derivation outputs on target store

[Ludovic Courtès]

There are two ways I can think of to fix this:

  1. Have ‘guix system init’ launch a new guix-daemon chrooted under the
     target directory, and then use it to perform all the builds.

  2. Use file system magic, presumably involving a COW unionfs so that
     writes to the in-RAM /gnu/store go to the user’s disk.

The first option seemed easy but has several problems.  First there are
several places in the (guix ...) modules that memorize derivation, which
causes breakage when ‘guix system’ switches to the new store because the
corresponding .drv files are invalid there.  That can be worked around.
But then, when talking to the chrooted store, ‘guix system’, in
‘derivation-hash’, tries to read .drv files that may be missing from the
initial store.  (Current patch attached, for posterity.)

So I’m now looking at option #2.

Ludo’.

        Modified   guix/packages.scm
diff --git a/guix/packages.scm b/guix/packages.scm
index 1939373..ad850fe 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -524,6 +524,10 @@ recursively."
   ;; Package to derivation-path mapping.
   (make-weak-key-hash-table 100))
 
+(define-public (%invalidate-derivation-cache!)
+  "Invalidate the package-to-derivation mapping cache."
+  (set! %derivation-cache (make-weak-key-hash-table 100)))
+
 (define (cache package system thunk)
   "Memoize the return values of THUNK as the derivation of PACKAGE on
 SYSTEM."
        Modified   guix/scripts/system.scm
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 57f4221..63b2c7b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -26,6 +26,7 @@
   #:use-module (guix utils)
   #:use-module (guix monads)
   #:use-module (guix profiles)
+  #:use-module (guix build-system gnu)
   #:use-module (guix scripts build)
   #:use-module (guix build utils)
   #:use-module (guix build install)
@@ -33,8 +34,11 @@
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)
   #:use-module (gnu packages grub)
+  #:use-module (gnu packages package-management)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (guix-system
@@ -118,18 +122,24 @@
 
       (return #t))))
 
-(define* (copy-closure item target
-                       #:key (log-port (current-error-port)))
-  "Copy ITEM and all its dependencies to the store under root directory
+(define* (copy-closures items target
+                        #:key (log-port (current-error-port)))
+  "Copy ITEMS and all their dependencies to the store under root directory
 TARGET, and register them."
-  (mlet* %store-monad ((refs    (references* item))
-                       (to-copy (topologically-sorted*
-                                 (delete-duplicates (cons item refs)
-                                                    string=?))))
+  (mlet* %store-monad ((refs     (sequence %store-monad
+                                           (map references* items)))
+                       (items -> (append items (concatenate refs)))
+                       (to-copy  (topologically-sorted*
+                                  (delete-duplicates items string=?))))
     (sequence %store-monad
               (map (cut copy-item <> target #:log-port log-port)
                    to-copy))))
 
+(define* (copy-closure item target
+                       #:key (log-port (current-error-port)))
+  (copy-closures (list item) target
+                 #:log-port log-port))
+
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
                   grub? grub.cfg device)
@@ -163,6 +173,103 @@ When GRUB? is true, install GRUB on DEVICE, using 
GRUB.CFG."
 
     (return #t)))
 
+(define (build-user-group)
+  "Return the name of the build user group."
+  (define write-group-name
+    #~(call-with-output-file #$output
+        (lambda (port)
+          (write (group:name (getgrnam (getgid))) port))))
+
+  (mlet* %store-monad ((group (gexp->derivation "build-user-group"
+                                                write-group-name))
+                       (_     (built-derivations (list group))))
+    (return
+     (call-with-input-file (derivation->output-path group) read))))
+
+(define* (spawn-target-daemon daemon target #:optional build-group)
+  "Spawn DAEMON, the absolute file name of the 'guix-daemon' binary stored
+under TARGET, so that it uses the store under TARGET.  Return an open
+connection to the daemon, and its PID."
+  (match (primitive-fork)
+    (0
+     ;; TODO: Add '--prefix' option to 'guix-daemon' and use that here, along
+     ;; with setting 'NIX_OTHER_STORES'.
+     (chroot target)
+     (apply execl daemon "guix-daemon"
+            (if build-group
+                (list (string-append "--build-users-group=" build-group))
+                '())))
+    (pid
+     (let ((socket (string-append target "/var/guix/daemon-socket/socket")))
+       (let try ((count 0))
+         (guard (c ((nix-connection-error? c)
+                    (if (< count 3)
+                        (begin
+                          (pk 'try count)
+                          (usleep 500000)
+                          (try (+ 1 count)))
+                        (raise c))))
+           (values (open-connection socket) pid)))))))
+
+(define (standard-derivations)
+  "Return the file name of all the standard derivations."
+  (match (standard-inputs (%current-system))
+    (((labels derivations . _) ...)
+     (map derivation-file-name derivations))))
+
+(define* (target-store store target
+                       #:key dry-run? use-substitutes? system)
+  (define guix-daemon
+    (mlet* %store-monad
+        ((drv       (package->derivation guix))
+         (out ->    (derivation->output-path drv))
+         (guile ->  (derivation-file-name (%guile-for-build)))
+         (%         (maybe-build (list drv)
+                                 #:use-substitutes? use-substitutes?))
+         (c         (begin
+                      (format #t (_ "copying Guix to ~a...~%") target)
+                      (copy-closures (cons* out guile (standard-derivations))
+                                     target))))
+      (return (string-append out "/bin/guix-daemon"))))
+
+  (define (copy-configuration target)
+    (let ((target-config (string-append target "/etc/guix")))
+      (mkdir-p target-config)
+      (copy-file (string-append %config-directory "/acl")
+                 (string-append target-config "/acl"))
+      (copy-file "/etc/group" (string-append target "/etc/group"))))
+
+  (if (or dry-run? (string=? target "/"))
+      (values store #f)
+      (let ((daemon (run-with-store store guix-daemon #:system system))
+            (group  (run-with-store store (build-user-group) #:system system)))
+        ;; Copy all that's needed to run the daemon.
+        (copy-configuration target)
+
+        ;; Now let's talk to the target daemon.
+        (let-values (((target-store pid)
+                      (spawn-target-daemon daemon target group)))
+          (close-connection store)
+          (%invalidate-derivation-cache!)
+          (values target-store pid)))))
+
+(define* (call-with-store target store proc
+                          #:key action dry-run? use-substitutes? system)
+  (if (eq? action 'init)
+      (let-values (((store pid)
+                    (target-store store (canonicalize-path target)
+                                  #:dry-run? dry-run?
+                                  #:use-substitutes? use-substitutes?
+                                  #:system system)))
+        (dynamic-wind
+          (const #f)
+          (lambda ()
+            (proc store))
+          (lambda ()
+            (close-connection store)
+            (kill pid SIGTERM))))
+      (proc store)))
+
 
 ;;;
 ;;; Reconfiguration.
@@ -433,35 +540,42 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
            (fail))))
       args))
 
-  (with-error-handling
-    (let* ((opts     (parse-options))
-           (args     (option-arguments opts))
-           (file     (first args))
-           (action   (assoc-ref opts 'action))
-           (system   (assoc-ref opts 'system))
-           (os       (if file
-                         (read-operating-system file)
-                         (leave (_ "no configuration file specified~%"))))
-
-           (dry?     (assoc-ref opts 'dry-run?))
-           (grub?    (assoc-ref opts 'install-grub?))
-           (target   (match args
-                       ((first second) second)
-                       (_ #f)))
-           (device   (and grub?
-                          (grub-configuration-device
-                           (operating-system-bootloader os))))
-
-           (store    (open-connection)))
-      (set-build-options-from-command-line store opts)
-
-      (run-with-store store
-        (perform-action action os
-                        #:dry-run? dry?
-                        #:use-substitutes? (assoc-ref opts 'substitutes?)
-                        #:image-size (assoc-ref opts 'image-size)
-                        #:grub? grub?
-                        #:target target #:device device)
-        #:system system))))
+  (let* ((opts     (parse-options))
+         (args     (option-arguments opts))
+         (file     (first args))
+         (action   (assoc-ref opts 'action))
+         (system   (assoc-ref opts 'system))
+         (os       (if file
+                       (read-operating-system file)
+                       (leave (_ "no configuration file specified~%"))))
+
+         (dry?     (assoc-ref opts 'dry-run?))
+         (grub?    (assoc-ref opts 'install-grub?))
+         (target   (match args
+                     ((first second) second)
+                     (_ #f)))
+         (subst?   (assoc-ref opts 'substitutes?))
+         (device   (and grub?
+                        (grub-configuration-device
+                         (operating-system-bootloader os))))
+
+         (store    (open-connection)))
+    (set-build-options-from-command-line store opts)
+
+    (call-with-store target store
+                     (lambda (store)
+                       (run-with-store store
+                         (perform-action action os
+                                         #:dry-run? dry?
+                                         #:use-substitutes? subst?
+                                         #:image-size (assoc-ref opts 
'image-size)
+                                         #:grub? grub?
+                                         #:target target #:device device)
+                         ;; (gexp->derivation "foo" #~(mkdir #$output))
+                         #:system system))
+                     #:action action
+                     #:dry-run? dry?
+                     #:use-substitutes? subst?
+                     #:system system)))
 
 ;;; system.scm ends here