diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 62 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 13 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 178 |
5 files changed, 200 insertions, 61 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 0a2e186da6..84904e29da 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -123,7 +123,7 @@ Export/import one or more packages from/to the store.\n")) (string->canonical-sexp (or arg %key-generation-parameters)))) (alist-cons 'generate-key params result))) - (lambda (key err) + (lambda (key proc err) (leave (_ "invalid key generation parameters: ~a: ~a~%") (error-source err) (error-string err)))))) @@ -248,7 +248,7 @@ this may take time...~%")) (let* ((pair (catch 'gcry-error (lambda () (generate-key parameters)) - (lambda (key err) + (lambda (key proc err) (leave (_ "key generation failed: ~a: ~a~%") (error-source err) (error-string err))))) @@ -275,7 +275,7 @@ the input port." (catch 'gcry-error (lambda () (string->canonical-sexp (get-string-all (current-input-port)))) - (lambda (key err) + (lambda (key proc err) (leave (_ "failed to read public key: ~a: ~a~%") (error-source err) (error-string err))))) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 62717bb09c..e9900689fa 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -81,6 +81,13 @@ to stdout upon success." (canonical-sexp->string subject))) (leave (_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) + +(define %default-port-conversion-strategy + ;; This fluid is in Guile > 2.0.5. + (if (defined? '%default-port-conversion-strategy) + (@ (guile) %default-port-conversion-strategy) + (make-fluid #f))) + ;;; ;;; Entry point with 'openssl'-compatible interface. We support this @@ -89,30 +96,39 @@ to stdout upon success." ;;; (define (guix-authenticate . args) - (match args - ;; As invoked by guix-daemon. - (("rsautl" "-sign" "-inkey" key "-in" hash-file) - (call-with-input-file hash-file - (lambda (port) - (sign-with-key key port)))) - ;; As invoked by Nix/Crypto.pm (used by Hydra.) - (("rsautl" "-sign" "-inkey" key) - (sign-with-key key (current-input-port))) - ;; As invoked by guix-daemon. - (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) - (call-with-input-file signature-file - (lambda (port) - (validate-signature port)))) - ;; As invoked by Nix/Crypto.pm (used by Hydra.) - (("rsautl" "-verify" "-inkey" _ "-pubin") - (validate-signature (current-input-port))) - (("--help") - (display (_ "Usage: guix authenticate OPTION... + ;; Signature sexps written to stdout may contain binary data, so force + ;; ISO-8859-1 encoding so that things are not mangled. See + ;; <http://bugs.gnu.org/17312> for details. + (set-port-encoding! (current-output-port) "ISO-8859-1") + (set-port-conversion-strategy! (current-output-port) 'error) + + ;; Same goes for input ports. + (with-fluids ((%default-port-encoding "ISO-8859-1") + (%default-port-conversion-strategy 'error)) + (match args + ;; As invoked by guix-daemon. + (("rsautl" "-sign" "-inkey" key "-in" hash-file) + (call-with-input-file hash-file + (lambda (port) + (sign-with-key key port)))) + ;; As invoked by Nix/Crypto.pm (used by Hydra.) + (("rsautl" "-sign" "-inkey" key) + (sign-with-key key (current-input-port))) + ;; As invoked by guix-daemon. + (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) + (call-with-input-file signature-file + (lambda (port) + (validate-signature port)))) + ;; As invoked by Nix/Crypto.pm (used by Hydra.) + (("rsautl" "-verify" "-inkey" _ "-pubin") + (validate-signature (current-input-port))) + (("--help") + (display (_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to be used internally by 'guix-daemon'.\n"))) - (("--version") - (show-version-and-exit "guix authenticate")) - (else - (leave (_ "wrong arguments"))))) + (("--version") + (show-version-and-exit "guix authenticate")) + (else + (leave (_ "wrong arguments")))))) ;;; authenticate.scm ends here diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index c5cae4b07a..d87cad3f23 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -443,9 +443,11 @@ success, #f otherwise." "-i" (build-machine-private-key machine) (build-machine-name machine) "guix" "archive" "--missing") - (open-input-string files)))) + (open-input-string files))) + ((result) + (get-string-all missing))) (for-each waitpid pids) - (string-tokenize (get-string-all missing)))) + (string-tokenize result))) (with-store store (guard (c ((nix-protocol-error? c) @@ -472,7 +474,9 @@ success, #f otherwise." (warning (_ "failed while exporting files to '~a': ~a~%") (build-machine-name machine) (strerror (system-error-errno args))))))) - #t)))) + + ;; Wait for the 'lsh' process to complete. + (zero? (close-pipe pipe)))))) (define (retrieve-files files machine) "Retrieve FILES from MACHINE's store, and import them." @@ -500,7 +504,8 @@ success, #f otherwise." #:log-port (current-error-port) #:lock? #f))) - #t))))) + ;; Wait for the 'lsh' process to complete. + (zero? (close-pipe pipe))))))) ;;; diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 8e35612e3a..c70a4f626c 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -252,7 +252,7 @@ failure." (catch 'gcry-error (lambda () (string->canonical-sexp signature)) - (lambda (err . rest) + (lambda (key proc err) (leave (_ "signature is not a valid \ s-expression: ~s~%") signature)))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 582027244c..345d8c3e5f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -19,13 +19,20 @@ (define-module (guix scripts system) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix scripts build) + #:use-module (guix build utils) + #:use-module (guix build install) + #:use-module (gnu system) #:use-module (gnu system vm) + #:use-module (gnu system grub) + #:use-module (gnu packages grub) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-system @@ -63,6 +70,48 @@ (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) +(define* (copy-closure store item target + #:key (log-port (current-error-port))) + "Copy ITEM to the store under root directory TARGET and register it." + (let ((dest (string-append target item)) + (refs (references store item))) + (format log-port "copying '~a'...~%" item) + (copy-recursively item dest + #:log (%make-void-port "w")) + + ;; Register ITEM; as a side-effect, it resets timestamps, etc. + (unless (register-path item + #:prefix target + #:references refs) + (leave (_ "failed to register '~a' under '~a'~%") + item target)))) + +(define* (install store os-dir target + #:key (log-port (current-output-port)) + grub? grub.cfg device) + "Copy OS-DIR and its dependencies to directory TARGET. TARGET must be an +absolute directory name since that's what 'guix-register' expects. + +When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." + (define to-copy + (let ((lst (delete-duplicates (cons os-dir (references store os-dir)) + string=?))) + (topologically-sorted store lst))) + + (if (string=? target "/") + (warning (_ "initializing the current root file system~%")) + ;; Copy items to the new store. + (for-each (cut copy-closure store <> target #:log-port log-port) + to-copy)) + + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate-root-file-system target) + + (when grub? + (unless (install-grub grub.cfg device target) + (leave (_ "failed to install GRUB on device '~a'~%") device)))) + ;;; ;;; Options. @@ -71,12 +120,24 @@ (define (show-help) (display (_ "Usage: guix system [OPTION] ACTION FILE Build the operating system declared in FILE according to ACTION.\n")) - (display (_ "Currently the only valid values for ACTION are 'vm', which builds -a virtual machine of the given operating system that shares the host's store, -and 'vm-image', which builds a virtual machine image that stands alone.\n")) + (newline) + (display (_ "The valid values for ACTION are:\n")) + (display (_ "\ + - 'build', build the operating system without installing anything\n")) + (display (_ "\ + - 'vm', build a virtual machine image that shares the host's store\n")) + (display (_ "\ + - 'vm-image', build a freestanding virtual machine image\n")) + (display (_ "\ + - 'disk-image', build a disk image, suitable for a USB stick\n")) + (display (_ "\ + - 'init', initialize a root file system to run GNU.\n")) + (show-build-options-help) (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) + (display (_ " + --no-grub for 'init', do not install GRUB")) (newline) (display (_ " -h, --help display this help and exit")) @@ -98,6 +159,9 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) result))) + (option '("no-grub") #f #f + (lambda (opt name arg result) + (alist-delete 'install-grub? result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -110,7 +174,8 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0) - (image-size . ,(* 900 (expt 2 20))))) + (image-size . ,(* 900 (expt 2 20))) + (install-grub? . #t))) ;;; @@ -125,43 +190,96 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (leave (_ "~A: unrecognized option~%") name)) (lambda (arg result) (if (assoc-ref result 'action) - (let ((previous (assoc-ref result 'argument))) - (if previous - (leave (_ "~a: extraneous argument~%") previous) - (alist-cons 'argument arg result))) + (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((vm) - (alist-cons 'action action result)) - ((vm-image) + ((build vm vm-image disk-image init) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) %default-options)) + (define (match-pair car) + ;; Return a procedure that matches a pair with CAR. + (match-lambda + ((head . tail) + (and (eq? car head) tail)) + (_ #f))) + + (define (option-arguments opts) + ;; Extract the plain arguments from OPTS. + (let* ((args (reverse (filter-map (match-pair 'argument) opts))) + (count (length args)) + (action (assoc-ref opts 'action))) + (define (fail) + (leave (_ "wrong number of arguments for action '~a'~%") + action)) + + (case action + ((build vm vm-image disk-image) + (unless (= count 1) + (fail))) + ((init) + (unless (= count 2) + (fail)))) + args)) + (with-error-handling - (let* ((opts (parse-options)) - (file (assoc-ref opts 'argument)) - (action (assoc-ref opts 'action)) - (os (if file - (read-operating-system file) - (leave (_ "no configuration file specified~%")))) - (mdrv (case action - ((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)))) - (store (open-connection)) - (dry? (assoc-ref opts 'dry-run?)) - (drv (run-with-store store mdrv))) + (let* ((opts (parse-options)) + (args (option-arguments opts)) + (file (first args)) + (action (assoc-ref opts 'action)) + (os (if file + (read-operating-system file) + (leave (_ "no configuration file specified~%")))) + (mdrv (case action + ((build init) + (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?)) + (drv (run-with-store store mdrv)) + (grub? (assoc-ref opts 'install-grub?)) + (grub.cfg (run-with-store store + (operating-system-grub.cfg os))) + (grub (package-derivation store grub)) + (drv-lst (if grub? + (list drv grub grub.cfg) + (list drv)))) (set-build-options-from-command-line store opts) - (show-what-to-build store (list drv) + (show-what-to-build store drv-lst #:dry-run? dry? #:use-substitutes? (assoc-ref opts 'substitutes?)) (unless dry? - (build-derivations store (list drv)) + (build-derivations store drv-lst) (display (derivation->output-path drv)) - (newline))))) + (newline) + + (when (eq? action 'init) + (let* ((target (second args)) + (device (grub-configuration-device + (operating-system-bootloader os)))) + (format #t (_ "initializing operating system under '~a'...~%") + target) + + (when grub + (let ((prefix (derivation->output-path grub))) + (setenv "PATH" + (string-append prefix "/bin:" prefix "/sbin:" + (getenv "PATH"))))) + + (install store (derivation->output-path drv) + (canonicalize-path target) + #:grub? grub? + #:grub.cfg (derivation->output-path grub.cfg) + #:device device))))))) |