nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guix system: Convert to monadic style. 

* guix/scripts/system.scm (references*, topologically-sorted*,
  show-what-to-build*): New procedures.
  (copy-closure): Turn into a monadic procedure.
  (install): Likewise, and adjust parameter list.
  (switch-to-system): Likewise.
  (system-derivation-for-action, grub.cfg, maybe-build, perform-action):
  New procedures.
  (guix-system): Use them.
This commit is contained in:
Ludovic Courtès 2014-07-13 16:13:42 +02:00
parent 66670cf39c
commit 8e42796bdc
1 changed files with 181 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

291
guix/scripts/system.scm
View File

@ -40,6 +40,11 @@
#:export (guix-system #:export (guix-system
read-operating-system)) read-operating-system))
;;;
;;; Operating system declaration.
;;;
(define %user-module (define %user-module
;; Module in which the machine description file is loaded. ;; Module in which the machine description file is loaded.
(let ((module (make-fresh-user-module))) (let ((module (make-fresh-user-module)))
@ -76,51 +81,76 @@
(leave (_ "failed to load operating system file '~a': ~s~%") (leave (_ "failed to load operating system file '~a': ~s~%")
file args)))))) file args))))))
(define* (copy-closure store item target
;;;
;;; Installation.
;;;
;; TODO: Factorize.
(define references*
(store-lift references))
(define topologically-sorted*
(store-lift topologically-sorted))
(define show-what-to-build*
(store-lift show-what-to-build))
(define* (copy-closure item target
#:key (log-port (current-error-port))) #:key (log-port (current-error-port)))
"Copy ITEM to the store under root directory TARGET and register it." "Copy ITEM to the store under root directory TARGET and register it."
(let ((dest (string-append target item)) (mlet* %store-monad ((refs (references* item)))
(refs (references store item))) (let ((dest (string-append target item)))
(format log-port "copying '~a'...~%" item) (format log-port "copying '~a'...~%" item)
(copy-recursively item dest (copy-recursively item dest
#:log (%make-void-port "w")) #:log (%make-void-port "w"))
;; Register ITEM; as a side-effect, it resets timestamps, etc. ;; Register ITEM; as a side-effect, it resets timestamps, etc.
(unless (register-path item (unless (register-path item
#:prefix target #:prefix target
#:references refs) #:references refs)
(leave (_ "failed to register '~a' under '~a'~%") (leave (_ "failed to register '~a' under '~a'~%")
item target)))) item target))
(define* (install store os-dir target (return #t))))
(define* (install os-drv target
#:key (log-port (current-output-port)) #:key (log-port (current-output-port))
grub? grub.cfg device) grub? grub.cfg device)
"Copy OS-DIR and its dependencies to directory TARGET. TARGET must be an "Copy the output of OS-DRV and its dependencies to directory TARGET. TARGET
absolute directory name since that's what 'guix-register' expects. must be an absolute directory name since that's what 'guix-register' expects.
When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
(define to-copy (define (maybe-copy to-copy)
(let ((lst (delete-duplicates (cons os-dir (references store os-dir)) (with-monad %store-monad
string=?))) (if (string=? target "/")
(topologically-sorted store lst))) (begin
(warning (_ "initializing the current root file system~%"))
(return #t))
(begin
;; Make sure the target store exists.
(mkdir-p (string-append target (%store-prefix)))
(if (string=? target "/") ;; Copy items to the new store.
(warning (_ "initializing the current root file system~%")) (sequence %store-monad
(begin (map (cut copy-closure <> target #:log-port log-port)
;; Make sure the target store exists. to-copy))))))
(mkdir-p (string-append target (%store-prefix)))
;; Copy items to the new store. (mlet* %store-monad ((os-dir -> (derivation->output-path os-drv))
(for-each (cut copy-closure store <> target #:log-port log-port) (refs (references* os-dir))
to-copy))) (lst -> (delete-duplicates (cons os-dir refs)
string=?))
(to-copy (topologically-sorted* lst))
(% (maybe-copy to-copy)))
;; Create a bunch of additional files. ;; Create a bunch of additional files.
(format log-port "populating '~a'...~%" target) (format log-port "populating '~a'...~%" target)
(populate-root-file-system os-dir target) (populate-root-file-system os-dir target)
(when grub? (when grub?
(unless (false-if-exception (install-grub grub.cfg device target)) (unless (false-if-exception (install-grub grub.cfg device target))
(leave (_ "failed to install GRUB on device '~a'~%") device)))) (leave (_ "failed to install GRUB on device '~a'~%") device)))
(return #t)))
;;; ;;;
@ -131,25 +161,23 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
;; The system profile. ;; The system profile.
(string-append %state-directory "/profiles/system")) (string-append %state-directory "/profiles/system"))
(define* (switch-to-system store os system-directory (define* (switch-to-system os
#:optional (profile %system-profile) #:optional (profile %system-profile))
#:key system) "Make a new generation of PROFILE pointing to the directory of OS, switch to
"Make a new generation of PROFILE pointing to SYSTEM-DIRECTORY, which is the it atomically, and then run OS's activation script."
directory corresponding to OS on SYSTEM, switch to it atomically, and then run (mlet* %store-monad ((drv (operating-system-derivation os))
OS's activation script." (script (operating-system-activation-script os)))
(let* ((number (+ 1 (generation-number profile))) (let* ((system (derivation->output-path drv))
(generation (generation-file-name profile number))) (number (+ 1 (generation-number profile)))
(symlink system generation) (generation (generation-file-name profile number)))
(switch-symlinks profile generation) (symlink system generation)
(switch-symlinks profile generation)
(run-with-store store (format #t (_ "activating system...~%"))
(mlet %store-monad ((script (operating-system-activation-script os))) (return (primitive-load (derivation->output-path script)))
(format #t (_ "activating system...~%"))
(return (primitive-load (derivation->output-path script))))
#:system system)
;; TODO: Run 'deco reload ...'. ;; TODO: Run 'deco reload ...'.
)) )))
(define-syntax-rule (unless-file-not-found exp) (define-syntax-rule (unless-file-not-found exp)
(catch 'system-error (catch 'system-error
@ -188,6 +216,92 @@ OS's activation script."
(generation-numbers profile)))) (generation-numbers profile))))
(filter-map system->grub-entry systems))) (filter-map system->grub-entry systems)))
;;;
;;; Action.
;;;
(define* (system-derivation-for-action os action
#:key image-size)
"Return as a monadic value the derivation for OS according to ACTION."
(case action
((build init reconfigure)
(operating-system-derivation os))
((vm-image)
(system-qemu-image os #:disk-image-size image-size))
((vm)
(system-qemu-image/shared-store-script os))
((disk-image)
(system-disk-image os #:disk-image-size image-size))))
(define (grub.cfg os)
"Return the GRUB configuration file for OS."
(operating-system-grub.cfg os (previous-grub-entries)))
(define* (maybe-build drvs
#:key dry-run? use-substitutes?)
"Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
true."
(with-monad %store-monad
(>>= (show-what-to-build* drvs
#:dry-run? dry-run?
#:use-substitutes? use-substitutes?)
(lambda (_)
(if dry-run?
(return #f)
(built-derivations drvs))))))
(define* (perform-action action os
#:key grub? dry-run?
use-substitutes? device target
image-size)
"Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is
the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
is the size of the image to be built, for the 'vm-image' and 'disk-image'
actions."
(mlet* %store-monad
((sys (system-derivation-for-action os action
#:image-size image-size))
(grub (package->derivation grub))
(grub.cfg (grub.cfg os))
(drvs -> (if (and grub? (memq action '(init reconfigure)))
(list sys grub grub.cfg)
(list sys)))
(% (maybe-build drvs #:dry-run? dry-run?
#:use-substitutes? use-substitutes?)))
(if dry-run?
(return #f)
(begin
(for-each (cut format #t "~a~%" <>)
(map derivation->output-path drvs))
;; Make sure GRUB is accessible.
(when grub?
(let ((prefix (derivation->output-path grub)))
(setenv "PATH"
(string-append prefix "/bin:" prefix "/sbin:"
(getenv "PATH")))))
(case action
((reconfigure)
(mlet %store-monad ((% (switch-to-system os)))
(when grub?
(unless (install-grub grub.cfg device target)
(leave (_ "failed to install GRUB on device '~a'~%")
device)))))
((init)
(newline)
(format #t (_ "initializing operating system under '~a'...~%")
target)
(install sys (canonicalize-path target)
#:grub? grub?
#:grub.cfg (derivation->output-path grub.cfg)
#:device device))
(else
;; All we had to do was to build SYS.
(return (derivation->output-path sys))))))))
;;; ;;;
;;; Options. ;;; Options.
@ -315,69 +429,26 @@ Build the operating system declared in FILE according to ACTION.\n"))
(os (if file (os (if file
(read-operating-system file) (read-operating-system file)
(leave (_ "no configuration file specified~%")))) (leave (_ "no configuration file specified~%"))))
(mdrv (case action
((build init reconfigure)
(operating-system-derivation os))
((vm-image)
(let ((size (assoc-ref opts 'image-size)))
(system-qemu-image os
#:disk-image-size size)))
((vm)
(system-qemu-image/shared-store-script os))
((disk-image)
(let ((size (assoc-ref opts 'image-size)))
(system-disk-image os
#:disk-image-size size)))))
(store (open-connection))
(dry? (assoc-ref opts 'dry-run?)) (dry? (assoc-ref opts 'dry-run?))
(drv (run-with-store store mdrv #:system system))
(grub? (assoc-ref opts 'install-grub?)) (grub? (assoc-ref opts 'install-grub?))
(old (previous-grub-entries)) (target (match args
(grub.cfg (run-with-store store ((first second) second)
(operating-system-grub.cfg os old) (_ #f)))
#:system system)) (device (and grub?
(grub (package-derivation store grub system)) (grub-configuration-device
(drv-lst (if grub? (operating-system-bootloader os))))
(list drv grub grub.cfg)
(list drv)))) (store (open-connection)))
(set-build-options-from-command-line store opts) (set-build-options-from-command-line store opts)
(show-what-to-build store drv-lst
#:dry-run? dry?
#:use-substitutes? (assoc-ref opts 'substitutes?))
(unless dry? (run-with-store store
(build-derivations store drv-lst) (perform-action action os
(display (derivation->output-path drv)) #:dry-run? dry?
(newline) #:use-substitutes? (assoc-ref opts 'substitutes?)
#:image-size (assoc-ref opts 'image-size)
;; Make sure GRUB is accessible. #:grub? grub?
(when grub #:target target #:device device)
(let ((prefix (derivation->output-path grub))) #:system system))))
(setenv "PATH"
(string-append prefix "/bin:" prefix "/sbin:"
(getenv "PATH")))))
(let ((target (match args
((first second) second)
(_ #f)))
(device (and grub?
(grub-configuration-device
(operating-system-bootloader os)))))
(case action
((reconfigure)
(switch-to-system store os (derivation->output-path drv)
#:system system)
(when grub?
(unless (install-grub grub.cfg device target)
(leave (_ "failed to install GRUB on device '~a'~%") device))))
((init)
(format #t (_ "initializing operating system under '~a'...~%")
target)
(install store (derivation->output-path drv)
(canonicalize-path target)
#:grub? grub?
#:grub.cfg (derivation->output-path grub.cfg)
#:device device))))))))
;;; system.scm ends here ;;; system.scm ends here