diff options
Diffstat (limited to 'guix/scripts/system.scm')
| -rw-r--r-- | guix/scripts/system.scm | 58 |
1 files changed, 41 insertions, 17 deletions
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 398a5a371b..27404772b7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -131,6 +131,27 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) +(define (install-grub* grub.cfg device target) + "This is a variant of 'install-grub' with error handling, lifted in +%STORE-MONAD" + (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (temp-gc-root (string-append gc-root ".new")) + (delete-file (lift1 delete-file %store-monad)) + (make-symlink (lift2 switch-symlinks %store-monad)) + (rename (lift2 rename-file %store-monad))) + (mbegin %store-monad + ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when + ;; 'install-grub' completes (being a bit paranoid.) + (make-symlink temp-gc-root grub.cfg) + + (munless (false-if-exception (install-grub grub.cfg device target)) + (delete-file temp-gc-root) + (leave (_ "failed to install GRUB on device '~a'~%") device)) + + ;; Register GRUB.CFG as a GC root so that its dependencies (background + ;; image, font, etc.) are not reclaimed. + (rename temp-gc-root gc-root)))) + (define* (install os-drv target #:key (log-port (current-output-port)) grub? grub.cfg device) @@ -151,18 +172,19 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; Copy items to the new store. (copy-closure to-copy target #:log-port log-port))))) - (mlet* %store-monad ((os-dir -> (derivation->output-path os-drv)) - (% (maybe-copy os-dir))) + (let ((os-dir (derivation->output-path os-drv)) + (format (lift format %store-monad)) + (populate (lift2 populate-root-file-system %store-monad))) - ;; Create a bunch of additional files. - (format log-port "populating '~a'...~%" target) - (populate-root-file-system os-dir target) + (mbegin %store-monad + (maybe-copy os-dir) - (when grub? - (unless (false-if-exception (install-grub grub.cfg device target)) - (leave (_ "failed to install GRUB on device '~a'~%") device))) + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate os-dir target) - (return #t))) + (mwhen grub? + (install-grub* grub.cfg device target))))) ;;; @@ -334,14 +356,11 @@ boot directly to the kernel or to the bootloader." (case action ((reconfigure) - (mlet %store-monad ((% (switch-to-system os))) - (when grub? - (unless (false-if-exception - (install-grub (derivation->output-path grub.cfg) - device "/")) - (leave (_ "failed to install GRUB on device '~a'~%") - device))) - (return #t))) + (mbegin %store-monad + (switch-to-system os) + (mwhen grub? + (install-grub* (derivation->output-path grub.cfg) + device "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") @@ -467,6 +486,11 @@ Build the operating system declared in FILE according to ACTION.\n")) (define (guix-system . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) |