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