From 66ef5411471e8d5f25815b9ab1f360ad56e08544 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 00:17:43 +0200 Subject: offload: Better synchronize with remote invocation of 'guix archive --missing'. * guix/scripts/offload.scm (send-files)[missing-files]: Call 'waitpid' after reading all of MISSING. --- guix/scripts/offload.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index c5cae4b07..e340b7e8c 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) -- cgit v1.3 From 30ce8012cd6265b12f756283633be94a547bf990 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 00:24:24 +0200 Subject: offload: '{send,receive}-files' wait for completion of the transfer. Fixes situations where the remote 'guix build' is invoked before the .drv has been completely copied, as reported at . In some cases 'send-files' would return before the other end is done importing the files, and so the subsequent 'guix build' invocation would just miss the .drv file it refers to. * guix/utils.scm (call-with-decompressed-port): Don't close PORT. (call-with-compressed-output-port): Likewise. * tests/utils.scm ("compressed-output-port + decompressed-port"): Adjust accordingly. * guix/scripts/offload.scm (send-files): Add explicit (close-pipe pipe) call. (retrieve-files): Likewise. --- guix/scripts/offload.scm | 7 +++++-- guix/utils.scm | 8 ++------ tests/utils.scm | 6 ++++-- 3 files changed, 11 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e340b7e8c..d87cad3f2 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -474,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." @@ -502,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/utils.scm b/guix/utils.scm index 84cb5ae98..53fc68d27 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -229,14 +229,12 @@ a symbol such as 'xz." (define (call-with-decompressed-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that decompresses data -read from PORT according to COMPRESSION, a symbol such as 'xz. PORT is closed -as soon as PROC's dynamic extent is entered." +read from PORT according to COMPRESSION, a symbol such as 'xz." (let-values (((decompressed pids) (decompressed-port compression port))) (dynamic-wind (const #f) (lambda () - (close-port port) (proc decompressed)) (lambda () (close-port decompressed) @@ -286,14 +284,12 @@ of PIDs to wait for." (define (call-with-compressed-output-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that compresses data -that goes to PORT according to COMPRESSION, a symbol such as 'xz. PORT is -closed as soon as PROC's dynamic extent is entered." +that goes to PORT according to COMPRESSION, a symbol such as 'xz." (let-values (((compressed pids) (compressed-output-port compression port))) (dynamic-wind (const #f) (lambda () - (close-port port) (proc compressed)) (lambda () (close-port compressed) diff --git a/tests/utils.scm b/tests/utils.scm index 4d2d123c6..8ad399f75 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -164,10 +164,12 @@ (false-if-exception (delete-file temp-file)) (test-assert "compressed-output-port + decompressed-port" (let* ((file (search-path %load-path "guix/derivations.scm")) - (data (call-with-input-file file get-bytevector-all))) - (call-with-compressed-output-port 'xz (open-file temp-file "w0b") + (data (call-with-input-file file get-bytevector-all)) + (port (open-file temp-file "w0b"))) + (call-with-compressed-output-port 'xz port (lambda (compressed) (put-bytevector compressed data))) + (close-port port) (bytevector=? data (call-with-decompressed-port 'xz (open-file temp-file "r0b") -- cgit v1.3 From 1c96c1bbabb9646aba2a3860cac02157f56c4dd1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 23:59:08 +0200 Subject: linux-initrd: Mount / as a unionfs when asking for a volatile root. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/fuse. (boot-system): Add #:unionfs parameter. Invoke UNIONFS instead of copying files over when VOLATILE-ROOT? is true. * gnu/system/linux-initrd.scm (expression->initrd): Add #:inputs parameter. [files-to-copy]: New procedure. [builder]: Add 'to-copy' parameter; honor it. (qemu-initrd)[linux-modules]: Add 'fuse.ko' when VOLATILE-ROOT?. Pass UNIONFS-FUSE/STATIC as #:inputs; change builder to pass #:unionfs to 'boot-system'. --- gnu/system/linux-initrd.scm | 75 +++++++++++++++++++++++++++++++++------------ guix/build/linux-initrd.scm | 38 ++++++++++------------- 2 files changed, 73 insertions(+), 40 deletions(-) (limited to 'guix') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 42ca29cb5..786e06876 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -21,12 +21,15 @@ #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix)) + #:use-module ((guix derivations) + #:select (derivation->output-path)) #:use-module (gnu packages cpio) #:use-module (gnu packages compression) #:use-module (gnu packages linux) #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (expression->initrd qemu-initrd @@ -49,12 +52,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) + (inputs '()) (linux #f) (linux-modules '())) "Return a package that contains a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list -of `.ko' file names to be copied from LINUX into the initrd. MODULES is a -list of Guile module names to be embedded in the initrd." +of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list +of additional inputs to be copied in the initrd. MODULES is a list of Guile +module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. @@ -63,7 +68,16 @@ list of Guile module names to be embedded in the initrd." ;; Return a regexp that matches STR exactly. (string-append "^" (regexp-quote str) "$")) - (define builder + (define (files-to-copy) + (mlet %store-monad ((inputs (lower-inputs inputs))) + (return (map (match-lambda + ((_ drv) + (derivation->output-path drv)) + ((_ drv sub-drv) + (derivation->output-path drv sub-drv))) + inputs)))) + + (define (builder to-copy) `(begin (use-modules (guix build utils) (ice-9 pretty-print) @@ -137,6 +151,18 @@ list of Guile module names to be embedded in the initrd." ,module module-dir)))) linux-modules)) + ,@(if (null? to-copy) + '() + `((let ((store ,(string-append "." (%store-prefix)))) + (mkdir-p store) + ;; XXX: Should we do export-references-graph? + (for-each (lambda (input) + (let ((target + (string-append store "/" + (basename input)))) + (copy-recursively input target))) + ',to-copy)))) + ;; Reset the timestamps of all the files that will make it in the ;; initrd. (for-each (cut utime <> 0 0 0 0) @@ -184,8 +210,10 @@ list of Guile module names to be embedded in the initrd." ("modules/compiled" ,compiled) ,@(if linux `(("linux" ,linux)) - '()))))) - (derivation-expression name builder + '()) + ,@inputs))) + (to-copy (files-to-copy))) + (derivation-expression name (builder to-copy) #:modules '((guix build utils)) #:inputs inputs))) @@ -224,22 +252,31 @@ to it are lost." '()) ,@(if (assoc-ref mounts '9p) virtio-9p-modules + '()) + ,@(if volatile-root? + '("fuse.ko") '()))) - (expression->initrd - `(begin - (use-modules (guix build linux-initrd)) - - (boot-system #:mounts ',mounts - #:linux-modules ',linux-modules - #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot? - #:volatile-root? ',volatile-root?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules)) + (mlet %store-monad + ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) + (expression->initrd + `(begin + (use-modules (guix build linux-initrd)) + + (boot-system #:mounts ',mounts + #:linux-modules ',linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? ',guile-modules-in-chroot? + #:unionfs ,unionfs + #:volatile-root? ',volatile-root?)) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:linux linux-libre + #:linux-modules linux-modules + #:inputs (if volatile-root? + `(("unionfs" ,unionfs-fuse/static)) + '())))) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 61d4304b6..5d4446e72 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -143,7 +143,10 @@ (symlink "/proc/self/fd" (scope "dev/fd")) (symlink "/proc/self/fd/0" (scope "dev/stdin")) (symlink "/proc/self/fd/1" (scope "dev/stdout")) - (symlink "/proc/self/fd/2" (scope "dev/stderr"))) + (symlink "/proc/self/fd/2" (scope "dev/stderr")) + + ;; File systems in user space (FUSE). + (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) (define %host-qemu-ipv4-address (inet-pton AF_INET "10.0.2.10")) @@ -212,7 +215,7 @@ the last argument of `mknod'." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? + volatile-root? unionfs (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -277,27 +280,20 @@ to it are lost." (lambda () (if volatile-root? (begin - ;; XXX: For lack of a union file system... (mkdir-p "/real-root") (mount root "/real-root" "ext3" MS_RDONLY) - (mount "none" "/root" "tmpfs") - - ;; XXX: 'copy-recursively' cannot deal with device nodes, so - ;; explicitly avoid /dev. - (for-each (lambda (file) - (unless (string=? "dev" file) - (copy-recursively (string-append "/real-root/" - file) - (string-append "/root/" - file) - #:log (%make-void-port - "w")))) - (scandir "/real-root" - (lambda (file) - (not (member file '("." "..")))))) - - ;; TODO: Unmount /real-root. - ) + (mkdir-p "/rw-root") + (mount "none" "/rw-root" "tmpfs") + + ;; We want read-write /dev nodes. + (make-essential-device-nodes #:root "/rw-root") + + ;; Make /root a union of the tmpfs and the actual root. + (unless (zero? (system* unionfs "-o" + "cow,allow_other,use_ino,dev" + "/rw-root=RW:/real-root=RO" + "/root")) + (error "unionfs failed"))) (mount root "/root" "ext3"))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" -- cgit v1.3 From 395bea2a53ed7398e52a0a85370a554501af5678 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Apr 2014 12:25:25 +0200 Subject: download: Improve progress report output. * guix/build/download.scm (url-fetch): Make current-output-port unbuffered. --- guix/build/download.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 54115a9de..5d881b93e 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -307,7 +307,10 @@ on success." uri) #f))) - (setvbuf (current-output-port) _IOLBF) + ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means + ;; '\n', not '\r', so it's not appropriate here. + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) _IOLBF) (let try ((uri uri)) -- cgit v1.3 From 50db7d82b3f3ab8ec382132b06a1400c0044b89e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Apr 2014 23:23:34 +0200 Subject: nar: Really really protect the temporary store directory from GC. This is a follow-up to 6071b55e10b7b6e67d77ae058c8744834889e0b4. See for the original report, and for an alternate solution that has been discussed. * guix/nar.scm (temporary-store-file): Remove call to 'add-permanent-root'; don't loop. (with-temporary-store-file): Rewrite using 'with-store' and 'add-temp-root'. --- guix/nar.scm | 39 ++++++++++++++++----------------------- 1 file changed, 16 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/nar.scm b/guix/nar.scm index 0bf8ac317..6beda91c0 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -334,36 +334,29 @@ held." (unlock-store-file target))))) (define (temporary-store-file) - "Return the file name of a temporary file created in the store that is -protected from garbage collection." + "Return the file name of a temporary file created in the store." (let* ((template (string-append (%store-prefix) "/guix-XXXXXX")) (port (mkstemp! template))) (close-port port) - - ;; Make sure TEMPLATE is not collected while we populate it. - (add-permanent-root template) - - ;; There's a small window during which the GC could delete the file. Try - ;; again if that happens. - (if (file-exists? template) - (begin - ;; It's up to the caller to create that file or directory. - (delete-file template) - template) - (begin - (remove-permanent-root template) - (temporary-store-file))))) + template)) (define-syntax-rule (with-temporary-store-file name body ...) "Evaluate BODY with NAME bound to the file name of a temporary store item protected from GC." - (let ((name (temporary-store-file))) - (dynamic-wind - (const #t) - (lambda () - body ...) - (lambda () - (remove-permanent-root name))))) + (let loop ((name (temporary-store-file))) + (with-store store + ;; Add NAME to the current process' roots. (Opening this connection to + ;; the daemon allows us to reuse its code that deals with the + ;; per-process roots file.) + (add-temp-root store name) + + ;; There's a window during which GC could delete NAME. Try again when + ;; that happens. + (if (file-exists? name) + (begin + (delete-file name) + body ...) + (loop (temporary-store-file)))))) (define* (restore-one-item port #:key acl (verify-signature? #t) (lock? #t) -- cgit v1.3 From 6030d8493e13af81be63c3cee530d44b4dff1ad6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 01:36:31 +0200 Subject: pk-crypto: Use ISO-8859-1 for strings passed to 'gcry_sexp_new'. * guix/pk-crypto.scm (string->canonical-sexp): Pass "ISO-8859-1" as the 2nd argument to 'string->pointer'. * tests/pk-crypto.scm ("version"): New test. ("hash corrupt due to restrictive locale encoding"): New test. --- guix/pk-crypto.scm | 7 ++++++- tests/pk-crypto.scm | 24 ++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 481d3f246..351bf929c 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -134,8 +134,13 @@ thrown along with 'gcry-error'." (proc (pointer->procedure int ptr `(* * ,size_t ,int)))) (lambda (str) "Parse STR and return the corresponding gcrypt s-expression." + + ;; When STR comes from 'canonical-sexp->string', it may contain + ;; characters that are really meant to be interpreted as bytes as in a C + ;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the + ;; characters are preserved. (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc sexp (string->pointer str) 0 1))) + (err (proc sexp (string->pointer str "ISO-8859-1") 0 1))) (if (= 0 err) (pointer->canonical-sexp (dereference-pointer sexp)) (throw 'gcry-error err)))))) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 294c7f3df..67bbc83d4 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -64,6 +64,9 @@ (test-begin "pk-crypto") +(test-assert "version" + (gcrypt-version)) + (let ((sexps '("(foo bar)" ;; In Libgcrypt 1.5.3 the following integer is rendered as @@ -142,6 +145,27 @@ 1+ 0))) +(let ((bv (base16-string->bytevector + "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c"))) + (test-equal "hash corrupt due to restrictive locale encoding" + bv + + ;; In Guix up to 0.6 included this test would fail because at some point + ;; the hash value would be cropped to ASCII. In practice 'guix + ;; authenticate' would produce invalid signatures that would fail + ;; signature verification. + (let ((locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + (setlocale LC_ALL "C")) + (lambda () + (hash-data->bytevector + (string->canonical-sexp + (canonical-sexp->string + (bytevector->hash-data bv "sha256"))))) + (lambda () + (setlocale LC_ALL locale)))))) + (gc) ;; XXX: The test below is typically too long as it needs to gather enough entropy. -- cgit v1.3 From 6f69588529f9898dc4f2defd21603cc4abbaca17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 11:30:51 +0200 Subject: authenticate: Allow signatures with binary data to be written to stdout. Fixes . * guix/scripts/authenticate.scm (guix-authenticate): Add calls to 'set-port-encoding!' and 'set-port-conversion-strategy!'. Wrap body in 'with-fluids' form that sets '%default-port-encoding' and '%default-port-conversion-strategy'. * tests/guix-authenticate.sh: Add test. * tests/pk-crypto.scm ("hash corrupt due to restrictive locale encoding"): Add reference to bug. --- guix/scripts/authenticate.scm | 55 +++++++++++++++++++++++++------------------ tests/guix-authenticate.sh | 21 +++++++++++++++++ tests/pk-crypto.scm | 2 +- 3 files changed, 54 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 62717bb09..1b1e0b08c 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -89,30 +89,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 + ;; 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/tests/guix-authenticate.sh b/tests/guix-authenticate.sh index 35ec7ffd6..72c3d161d 100644 --- a/tests/guix-authenticate.sh +++ b/tests/guix-authenticate.sh @@ -72,3 +72,24 @@ if guix authenticate rsautl -verify \ then false else true fi + + +# Test for : make sure 'guix authenticate' produces +# valid signatures when run in the C locale. +echo "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c" \ + > "$hash" + +LC_ALL=C +export LC_ALL + +guix authenticate rsautl -sign \ + -inkey "$abs_top_srcdir/tests/signing-key.sec" \ + -in "$hash" > "$sig" + +guix authenticate rsautl -verify \ + -inkey "$abs_top_srcdir/tests/signing-key.pub" \ + -pubin -in "$sig" +hash2="`guix authenticate rsautl -verify \ + -inkey $abs_top_srcdir/tests/signing-key.pub \ + -pubin -in $sig`" +test "$hash2" = `cat "$hash"` diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 67bbc83d4..f5008f324 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -153,7 +153,7 @@ ;; In Guix up to 0.6 included this test would fail because at some point ;; the hash value would be cropped to ASCII. In practice 'guix ;; authenticate' would produce invalid signatures that would fail - ;; signature verification. + ;; signature verification. See . (let ((locale (setlocale LC_ALL))) (dynamic-wind (lambda () -- cgit v1.3 From 6ef3644e3462d4a98323f556eefa92a6765ed437 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 11:41:52 +0200 Subject: pk-crypto: Add pretty-printer to 'gcry-error' exceptions. * guix/pk-crypto.scm (string->canonical-sexp, sign, generate-key): Pass the procedure name as the first argument to 'throw'. (gcrypt-error-printer): New procedure. : Add call to 'set-exception-printer!'. * guix/nar.scm (restore-one-item): Add 'proc' parameter to 'catch' handler for 'gcry-error. * guix/scripts/archive.scm (%options, generate-key-pair, authorize-key): Likewise. * guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp): Likewise. --- guix/nar.scm | 2 +- guix/pk-crypto.scm | 15 ++++++++++++--- guix/scripts/archive.scm | 6 +++--- guix/scripts/substitute-binary.scm | 2 +- 4 files changed, 17 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/nar.scm b/guix/nar.scm index 6beda91c0..0a7187c2d 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -370,7 +370,7 @@ protected from GC." (let ((signature (catch 'gcry-error (lambda () (string->canonical-sexp signature)) - (lambda (err . _) + (lambda (key proc err) (raise (condition (&message (message "signature is not a valid \ diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 351bf929c..71104128c 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -143,7 +143,7 @@ thrown along with 'gcry-error'." (err (proc sexp (string->pointer str "ISO-8859-1") 0 1))) (if (= 0 err) (pointer->canonical-sexp (dereference-pointer sexp)) - (throw 'gcry-error err)))))) + (throw 'gcry-error 'string->canonical-sexp err)))))) (define-syntax GCRYSEXP_FMT_ADVANCED (identifier-syntax 3)) @@ -296,7 +296,7 @@ is 'private-key'.)" (canonical-sexp->pointer secret-key)))) (if (= 0 err) (pointer->canonical-sexp (dereference-pointer sig)) - (throw 'gry-error err)))))) + (throw 'gcry-error 'sign err)))))) (define verify (let* ((ptr (libgcrypt-func "gcry_pk_verify")) @@ -318,7 +318,7 @@ s-expression like: (genkey (rsa (nbits 4:2048)))." (err (proc key (canonical-sexp->pointer params)))) (if (zero? err) (pointer->canonical-sexp (dereference-pointer key)) - (throw 'gcry-error err)))))) + (throw 'gcry-error 'generate-key err)))))) (define find-sexp-token (let* ((ptr (libgcrypt-func "gcry_sexp_find_token")) @@ -403,4 +403,13 @@ use pattern matching." (write sexp))))) +(define (gcrypt-error-printer port key args default-printer) + "Print the gcrypt error specified by ARGS." + (match args + ((proc err) + (format port "In procedure ~a: ~a: ~a" + proc (error-source err) (error-string err))))) + +(set-exception-printer! 'gcry-error gcrypt-error-printer) + ;;; pk-crypto.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 0a2e186da..84904e29d 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/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 8e35612e3..c70a4f626 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)))))))) -- cgit v1.3 From 06ed59825ecc0dc78d4d16d06c129e2f4879201a Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sun, 27 Apr 2014 11:09:07 +0200 Subject: guix: cmake: Add input and package libraries to the rpath, and adapt package definitions accordingly. * guix/build/cmake-build-system.scm (configure): Add flags. * gnu/packages/maths.scm (lapack): Drop special code. * gnu/packages/ssh.scm (libssh): Drop special code. * gnu/packages/slim.scm (slim): Drop special code and enable shared library. Co-authored-by: Eric Bavier --- gnu/packages/maths.scm | 35 +++-------------------------------- gnu/packages/slim.scm | 12 +++--------- gnu/packages/ssh.scm | 35 +++-------------------------------- guix/build/cmake-build-system.scm | 5 +++++ 4 files changed, 14 insertions(+), 73 deletions(-) (limited to 'guix') diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 68c326752..232b79b31 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 John Darrington ;;; @@ -190,43 +190,14 @@ output in text, PostScript, PDF or HTML.") (inputs `(("fortran" ,gfortran-4.8) ("python" ,python-2))) (arguments - `(#:modules ((guix build cmake-build-system) - (guix build utils) - (guix build rpath) - (srfi srfi-1)) - #:imported-modules ((guix build cmake-build-system) - (guix build gnu-build-system) - (guix build utils) - (guix build rpath)) - #:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES") + `(#:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES") #:phases (alist-cons-before 'check 'patch-python (lambda* (#:key inputs #:allow-other-keys) (let ((python (assoc-ref inputs "python"))) (substitute* "lapack_testing.py" (("/usr/bin/env python") python)))) - (alist-cons-after - 'strip 'add-libs-to-runpath - (lambda* (#:key inputs outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (fortran (assoc-ref inputs "fortran")) - (libc (assoc-ref inputs "libc")) - (rpaths `(,(string-append fortran "/lib64") - ,(string-append fortran "/lib") - ,(string-append libc "/lib") - ,(string-append out "/lib")))) - ;; Set RUNPATH for all libraries - (with-directory-excursion out - (for-each - (lambda (lib) - (let ((lib-rpaths (file-rpath lib))) - (for-each - (lambda (dir) - (or (member dir lib-rpaths) - (augment-rpath lib dir))) - rpaths))) - (find-files "lib" ".*so$"))))) - %standard-phases)))) + %standard-phases))) (synopsis "Library for numerical linear algebra") (description "LAPACK is a Fortran 90 library for solving the most commonly occurring diff --git a/gnu/packages/slim.scm b/gnu/packages/slim.scm index f25b070f3..cea374898 100644 --- a/gnu/packages/slim.scm +++ b/gnu/packages/slim.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Guy Grant ;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,15 +76,8 @@ ;; "systemd". Strip that. ""))) %standard-phases) - #:configure-flags '("-DUSE_PAM=yes" "-DUSE_CONSOLEKIT=no" - - ;; Don't build libslim.so, because then the build - ;; system is unable to set the right RUNPATH on the - ;; 'slim' binary. - "-DBUILD_SHARED_LIBS=OFF" - - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + #:configure-flags '("-DUSE_PAM=yes" + "-DUSE_CONSOLEKIT=no") #:tests? #f)) (home-page "http://slim.berlios.de/") (synopsis "Desktop-independent graphcal login manager for X11") diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 51e199016..c8ed3be4a 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -53,39 +53,10 @@ "1jyaj9h1iglvn02hrvcchbx8ycjpj8b91h8mi459k7q5jp2xgd9b")))) (build-system cmake-build-system) (arguments - '(#:configure-flags '("-DWITH_GCRYPT=ON" - - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + '(#:configure-flags '("-DWITH_GCRYPT=ON") ;; TODO: Add 'CMockery' and '-DWITH_TESTING=ON' for the test suite. - #:tests? #f - - #:modules ((guix build cmake-build-system) - (guix build utils) - (guix build rpath)) - #:imported-modules ((guix build gnu-build-system) - (guix build cmake-build-system) - (guix build utils) - (guix build rpath)) - - #:phases (alist-cons-after - 'install 'augment-runpath - (lambda* (#:key outputs #:allow-other-keys) - ;; libssh_threads.so NEEDs libssh.so, so add $libdir to its - ;; RUNPATH. - (define (dereference file) - (let ((target (false-if-exception (readlink file)))) - (if target - (dereference target) - file))) - - (let* ((out (assoc-ref outputs "out")) - (lib (string-append out "/lib"))) - (with-directory-excursion lib - (augment-rpath (dereference "libssh_threads.so") - lib)))) - %standard-phases))) + #:tests? #f)) (inputs `(("zlib" ,zlib) ;; Link against an older gcrypt, because libssh tries to access ;; fields of 'gcry_thread_cbs' that are now private: diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm index 75998568b..144552e8d 100644 --- a/guix/build/cmake-build-system.scm +++ b/guix/build/cmake-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Ludovic Courtès ;;; Copyright © 2013 Cyril Roelandt +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,6 +49,10 @@ (let ((args `(,srcdir ,(string-append "-DCMAKE_INSTALL_PREFIX=" out) + ;; add input libraries to rpath + "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE" + ;; add (other) libraries of the project itself to rpath + ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib") ,@configure-flags))) (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH")) (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH")) -- cgit v1.3 From 21b679f6944f4e1f09f949322f5242b761dc22a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:00:57 +0200 Subject: Add (guix gexp). * guix/gexp.scm: New file. * tests/gexp.scm: New file. * Makefile.am (MODULES): Add guix/gexp.scm. (SCM_TESTS): Add tests/gexp.scm. * doc/guix.texi (Derivations): Add #:inputs in 'derivation' example. Mark 'build-expression->derivation' as deprecated, refer to "G-Expressions". Remove paragraph about code strata. (G-Expressions): New node. --- .dir-locals.el | 9 +- Makefile.am | 2 + doc/guix.texi | 219 +++++++++++++++++++++++++++++--- guix/gexp.scm | 391 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/gexp.scm | 234 ++++++++++++++++++++++++++++++++++ 5 files changed, 837 insertions(+), 18 deletions(-) create mode 100644 guix/gexp.scm create mode 100644 tests/gexp.scm (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 49380fe4b..a6135b171 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -6,6 +6,7 @@ (scheme-mode . ((indent-tabs-mode . nil) + (eval . (put 'eval-when 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) (eval . (put 'test-eq 'scheme-indent-function 1)) @@ -31,7 +32,13 @@ (eval . (put 'with-monad 'scheme-indent-function 1)) (eval . (put 'mlet* 'scheme-indent-function 2)) (eval . (put 'mlet 'scheme-indent-function 2)) - (eval . (put 'run-with-store 'scheme-indent-function 1)))) + (eval . (put 'run-with-store 'scheme-indent-function 1)) + + ;; Recognize '~' and '$', as used for gexps, as quotation symbols. This + ;; notably allows '(' in Paredit to not insert a space when the preceding + ;; symbol is one of these. + (eval . (modify-syntax-entry ?~ "'")) + (eval . (modify-syntax-entry ?$ "'")))) (emacs-lisp-mode . ((indent-tabs-mode . nil))) (texinfo-mode . ((indent-tabs-mode . nil) (fill-column . 72)))) diff --git a/Makefile.am b/Makefile.am index 8d425f1be..d01032f53 100644 --- a/Makefile.am +++ b/Makefile.am @@ -37,6 +37,7 @@ MODULES = \ guix/download.scm \ guix/git-download.scm \ guix/monads.scm \ + guix/gexp.scm \ guix/profiles.scm \ guix/serialization.scm \ guix/nar.scm \ @@ -139,6 +140,7 @@ SCM_TESTS = \ tests/snix.scm \ tests/store.scm \ tests/monads.scm \ + tests/gexp.scm \ tests/nar.scm \ tests/union.scm \ tests/profiles.scm diff --git a/doc/guix.texi b/doc/guix.texi index f8d71fdac..9fb226c65 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1305,6 +1305,7 @@ package definitions. * The Store:: Manipulating the package store. * Derivations:: Low-level interface to package derivations. * The Store Monad:: Purely functional interface to the store. +* G-Expressions:: Manipulating build expressions. @end menu @node Defining Packages @@ -1762,13 +1763,21 @@ to a Bash executable in the store: "echo hello world > $out\n" '()))) (derivation store "foo" bash `("-e" ,builder) + #:inputs `((,bash) (,builder)) #:env-vars '(("HOME" . "/homeless")))) @result{} # /gnu/store/@dots{}-foo> @end lisp -As can be guessed, this primitive is cumbersome to use directly. An -improved variant is @code{build-expression->derivation}, which allows -the caller to directly pass a Guile expression as the build script: +As can be guessed, this primitive is cumbersome to use directly. A +better approach is to write build scripts in Scheme, of course! The +best course of action for that is to write the build code as a +``G-expression'', and to pass it to @code{gexp->derivation}. For more +information, @ref{G-Expressions}. + +Once upon a time, @code{gexp->derivation} did not exist and constructing +derivations with build code written in Scheme was achieved with +@code{build-expression->derivation}, documented below. This procedure +is now deprecated in favor of the much nicer @code{gexp->derivation}. @deffn {Scheme Procedure} build-expression->derivation @var{store} @ @var{name} @var{exp} @ @@ -1816,20 +1825,6 @@ containing one file: @result{} # @dots{}> @end lisp -@cindex strata of code -Remember that the build expression passed to -@code{build-expression->derivation} is run by a separate Guile process -than the one that calls @code{build-expression->derivation}: it is run -by a Guile process launched by the daemon, typically in a chroot. So, -while there is a single language for both the @dfn{host} and the build -side, there are really two @dfn{strata} of code: the host-side, and the -build-side code@footnote{The term @dfn{stratum} in this context was -coined by Manuel Serrano et al. in the context of their work on Hop.}. -This distinction is important to keep in mind, notably when using -higher-level constructs such as @var{gnu-build-system} (@pxref{Defining -Packages}). For this reason, Guix modules that are meant to be used in -the build stratum are kept in the @code{(guix build @dots{})} name -space. @node The Store Monad @section The Store Monad @@ -1993,6 +1988,196 @@ Packages}). @end deffn +@node G-Expressions +@section G-Expressions + +@cindex G-expression +@cindex build code quoting +So we have ``derivations'', which represent a sequence of build actions +to be performed to produce an item in the store (@pxref{Derivations}). +Those build actions are performed when asking the daemon to actually +build the derivations; they are run by the daemon in a container +(@pxref{Invoking guix-daemon}). + +@cindex strata of code +It should come as no surprise that we like to write those build actions +in Scheme. When we do that, we end up with two @dfn{strata} of Scheme +code@footnote{The term @dfn{stratum} in this context was coined by +Manuel Serrano et al.@: in the context of their work on Hop.}: the +``host code''---code that defines packages, talks to the daemon, +etc.---and the ``build code''---code that actually performs build +actions, such as making directories, invoking @command{make}, etc. + +To describe a derivation and its build actions, one typically needs to +embed build code inside host code. It boils down to manipulating build +code as data, and Scheme's homoiconicity---code has a direct +representation as data---comes in handy for that. But we need more than +Scheme's normal @code{quasiquote} mechanism to construct build +expressions. + +The @code{(guix gexp)} module implements @dfn{G-expressions}, a form of +S-expressions adapted to build expressions. G-expressions, or +@dfn{gexps}, consist essentially in three syntactic forms: @code{gexp}, +@code{ungexp}, and @code{ungexp-splicing} (or simply: @code{#~}, +@code{#$}, and @code{#$@@}), which are comparable respectively to +@code{quasiquote}, @code{unquote}, and @code{unquote-splicing} +(@pxref{Expression Syntax, @code{quasiquote},, guile, GNU Guile +Reference Manual}). However, there are major differences: + +@itemize +@item +Gexps are meant to be written to a file and run or manipulated by other +processes. + +@item +When a package or derivation is unquoted inside a gexp, the result is as +if its output file name had been introduced. + +@item +Gexps carry information about the packages or derivations they refer to, +and these dependencies are automatically added as inputs to the build +processes that use them. +@end itemize + +To illustrate the idea, here is an example of a gexp: + +@example +(define build-exp + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink (string-append #$coreutils "/bin/ls") + "list-files"))) +@end example + +This gexp can be passed to @code{gexp->derivation}; we obtain a +derivation that builds a directory containing exactly one symlink to +@file{/gnu/store/@dots{}-coreutils-8.22/bin/ls}: + +@example +(gexp->derivation "the-thing" build-exp) +@end example + +As one would expect, the @code{"/gnu/store/@dots{}-coreutils"} string is +substituted to the reference to the @var{coreutils} package in the +actual build code, and @var{coreutils} is automatically made an input to +the derivation. Likewise, @code{#$output} (equivalent to @code{(ungexp +output)}) is replaced by a string containing the derivation's output +directory name. The syntactic form to construct gexps is summarized +below. + +@deffn {Scheme Syntax} #~@var{exp} +@deffnx {Scheme Syntax} (gexp @var{exp}) +Return a G-expression containing @var{exp}. @var{exp} may contain one +or more of the following forms: + +@table @code +@item #$@var{obj} +@itemx (ungexp @var{obj}) +Introduce a reference to @var{obj}. @var{obj} may be a package or a +derivation, in which case the @code{ungexp} form is replaced by its +output file name---e.g., @code{"/gnu/store/@dots{}-coreutils-8.22}. + +If @var{obj} is a list, it is traversed and any package or derivation +references are substituted similarly. + +If @var{obj} is another gexp, its contents are inserted and its +dependencies are added to those of the containing gexp. + +If @var{obj} is another kind of object, it is inserted as is. + +@item #$@var{package-or-derivation}:@var{output} +@itemx (ungexp @var{package-or-derivation} @var{output}) +This is like the form above, but referring explicitly to the +@var{output} of @var{package-or-derivation}---this is useful when +@var{package-or-derivation} produces multiple outputs (@pxref{Packages +with Multiple Outputs}). + +@item #$output[:@var{output}] +@itemx (ungexp output [@var{output}]) +Insert a reference to derivation output @var{output}, or to the main +output when @var{output} is omitted. + +This only makes sense for gexps passed to @code{gexp->derivation}. + +@item #$@@@var{lst} +@itemx (ungexp-splicing @var{lst}) +Like the above, but splices the contents of @var{lst} inside the +containing list. + +@end table + +G-expressions created by @code{gexp} or @code{#~} are run-time objects +of the @code{gexp?} type (see below.) +@end deffn + +@deffn {Scheme Procedure} gexp? @var{obj} +Return @code{#t} if @var{obj} is a G-expression. +@end deffn + +G-expressions are meant to be written to disk, either as code building +some derivation, or as plain files in the store. The monadic procedures +below allow you to do that (@pxref{The Store Monad}, for more +information about monads.) + +@deffn {Monadic Procedure} gexp->derivation @var{name} @var{exp} @ + [#:system (%current-system)] [#:inputs '()] @ + [#:hash #f] [#:hash-algo #f] @ + [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ + [#:references-graphs #f] [#:local-build? #f] @ + [#:guile-for-build #f] +Return a derivation @var{name} that runs @var{exp} (a gexp) with +@var{guile-for-build} (a derivation) on @var{system}. + +Make @var{modules} available in the evaluation context of @var{EXP}; +@var{MODULES} is a list of names of Guile modules from the current +search path to be copied in the store, compiled, and made available in +the load path during the execution of @var{exp}---e.g., @code{((guix +build utils) (guix build gnu-build-system))}. + +The other arguments are as for @code{derivation}. +@end deffn + +@deffn {Monadic Procedure} gexp->script @var{name} @var{exp} +Return an executable script @var{name} that runs @var{exp} using +@var{guile} with @var{modules} in its search path. + +The example below builds a script that simply invokes the @command{ls} +command: + +@example +(use-modules (guix gexp) (gnu packages base)) + +(gexp->script "list-files" + #~(execl (string-append #$coreutils "/bin/ls") + "ls")) +@end example + +When ``running'' it through the store (@pxref{The Store Monad, +@code{run-with-store}}), we obtain a derivation that procedures an +executable file @file{/gnu/store/@dots{}-list-files} along these lines: + +@example +#!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds +!# +(execl (string-append "/gnu/store/@dots{}-coreutils-8.22"/bin/ls") + "ls") +@end example +@end deffn + +@deffn {Monadic Procedure} gexp->file @var{name} @var{exp} +Return a derivation that builds a file @var{name} containing @var{exp}. + +The resulting file holds references to all the dependencies of @var{exp} +or a subset thereof. +@end deffn + +Of course, in addition to gexps embedded in ``host'' code, there are +also modules containing build tools. To make it clear that they are +meant to be used in the build stratum, these modules are kept in the +@code{(guix build @dots{})} name space. + + @c ********************************************************************* @node Utilities @chapter Utilities diff --git a/guix/gexp.scm b/guix/gexp.scm new file mode 100644 index 000000000..9dd83f537 --- /dev/null +++ b/guix/gexp.scm @@ -0,0 +1,391 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix gexp) + #:use-module ((guix store) + #:select (direct-store-path?)) + #:use-module (guix monads) + #:use-module ((guix derivations) + #:select (derivation? derivation->output-path + %guile-for-build derivation)) + #:use-module (guix packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (gexp + gexp? + gexp->derivation + gexp->file + gexp->script)) + +;;; Commentary: +;;; +;;; This module implements "G-expressions", or "gexps". Gexps are like +;;; S-expressions (sexps), with two differences: +;;; +;;; 1. References (un-quotations) to derivations or packages in a gexp are +;;; replaced by the corresponding output file name; +;;; +;;; 2. Gexps embed information about the derivations they refer to. +;;; +;;; Gexps make it easy to write to files Scheme code that refers to store +;;; items, or to write Scheme code to build derivations. +;;; +;;; Code: + +;; "G expressions". +(define-record-type + (make-gexp references proc) + gexp? + (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) + (proc gexp-proc)) ; procedure + +;; Reference to one of the derivation's outputs, for gexps used in +;; derivations. +(define-record-type + (output-ref name) + output-ref? + (name output-ref-name)) + +(define raw-derivation + (store-lift derivation)) + +(define (lower-inputs* inputs) + "Turn any package from INPUTS into a derivation; return the corresponding +input list as a monadic value." + ;; XXX: This is like 'lower-inputs' but without the "name" part in tuples. + (with-monad %store-monad + (sequence %store-monad + (map (match-lambda + (((? package? package) sub-drv ...) + (mlet %store-monad ((drv (package->derivation package))) + (return `(,drv ,@sub-drv)))) + (input + (return input))) + inputs)))) + +(define* (gexp->derivation name exp + #:key + (system (%current-system)) + hash hash-algo recursive? + (env-vars '()) + (modules '()) + (guile-for-build (%guile-for-build)) + references-graphs + local-build?) + "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a +derivation) on SYSTEM. + +Make MODULES available in the evaluation context of EXP; MODULES is a list of +names of Guile modules from the current search path to be copied in the store, +compiled, and made available in the load path during the execution of +EXP---e.g., '((guix build utils) (guix build gnu-build-system)). + +The other arguments are as for 'derivation'." + (define %modules modules) + (define outputs (gexp-outputs exp)) + + (mlet* %store-monad ((inputs (lower-inputs* (gexp-inputs exp))) + (sexp (gexp->sexp exp #:outputs outputs)) + (builder (text-file (string-append name "-builder") + (object->string sexp))) + (modules (if (pair? %modules) + (imported-modules %modules + #:system system + #:guile guile-for-build) + (return #f))) + (compiled (if (pair? %modules) + (compiled-modules %modules + #:system system + #:guile guile-for-build) + (return #f))) + (guile (if guile-for-build + (return guile-for-build) + (package->derivation + (@ (gnu packages base) guile-final) + system)))) + (raw-derivation name + (string-append (derivation->output-path guile) + "/bin/guile") + `("--no-auto-compile" + ,@(if (pair? %modules) + `("-L" ,(derivation->output-path modules) + "-C" ,(derivation->output-path compiled)) + '()) + ,builder) + #:outputs outputs + #:env-vars env-vars + #:system system + #:inputs `((,guile) + (,builder) + ,@(if modules + `((,modules) (,compiled) ,@inputs) + inputs)) + #:hash hash #:hash-algo hash-algo #:recursive? recursive? + #:references-graphs references-graphs + #:local-build? local-build?))) + +(define (gexp-inputs exp) + "Return the input list for EXP." + (define (add-reference-inputs ref result) + (match ref + (((? derivation?) (? string?)) + (cons ref result)) + (((? package?) (? string?)) + (cons ref result)) + ((? gexp? exp) + (append (gexp-inputs exp) result)) + (((? string? file)) + (if (direct-store-path? file) + (cons ref result) + result)) + ((refs ...) + (fold-right add-reference-inputs result refs)) + (_ + ;; Ignore references to other kinds of objects. + result))) + + (fold-right add-reference-inputs + '() + (gexp-references exp))) + +(define (gexp-outputs exp) + "Return the outputs referred to by EXP as a list of strings." + (define (add-reference-output ref result) + (match ref + (($ name) + (cons name result)) + ((? gexp? exp) + (append (gexp-outputs exp) result)) + (_ + result))) + + (fold-right add-reference-output + '() + (gexp-references exp))) + +(define* (gexp->sexp exp #:key (outputs '())) + "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, +and in the current monad setting (system type, etc.)" + (define (reference->sexp ref) + (with-monad %store-monad + (match ref + (((? derivation? drv) (? string? output)) + (return (derivation->output-path drv output))) + (((? package? p) (? string? output)) + (package-file p #:output output)) + (($ output) + (match (member output outputs) + (#f + (error "no such output" output)) + (_ + (return `((@ (guile) getenv) ,output))))) + ((? gexp? exp) + (gexp->sexp exp #:outputs outputs)) + (((? string? str)) + (return (if (direct-store-path? str) str ref))) + ((refs ...) + (sequence %store-monad (map reference->sexp refs))) + (x + (return x))))) + + (mlet %store-monad + ((args (sequence %store-monad + (map reference->sexp (gexp-references exp))))) + (return (apply (gexp-proc exp) args)))) + +(define (canonicalize-reference ref) + "Return a canonical variant of REF, which adds any missing output part in +package/derivation references." + (match ref + ((? package? p) + `(,p "out")) + ((? derivation? d) + `(,d "out")) + (((? package?) (? string?)) + ref) + (((? derivation?) (? string?)) + ref) + ((? string? s) + (if (direct-store-path? s) `(,s) s)) + ((refs ...) + (map canonicalize-reference refs)) + (x x))) + +(define (syntax-location-string s) + "Return a string representing the source code location of S." + (let ((props (syntax-source s))) + (if props + (let ((file (assoc-ref props 'filename)) + (line (and=> (assoc-ref props 'line) 1+)) + (column (assoc-ref props 'column))) + (if file + (simple-format #f "~a:~a:~a" + file line column) + (simple-format #f "~a:~a" line column))) + ""))) + +(define-syntax gexp + (lambda (s) + (define (collect-escapes exp) + ;; Return all the 'ungexp' present in EXP. + (let loop ((exp exp) + (result '())) + (syntax-case exp (ungexp ungexp-splicing) + ((ungexp _) + (cons exp result)) + ((ungexp _ _) + (cons exp result)) + ((ungexp-splicing _ ...) + (cons exp result)) + ((exp0 exp ...) + (let ((result (loop #'exp0 result))) + (fold loop result #'(exp ...)))) + (_ + result)))) + + (define (escape->ref exp) + ;; Turn 'ungexp' form EXP into a "reference". + (syntax-case exp (ungexp ungexp-splicing output) + ((ungexp output) + #'(output-ref "out")) + ((ungexp output name) + #'(output-ref name)) + ((ungexp thing) + #'thing) + ((ungexp drv-or-pkg out) + #'(list drv-or-pkg out)) + ((ungexp-splicing lst) + #'lst))) + + (define (substitute-references exp substs) + ;; Return a variant of EXP where all the cars of SUBSTS have been + ;; replaced by the corresponding cdr. + (syntax-case exp (ungexp ungexp-splicing) + ((ungexp _ ...) + (match (assoc exp substs) + ((_ id) + id) + (_ + #'(syntax-error "error: no 'ungexp' substitution" + #'ref)))) + (((ungexp-splicing _ ...) rest ...) + (syntax-case exp () + ((exp rest ...) + (match (assoc #'exp substs) + ((_ id) + (with-syntax ((id id)) + #`(append id + #,(substitute-references #'(rest ...) substs)))) + (_ + #'(syntax-error "error: no 'ungexp-splicing' substitution" + #'ref)))))) + ((exp0 exp ...) + #`(cons #,(substitute-references #'exp0 substs) + #,(substitute-references #'(exp ...) substs))) + (x #''x))) + + (syntax-case s (ungexp output) + ((_ exp) + (let* ((escapes (delete-duplicates (collect-escapes #'exp))) + (formals (generate-temporaries escapes)) + (sexp (substitute-references #'exp (zip escapes formals))) + (refs (map escape->ref escapes))) + #`(make-gexp (map canonicalize-reference (list #,@refs)) + (lambda #,formals + #,sexp))))))) + + +;;; +;;; Convenience procedures. +;;; + +(define* (gexp->script name exp + #:key (modules '()) + (guile (@ (gnu packages base) guile-final))) + "Return an executable script NAME that runs EXP using GUILE with MODULES in +its search path." + (mlet %store-monad ((modules (imported-modules modules)) + (compiled (compiled-modules modules))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (format port + "#!~a/bin/guile --no-auto-compile~%!#~%" + (ungexp guile)) + (write + '(set! %load-path + (cons (ungexp modules) %load-path)) + port) + (write + '(set! %load-compiled-path + (cons (ungexp compiled) + %load-compiled-path)) + port) + (write '(ungexp exp) port) + (chmod port #o555))))))) + +(define (gexp->file name exp) + "Return a derivation that builds a file NAME containing EXP." + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp exp) port)))))) + + + +;;; +;;; Syntactic sugar. +;;; + +(eval-when (expand load eval) + (define (read-ungexp chr port) + "Read an 'ungexp' or 'ungexp-splicing' form from PORT." + (define unquote-symbol + (match (peek-char port) + (#\@ + (read-char port) + 'ungexp-splicing) + (_ + 'ungexp))) + + (match (read port) + ((? symbol? symbol) + (let ((str (symbol->string symbol))) + (match (string-index-right str #\:) + (#f + `(,unquote-symbol ,symbol)) + (colon + (let ((name (string->symbol (substring str 0 colon))) + (output (substring str (+ colon 1)))) + `(,unquote-symbol ,name ,output)))))) + (x + `(,unquote-symbol ,x)))) + + (define (read-gexp chr port) + "Read a 'gexp' form from PORT." + `(gexp ,(read port))) + + ;; Extend the reader + (read-hash-extend #\~ read-gexp) + (read-hash-extend #\$ read-ungexp)) + +;;; gexp.scm ends here diff --git a/tests/gexp.scm b/tests/gexp.scm new file mode 100644 index 000000000..3da5b82e4 --- /dev/null +++ b/tests/gexp.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module ((guix packages) + #:select (package-derivation %current-system)) + #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 popen)) + +;; Test the (guix gexp) module. + +(define %store + (open-connection)) + +;; For white-box testing. +(define gexp-inputs (@@ (guix gexp) gexp-inputs)) +(define gexp->sexp (@@ (guix gexp) gexp->sexp)) + +(define guile-for-build + (package-derivation %store %bootstrap-guile)) + +;; Make it the default. +(%guile-for-build guile-for-build) + +(define (gexp->sexp* exp) + (run-with-store %store (gexp->sexp exp) + #:guile-for-build guile-for-build)) + +(define-syntax-rule (test-assertm name exp) + (test-assert name + (run-with-store %store exp + #:guile-for-build guile-for-build))) + + +(test-begin "gexp") + +(test-equal "no refs" + '(display "hello!") + (let ((exp (gexp (display "hello!")))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + +(test-equal "unquote" + '(display `(foo ,(+ 2 3))) + (let ((exp (gexp (display `(foo ,(+ 2 3)))))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + +(test-assert "one input package" + (let ((exp (gexp (display (ungexp coreutils))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (equal? `(display ,(derivation->output-path + (package-derivation %store coreutils))) + (gexp->sexp* exp))))) + +(test-assert "same input twice" + (let ((exp (gexp (begin + (display (ungexp coreutils)) + (display (ungexp coreutils)))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (let ((e `(display ,(derivation->output-path + (package-derivation %store coreutils))))) + (equal? `(begin ,e ,e) (gexp->sexp* exp)))))) + +(test-assert "two input packages, one derivation, one file" + (let* ((drv (build-expression->derivation + %store "foo" 'bar + #:guile-for-build (package-derivation %store %bootstrap-guile))) + (txt (add-text-to-store %store "foo" "Hello, world!")) + (exp (gexp (begin + (display (ungexp coreutils)) + (display (ungexp %bootstrap-guile)) + (display (ungexp drv)) + (display (ungexp txt)))))) + (define (match-input thing) + (match-lambda + ((drv-or-pkg _ ...) + (eq? thing drv-or-pkg)))) + + (and (gexp? exp) + (= 4 (length (gexp-inputs exp))) + (every (lambda (input) + (find (match-input input) (gexp-inputs exp))) + (list drv coreutils %bootstrap-guile txt)) + (let ((e0 `(display ,(derivation->output-path + (package-derivation %store coreutils)))) + (e1 `(display ,(derivation->output-path + (package-derivation %store %bootstrap-guile)))) + (e2 `(display ,(derivation->output-path drv))) + (e3 `(display ,txt))) + (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp)))))) + +(test-assert "input list" + (let ((exp (gexp (display + '(ungexp (list %bootstrap-guile coreutils))))) + (guile (derivation->output-path + (package-derivation %store %bootstrap-guile))) + (cu (derivation->output-path + (package-derivation %store coreutils)))) + (and (lset= equal? + `((,%bootstrap-guile "out") (,coreutils "out")) + (gexp-inputs exp)) + (equal? `(display '(,guile ,cu)) + (gexp->sexp* exp))))) + +(test-assert "input list splicing" + (let* ((inputs (list (list glibc "debug") %bootstrap-guile)) + (outputs (list (derivation->output-path + (package-derivation %store glibc) + "debug") + (derivation->output-path + (package-derivation %store %bootstrap-guile)))) + (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) + (and (lset= equal? + `((,glibc "debug") (,%bootstrap-guile "out")) + (gexp-inputs exp)) + (equal? (gexp->sexp* exp) + `(list ,@(cons 5 outputs)))))) + +(test-assertm "gexp->file" + (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) + (guile (package-file %bootstrap-guile)) + (sexp (gexp->sexp exp)) + (drv (gexp->file "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (refs ((store-lift references) out))) + (return (and (equal? sexp (call-with-input-file out read)) + (equal? (list guile) refs))))) + +(test-assertm "gexp->derivation" + (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) + (exp -> (gexp + (begin + (mkdir (ungexp output)) + (chdir (ungexp output)) + (symlink + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "foo") + (symlink (ungexp file) + (ungexp output "2nd"))))) + (drv (gexp->derivation "foo" exp)) + (out -> (derivation->output-path drv)) + (out2 -> (derivation->output-path drv "2nd")) + (done (built-derivations (list drv))) + (refs ((store-lift references) out)) + (refs2 ((store-lift references) out2)) + (guile (package-file %bootstrap-guile "bin/guile"))) + (return (and (string=? (readlink (string-append out "/foo")) guile) + (string=? (readlink out2) file) + (equal? refs (list (dirname (dirname guile)))) + (equal? refs2 (list file)))))) + +(test-assertm "gexp->derivation, composed gexps" + (mlet* %store-monad ((exp0 -> (gexp (begin + (mkdir (ungexp output)) + (chdir (ungexp output))))) + (exp1 -> (gexp (symlink + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "foo"))) + (exp -> (gexp (begin (ungexp exp0) (ungexp exp1)))) + (drv (gexp->derivation "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (guile (package-file %bootstrap-guile "bin/guile"))) + (return (string=? (readlink (string-append out "/foo")) + guile)))) + +(test-assertm "gexp->script" + (mlet* %store-monad ((n -> (random (expt 2 50))) + (exp -> (gexp + (system* + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "-c" (object->string + '(display (expt (ungexp n) 2)))))) + (drv (gexp->script "guile-thing" exp + #:guile %bootstrap-guile)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv)))) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= (expt n 2) (string->number str))))))) + +(test-equal "sugar" + '(gexp (foo (ungexp bar) (ungexp baz "out") + (ungexp (chbouib 42)) + (ungexp-splicing (list x y z)))) + '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z))) + +(test-end "gexp") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;; Local Variables: +;; eval: (put 'test-assertm 'scheme-indent-function 1) +;; End: -- cgit v1.3 From eee212710978fb2044d3312aff0bf33b508aa026 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Apr 2014 16:38:38 +0200 Subject: store: (direct-store-path? (%store-prefix)) returns #f. * guix/store.scm (direct-store-path?): Return #f if PATH is (%store-prefix). * tests/store.scm ("direct-store-path?"): Add test. --- guix/store.scm | 1 + tests/store.scm | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index c1898c5c8..2b924db21 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -839,6 +839,7 @@ be used internally by the daemon's build hook." This predicate is sometimes needed because files *under* a store path are not valid inputs." (and (store-path? path) + (not (string=? path (%store-prefix))) (let ((len (+ 1 (string-length (%store-prefix))))) (not (string-index (substring path len) #\/))))) diff --git a/tests/store.scm b/tests/store.scm index 90137b975..b0f609f81 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -85,7 +85,8 @@ (not (direct-store-path? (string-append (%store-prefix) - "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))))) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))) + (not (direct-store-path? (%store-prefix))))) (test-skip (if %store 0 13)) -- cgit v1.3 From ada3df03e33f686467ce4e887381e8753a3e603b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 23:19:11 +0200 Subject: monads: Hide 'derivation-expression' and 'lower-inputs'. * guix/monads.scm: Unexport 'lower-inputs' and 'derivation-expression'. (text-file*): Add comment about the switch to 'gexp->derivation'. (lower-inputs): Add comment about its doom. (derivation-expression): Likewise. * guix/gexp.scm (lower-inputs*): Rename to... (lower-inputs): ... this. Update callers. * tests/monads.scm (derivation-expression): New procedure. * doc/guix.texi (The Store Monad): Use 'gexp->derivation' instead of 'derivation-expression'. Remove documentation of 'derivation-expression'. * guix/ui.scm (read/eval): Use THE-ROOT-MODULE so that macros are properly expanded. * tests/guix-build.sh: Use 'gexp->derivation' instead of 'derivation-expression'.monads: Hide 'derivation-expression' and 'lower-inputs'. --- doc/guix.texi | 14 +++----------- guix/gexp.scm | 5 ++--- guix/monads.scm | 8 ++++---- guix/ui.scm | 2 +- tests/guix-build.sh | 7 ++++--- tests/monads.scm | 3 +++ 6 files changed, 17 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index bbfdce51f..3ae2b7e00 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1868,11 +1868,12 @@ Consider this ``normal'' procedure: Using @code{(guix monads)}, it may be rewritten as a monadic function: +@c FIXME: Find a better example, one that uses 'mlet'. @example (define (sh-symlink) ;; Same, but return a monadic value. - (mlet %store-monad ((sh (package-file bash "bin"))) - (derivation-expression "sh" `(symlink ,sh %output)))) + (gexp->derivation "sh" + #~(symlink (string-append #$bash "/bin/bash") #$output))) @end example There are two things to note in the second version: the @code{store} @@ -1973,15 +1974,6 @@ directory of @var{package}. When @var{file} is omitted, return the name of the @var{output} directory of @var{package}. @end deffn -@deffn {Monadic Procedure} derivation-expression @var{name} @var{exp} @ - [#:system (%current-system)] [#:inputs '()] @ - [#:outputs '("out")] [#:hash #f] @ - [#:hash-algo #f] [#:env-vars '()] [#:modules '()] @ - [#:references-graphs #f] [#:guile-for-build #f] -Monadic version of @code{build-expression->derivation} -(@pxref{Derivations}). -@end deffn - @deffn {Monadic Procedure} package->derivation @var{package} [@var{system}] Monadic version of @code{package-derivation} (@pxref{Defining Packages}). diff --git a/guix/gexp.scm b/guix/gexp.scm index 9dd83f537..01084c262 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -66,10 +66,9 @@ (define raw-derivation (store-lift derivation)) -(define (lower-inputs* inputs) +(define (lower-inputs inputs) "Turn any package from INPUTS into a derivation; return the corresponding input list as a monadic value." - ;; XXX: This is like 'lower-inputs' but without the "name" part in tuples. (with-monad %store-monad (sequence %store-monad (map (match-lambda @@ -101,7 +100,7 @@ The other arguments are as for 'derivation'." (define %modules modules) (define outputs (gexp-outputs exp)) - (mlet* %store-monad ((inputs (lower-inputs* (gexp-inputs exp))) + (mlet* %store-monad ((inputs (lower-inputs (gexp-inputs exp))) (sexp (gexp->sexp exp #:outputs outputs)) (builder (text-file (string-append name "-builder") (object->string sexp))) diff --git a/guix/monads.scm b/guix/monads.scm index db8b64540..0e99cb37f 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -57,9 +57,7 @@ text-file* package-file package->derivation - built-derivations - derivation-expression - lower-inputs) + built-derivations) #:replace (imported-modules compiled-modules)) @@ -356,6 +354,7 @@ and store file names; the resulting store file holds references to all these." (lambda (port) (display ,(computed-text text inputs) port)))) + ;; TODO: Rewrite using 'gexp->derivation'. (mlet %store-monad ((inputs (lower-inputs inputs))) (derivation-expression name (builder inputs) #:inputs inputs))) @@ -376,7 +375,7 @@ OUTPUT directory of PACKAGE." (define (lower-inputs inputs) "Turn any package from INPUTS into a derivation; return the corresponding input list as a monadic value." - ;; XXX: Should probably be in (guix packages). + ;; XXX: This procedure is bound to disappear with 'derivation-expression'. (with-monad %store-monad (sequence %store-monad (map (match-lambda @@ -390,6 +389,7 @@ input list as a monadic value." inputs)))) (define derivation-expression + ;; XXX: This procedure is superseded by 'gexp->derivation'. (store-lift build-expression->derivation)) (define package->derivation diff --git a/guix/ui.scm b/guix/ui.scm index 944c9f87f..259dddd48 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -241,7 +241,7 @@ interpreted." str args))))) (catch #t (lambda () - (eval exp the-scm-module)) + (eval exp the-root-module)) (lambda args (leave (_ "failed to evaluate expression `~a': ~s~%") exp args))))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index d66e132c1..e0c774d05 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013 Ludovic Courtès +# Copyright © 2012, 2013, 2014 Ludovic Courtès # # This file is part of GNU Guix. # @@ -75,7 +75,8 @@ then false; else true; fi # Invoking a monadic procedure. guix build -e "(begin - (use-modules (guix monads) (guix utils)) + (use-modules (guix gexp)) (lambda () - (derivation-expression \"test\" '(mkdir %output))))" \ + (gexp->derivation \"test\" + (gexp (mkdir (ungexp output))))))" \ --dry-run diff --git a/tests/monads.scm b/tests/monads.scm index b51e705f0..82f4b9989 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -108,6 +108,9 @@ guile))) #:guile-for-build (package-derivation %store %bootstrap-guile))) +(define derivation-expression + (@@ (guix monads) derivation-expression)) + (test-assert "mlet* + derivation-expression" (run-with-store %store (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile")) -- cgit v1.3 From bfd9eed9557605ad6ee9339d649b57f183d90628 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 17:58:34 +0200 Subject: gexp: Remove leftover parameter. * guix/gexp.scm (gexp->sexp): Remove #:outputs parameter. Adjust callers accordingly. --- guix/gexp.scm | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 01084c262..a52360cd1 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -101,7 +101,7 @@ The other arguments are as for 'derivation'." (define outputs (gexp-outputs exp)) (mlet* %store-monad ((inputs (lower-inputs (gexp-inputs exp))) - (sexp (gexp->sexp exp #:outputs outputs)) + (sexp (gexp->sexp exp)) (builder (text-file (string-append name "-builder") (object->string sexp))) (modules (if (pair? %modules) @@ -179,7 +179,7 @@ The other arguments are as for 'derivation'." '() (gexp-references exp))) -(define* (gexp->sexp exp #:key (outputs '())) +(define* (gexp->sexp exp) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" (define (reference->sexp ref) @@ -190,13 +190,12 @@ and in the current monad setting (system type, etc.)" (((? package? p) (? string? output)) (package-file p #:output output)) (($ output) - (match (member output outputs) - (#f - (error "no such output" output)) - (_ - (return `((@ (guile) getenv) ,output))))) + ;; Output file names are not known in advance but the daemon defines + ;; an environment variable for each of them at build time, so use + ;; that trick. + (return `((@ (guile) getenv) ,output))) ((? gexp? exp) - (gexp->sexp exp #:outputs outputs)) + (gexp->sexp exp)) (((? string? str)) (return (if (direct-store-path? str) str ref))) ((refs ...) -- cgit v1.3 From 187eb5f6430c5b8ba1dc1853e97533551f932b61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 18:02:16 +0200 Subject: gnu-maintenance: Avoid network access in 'gnu-package?'. * guix/gnu-maintenance.scm (gnu-package?): Add 'mirror-type' procedure. Resort to 'official-gnu-packages' only when 'mirror-type' returns #f. --- guix/gnu-maintenance.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 14195da7b..d8b6af9d3 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -167,13 +167,22 @@ (lambda (package) "Return true if PACKAGE is a GNU package. This procedure may access the network to check in GNU's database." - ;; TODO: Find a way to determine that a package is non-GNU without going - ;; through the network. + (define (mirror-type url) + (let ((uri (string->uri url))) + (and (eq? (uri-scheme uri) 'mirror) + (if (member (uri-host uri) '("gnu" "gnupg" "gcc")) + 'gnu + 'non-gnu)))) + (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) - (or (and (string? url) (string-prefix? "mirror://gnu" url)) - (and (member name (map gnu-package-name (official-gnu-packages))) - #t))))))) + (case (and url (mirror-type url)) + ((gnu) #t) + ((non-gnu) #f) + (else + ;; Last resort: resort to the network. + (and (member name (map gnu-package-name (official-gnu-packages))) + #t)))))))) ;;; -- cgit v1.3 From be4e38fb6f8f2da9de4f9c6ff9e448a9dc178c8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 18:13:10 +0200 Subject: derivations: Micro-optimize 'derivation'. * guix/derivations.scm (derivation->string): New procedure. (derivation-hash, derivation): Use it. Memoization here yields a 5% improvement on "guix build -e '(@ (gnu packages emacs) emacs)' -n --no-substitutes". --- guix/derivations.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index a3a4eae6a..09b7ec079 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -435,6 +435,14 @@ that form." port) (display ")" port)))) +(define derivation->string + (memoize + (lambda (drv) + "Return the external representation of DRV as a string." + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-output-string + (cut write-derivation drv <>)))))) + (define* (derivation->output-path drv #:optional (output "out")) "Return the store path of its output OUTPUT." (let ((outputs (derivation-outputs drv))) @@ -517,9 +525,7 @@ in SIZE bytes." ;; the SHA256 port's `write' method gets called for every single ;; character. (sha256 - (with-fluids ((%default-port-encoding "UTF-8")) - (string->utf8 (call-with-output-string - (cut write-derivation drv <>))))))))))) + (string->utf8 (derivation->string drv))))))))) (define (store-path type hash name) ; makeStorePath "Return the store path for NAME/HASH/TYPE." @@ -685,8 +691,7 @@ derivations where the costs of data transfers would outweigh the benefits." (drv (add-output-paths drv-masked))) (let ((file (add-text-to-store store (string-append name ".drv") - (call-with-output-string - (cut write-derivation drv <>)) + (derivation->string drv) (map derivation-input-path inputs)))) (set-file-name drv file)))) -- cgit v1.3 From 4dfe6c58ee204cf05ce9ef5abbc96ada44ef0784 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 15:44:59 +0200 Subject: system: Add (guix build activation). * gnu/services/dmd.scm (dmd-configuration-file): Remove 'etc' parameter. Move /etc activation code to... * guix/build/activation.scm: ... here; new file. * gnu/system.scm (operating-system-boot-script): Augment script: add (guix build activation) to the load path; call 'activate-etc'. * Makefile.am (MODULES): Add guix/build/activation.scm. --- Makefile.am | 1 + gnu/services/dmd.scm | 27 ++------------------ gnu/system.scm | 21 +++++++++++++--- guix/build/activation.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 84 insertions(+), 28 deletions(-) create mode 100644 guix/build/activation.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index d01032f53..22bbdca13 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/activation.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index c187c0985..161a971ed 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -30,9 +30,8 @@ ;;; ;;; Code: -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the derivation that builds the /etc directory) on startup." +(define (dmd-configuration-file services) + "Return the dmd configuration file for SERVICES." (define config #~(begin (use-modules (ice-9 ftw)) @@ -48,28 +47,6 @@ ETC (the derivation that builds the /etc directory) on startup." #:stop #$(service-stop service))) services)) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" #$etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink #$etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir #$etc - (lambda (file) - (not (member file '("." "..")))))) - - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink #$etc "/var/guix/gcroots/etc-directory")) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. (setenv "PATH" "/run/current-system/bin") diff --git a/gnu/system.scm b/gnu/system.scm index 86904d9be..4a8585758 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -256,10 +256,25 @@ we're running in the final root." (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services etc))) + (modules (imported-modules '((guix build activation)))) + (compiled (compiled-modules '((guix build activation)))) + (dmd-conf (dmd-configuration-file services))) (gexp->file "boot" - #~(execl (string-append #$dmd "/bin/dmd") - "dmd" "--config" #$dmd-conf)))) + #~(begin + (eval-when (expand load eval) + ;; Make sure 'use-modules' below succeeds. + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) + + (use-modules (guix build activation)) + + ;; Populate /etc. + (activate-etc #$etc) + + ;; Start dmd. + (execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf))))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/guix/build/activation.scm b/guix/build/activation.scm new file mode 100644 index 000000000..c8491677d --- /dev/null +++ b/guix/build/activation.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build activation) + #:use-module (ice-9 ftw) + #:export (activate-etc)) + +;;; Commentary: +;;; +;;; This module provides "activation" helpers. Activation is the process that +;;; consists in setting up system-wide files and directories so that an +;;; 'operating-system' configuration becomes active. +;;; +;;; Code: + +(define (activate-etc etc) + "Install ETC, a directory in the store, as the source of static files for +/etc." + + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + + (format #t "populating /etc from ~a...~%" etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir etc + (lambda (file) + (not (member file '("." "..")))) + + ;; The default is 'string-locale)[pam-services, setuid-programs]: New fields. (etc-directory)[bashrc]: Prepend /run/setuid-programs to $PATH. (operating-system-etc-directory): Honor 'operating-system-pam-services'. (%setuid-programs): New variable. (operating-system-boot-script): Add (guix build utils) to the set of imported modules. Call 'activate-setuid-programs' in boot script. * gnu/system/linux.scm (base-pam-services): New procedure. * guix/build/activation.scm (%setuid-directory): New variable. (activate-setuid-programs): New procedure. * build-aux/hydra/demo-os.scm: Add 'pam-services' field. --- build-aux/hydra/demo-os.scm | 4 ++++ gnu/system.scm | 33 ++++++++++++++++++++++++++++----- gnu/system/linux.scm | 11 +++++++++-- guix/build/activation.scm | 36 +++++++++++++++++++++++++++++++++++- 4 files changed, 76 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index c2ff012a1..3987c4048 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -34,6 +34,7 @@ (gnu packages package-management) (gnu system shadow) ; 'user-account' + (gnu system linux) ; 'base-pam-services' (gnu services base) (gnu services networking) (gnu services xorg)) @@ -56,6 +57,9 @@ #:gateway "10.0.2.2") %base-services)) + (pam-services + ;; Explicitly allow for empty passwords. + (base-pam-services #:allow-empty-passwords? #t)) (packages (list bash coreutils findutils grep sed procps psmisc less guile-2.0 dmd guix util-linux inetutils diff --git a/gnu/system.scm b/gnu/system.scm index 4a8585758..ba105e2df 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -106,7 +106,12 @@ (locale operating-system-locale) ; string (services operating-system-services ; list of monadic services - (default %base-services))) + (default %base-services)) + + (pam-services operating-system-pam-services ; list of PAM services + (default (base-pam-services))) + (setuid-programs operating-system-setuid-programs + (default %setuid-programs))) ; list of string-valued gexps @@ -191,6 +196,7 @@ export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin +export PATH=/run/setuid-programs:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -238,8 +244,8 @@ alias ll='ls -l' (pam-services -> ;; Services known to PAM. (delete-duplicates - (cons %pam-other-services - (append-map service-pam-services services)))) + (append (operating-system-pam-services os) + (append-map service-pam-services services)))) (accounts (operating-system-accounts os)) (profile-drv (operating-system-profile os)) (groups -> (append (operating-system-groups os) @@ -250,15 +256,29 @@ alias ll='ls -l' #:timezone (operating-system-timezone os) #:profile profile-drv))) +(define %setuid-programs + ;; Default set of setuid-root programs. + (let ((shadow (@ (gnu packages admin) shadow))) + (list #~(string-append #$shadow "/bin/passwd") + #~(string-append #$shadow "/bin/su") + #~(string-append #$inetutils "/bin/ping")))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." + (define %modules + '((guix build activation) + (guix build utils))) + (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (modules (imported-modules '((guix build activation)))) - (compiled (compiled-modules '((guix build activation)))) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) (dmd-conf (dmd-configuration-file services))) + (define setuid-progs + (operating-system-setuid-programs os)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -272,6 +292,9 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Activate setuid programs. + (activate-setuid-programs (list #$@setuid-progs)) + ;; Start dmd. (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index efe27c55c..4030d8860 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -29,8 +29,8 @@ #:export (pam-service pam-entry pam-services->directory - %pam-other-services - unix-pam-service)) + unix-pam-service + base-pam-services)) ;;; Commentary: ;;; @@ -152,4 +152,11 @@ should be the name of a file used as the message-of-the-day." (list #~(string-append "motd=" #$motd))))) (list unix)))))))) +(define* (base-pam-services #:key allow-empty-passwords?) + "Return the list of basic PAM services everyone would want." + (list %pam-other-services + (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) + (unix-pam-service "passwd" + #:allow-empty-passwords? allow-empty-passwords?))) + ;;; linux.scm ends here diff --git a/guix/build/activation.scm b/guix/build/activation.scm index c8491677d..6930a8c58 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -17,8 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build activation) + #:use-module (guix build utils) #:use-module (ice-9 ftw) - #:export (activate-etc)) + #:export (activate-etc + activate-setuid-programs)) ;;; Commentary: ;;; @@ -60,4 +62,36 @@ (rm-f "/var/guix/gcroots/etc-directory") (symlink etc "/var/guix/gcroots/etc-directory"))) +(define %setuid-directory + ;; Place where setuid programs are stored. + "/run/setuid-programs") + +(define (activate-setuid-programs programs) + "Turn PROGRAMS, a list of file names, into setuid programs stored under +%SETUID-DIRECTORY." + (define (make-setuid-program prog) + (let ((target (string-append %setuid-directory + "/" (basename prog)))) + (catch 'system-error + (lambda () + (link prog target)) + (lambda args + ;; Perhaps PROG and TARGET live in a different file system, so copy + ;; PROG. + (copy-file prog target))) + (chown target 0 0) + (chmod target #o6555))) + + (format #t "setting up setuid programs in '~a'...~%" + %setuid-directory) + (if (file-exists? %setuid-directory) + (for-each delete-file + (scandir %setuid-directory + (lambda (file) + (not (member file '("." "..")))) + string: Add call to 'set-record-type-printer!'. --- guix/gexp.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index a52360cd1..79b6ec708 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -26,6 +26,7 @@ #:use-module (guix packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (gexp @@ -56,6 +57,15 @@ (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) (proc gexp-proc)) ; procedure +(define (write-gexp gexp port) + "Write GEXP on PORT." + (display "#" + (number->string (object-address gexp) 16))) + +(set-record-type-printer! write-gexp) + ;; Reference to one of the derivation's outputs, for gexps used in ;; derivations. (define-record-type -- cgit v1.3 From 79c0c8cdf74cc0587187aa8f25af29b21fe91ba2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 16:15:00 +0200 Subject: gexp: Add support for 'origin?' objects in 'ungexp' forms. * guix/gexp.scm (lower-inputs, gexp-inputs, gexp->sexp, canonicalize-reference): Add 'origin?' case. * guix/monads.scm (origin->derivation): New procedure. * tests/gexp.scm ("one input origin"): New test. --- guix/gexp.scm | 12 ++++++++++++ guix/monads.scm | 4 ++++ tests/gexp.scm | 14 ++++++++++++-- 3 files changed, 28 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 79b6ec708..ff4fd3f28 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -85,6 +85,9 @@ input list as a monadic value." (((? package? package) sub-drv ...) (mlet %store-monad ((drv (package->derivation package))) (return `(,drv ,@sub-drv)))) + (((? origin? origin) sub-drv ...) + (mlet %store-monad ((drv (origin->derivation origin))) + (return `(,drv ,@sub-drv)))) (input (return input))) inputs)))) @@ -158,6 +161,8 @@ The other arguments are as for 'derivation'." (cons ref result)) (((? package?) (? string?)) (cons ref result)) + (((? origin?) (? string?)) + (cons ref result)) ((? gexp? exp) (append (gexp-inputs exp) result)) (((? string? file)) @@ -199,6 +204,9 @@ and in the current monad setting (system type, etc.)" (return (derivation->output-path drv output))) (((? package? p) (? string? output)) (package-file p #:output output)) + (((? origin? o) (? string? output)) + (mlet %store-monad ((drv (origin->derivation o))) + (return (derivation->output-path drv output)))) (($ output) ;; Output file names are not known in advance but the daemon defines ;; an environment variable for each of them at build time, so use @@ -224,10 +232,14 @@ package/derivation references." (match ref ((? package? p) `(,p "out")) + ((? origin? o) + `(,o "out")) ((? derivation? d) `(,d "out")) (((? package?) (? string?)) ref) + (((? origin?) (? string?)) + ref) (((? derivation?) (? string?)) ref) ((? string? s) diff --git a/guix/monads.scm b/guix/monads.scm index 0e99cb37f..809aba59b 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -56,6 +56,7 @@ text-file text-file* package-file + origin->derivation package->derivation built-derivations) #:replace (imported-modules @@ -395,6 +396,9 @@ input list as a monadic value." (define package->derivation (store-lift package-derivation)) +(define origin->derivation + (store-lift package-source-derivation)) + (define imported-modules (store-lift (@ (guix derivations) imported-modules))) diff --git a/tests/gexp.scm b/tests/gexp.scm index 3da5b82e4..21606b510 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -21,8 +21,7 @@ #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix derivations) - #:use-module ((guix packages) - #:select (package-derivation %current-system)) + #:use-module (guix packages) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) @@ -83,6 +82,17 @@ (package-derivation %store coreutils))) (gexp->sexp* exp))))) +(test-assert "one input origin" + (let ((exp (gexp (display (ungexp (package-source coreutils)))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((o "out")) + (eq? o (package-source coreutils)))) + (equal? `(display ,(derivation->output-path + (package-source-derivation + %store (package-source coreutils)))) + (gexp->sexp* exp))))) + (test-assert "same input twice" (let ((exp (gexp (begin (display (ungexp coreutils)) -- cgit v1.3 From 53e89b1732d2935d69a199c0213568ae1e66eb60 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 18:53:16 +0200 Subject: monads, gexp: Remove unintended dependency on (gnu packages …). * guix/gexp.scm (gexp->derivation, gexp->script): Use 'default-guile' instead of an explicit reference to 'guile-final'. (default-guile): New procedure. * guix/monads.scm (run-with-store)[default-guile]: New procedure. Use it. --- guix/gexp.scm | 14 +++++++++----- guix/monads.scm | 9 +++++++-- 2 files changed, 16 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index ff4fd3f28..a2ba50d95 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -129,9 +129,8 @@ The other arguments are as for 'derivation'." (return #f))) (guile (if guile-for-build (return guile-for-build) - (package->derivation - (@ (gnu packages base) guile-final) - system)))) + (package->derivation (default-guile) + system)))) (raw-derivation name (string-append (derivation->output-path guile) "/bin/guile") @@ -336,9 +335,14 @@ package/derivation references." ;;; Convenience procedures. ;;; +(define (default-guile) + ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) + ;; modules directly, to avoid circular dependencies, hence this hack. + (module-ref (resolve-interface '(gnu packages base)) + 'guile-final)) + (define* (gexp->script name exp - #:key (modules '()) - (guile (@ (gnu packages base) guile-final))) + #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in its search path." (mlet %store-monad ((modules (imported-modules modules)) diff --git a/guix/monads.scm b/guix/monads.scm index 809aba59b..ec2b7f8b3 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -414,10 +414,15 @@ input list as a monadic value." (system (%current-system))) "Run MVAL, a monadic value in the store monad, in STORE, an open store connection." + (define (default-guile) + ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) + ;; modules directly, to avoid circular dependencies, hence this hack. + (module-ref (resolve-interface '(gnu packages base)) + 'guile-final)) + (parameterize ((%guile-for-build (or guile-for-build (package-derivation store - (@ (gnu packages base) - guile-final) + (default-guile) system))) (%current-system system)) (mval store))) -- cgit v1.3 From 6f8f8ccb5bcc883a63c2d98463f514c9745dcb8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 21:07:52 +0200 Subject: download: Rewrite using gexps. * guix/download.scm (gnutls-derivation): Remove. (gnutls-package): New procedure. (url-fetch): Rewrite using 'gexp->derivation'. --- guix/download.scm | 88 ++++++++++++++++++++++++++----------------------------- 1 file changed, 41 insertions(+), 47 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 2cb074089..8ec17ae55 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -23,6 +23,8 @@ #:use-module (guix packages) #:use-module ((guix store) #:select (derivation-path? add-to-store)) #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:)) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix utils) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -167,11 +169,10 @@ "http://ftp.fr.debian.org/debian/" "http://ftp.debian.org/debian/")))) -(define (gnutls-derivation store system) - "Return the GnuTLS derivation for SYSTEM." - (let* ((module (resolve-interface '(gnu packages gnutls))) - (gnutls (module-ref module 'gnutls))) - (package-derivation store gnutls system))) +(define (gnutls-package) + "Return the GnuTLS package for SYSTEM." + (let ((module (resolve-interface '(gnu packages gnutls)))) + (module-ref module 'gnutls))) (define* (url-fetch store url hash-algo hash #:optional name @@ -186,22 +187,13 @@ different file name. When one of the URL starts with mirror://, then its host part is interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS must be a list of symbol/URL-list pairs." - (define builder - `(begin - (use-modules (guix build download)) - (url-fetch ',url %output - #:mirrors ',mirrors))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system)) - ((and (? string?) (? derivation-path?)) - guile) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages base))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system))))) + (package-derivation store + (or guile + (let ((distro + (resolve-interface '(gnu packages base)))) + (module-ref distro 'guile-final))) + system)) (define file-name (match url @@ -219,34 +211,36 @@ must be a list of symbol/URL-list pairs." ((url ...) (any https? url))))) - (let* ((gnutls-drv (if need-gnutls? - (gnutls-derivation store system) - (values #f #f))) - (gnutls (and gnutls-drv - (derivation->output-path gnutls-drv "out"))) - (env-vars (if gnutls - (let ((dir (string-append gnutls "/share/guile/site"))) - ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden - ;; by `build-expression->derivation', so we can't - ;; set it here. - `(("GUILE_LOAD_PATH" . ,dir))) - '()))) - (build-expression->derivation store (or name file-name) builder - #:system system - #:inputs (if gnutls-drv - `(("gnutls" ,gnutls-drv)) - '()) - #:hash-algo hash-algo - #:hash hash - #:modules '((guix build download) - (guix build utils) - (guix ftp-client)) - #:guile-for-build guile-for-build - #:env-vars env-vars + (define builder + #~(begin + #$(if need-gnutls? + + ;; Add GnuTLS to the inputs and to the load path. + #~(eval-when (load expand eval) + (set! %load-path + (cons (string-append #$(gnutls-package) + "/share/guile/site") + %load-path))) + #~#t) + + (use-modules (guix build download)) + (url-fetch '#$url #$output + #:mirrors '#$mirrors))) + + (run-with-store store + (gexp->derivation (or name file-name) builder + #:system system + #:hash-algo hash-algo + #:hash hash + #:modules '((guix build download) + (guix build utils) + (guix ftp-client)) + #:guile-for-build guile-for-build - ;; In general, offloading downloads is not a - ;; good idea. - #:local-build? #t))) + ;; In general, offloading downloads is not a good idea. + #:local-build? #t) + #:guile-for-build guile-for-build + #:system system)) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port))) -- cgit v1.3 From 83bcd0b895016c058807e71e102c54d2fab44339 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 00:26:07 +0200 Subject: system: Add first-class file system declarations. * gnu/system.scm ()[initrd]: Default to 'qemu-initrd'. (): New record type. (operating-system-root-file-system): New procedure. (operating-system-derivation): Take the device name for GRUB from 'operating-system-root-file-system'. Pass the 'operating-system-initrd' procedure the list of boot file systems. * gnu/system/linux-initrd.scm (file-system->spec): New procedure. (qemu-initrd): Add 'file-systems' parameter, and remove #:mounts parameter. [file-system-type-predicate]: New procedure. [linux-modules]: Use it. Adjust #:mounts argument in 'boot-system' call. (gnu-system-initrd): Remove. * gnu/system/vm.scm (%linux-vm-file-systems): New variable. (expression->derivation-in-linux-vm): Adjust call to 'qemu-initrd'. (virtualized-operating-system): New procedure. (system-qemu-image/shared-store-script)[initrd]: Remove. Use 'virtualized-operating-system'. Get the 'initrd' file from OS-DRV. * guix/build/linux-initrd.scm (mount-qemu-smb-share, mount-qemu-9p): Remove. (MS_RDONLY, MS_BIND): New global variables. (bind-mount): Remove local 'MS_BIND' definition. (mount-root-file-system): New procedure, with code formerly in 'boot-system'. (mount-file-system): New procedure. (boot-system): Add #:root-fs-type parameter. Remove 'MS_RDONLY' local variable. Use 'mount-root-file-system' and 'mount-file-system'. * doc/guix.texi (Using the Configuration System): Add 'file-system' declaration. --- .dir-locals.el | 2 + doc/guix.texi | 4 ++ gnu/system.scm | 52 ++++++++++++++++-- gnu/system/linux-initrd.scm | 47 ++++++++-------- gnu/system/vm.scm | 46 ++++++++++++---- guix/build/linux-initrd.scm | 129 ++++++++++++++++++++++---------------------- 6 files changed, 180 insertions(+), 100 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index a6135b171..64a680c59 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,8 @@ (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0)) + (eval . (put 'operating-system 'scheme-indent-function 0)) + (eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-pattern 'scheme-indent-function 0)) (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 3ae2b7e00..99acad56e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3088,6 +3088,10 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: (host-name "komputilo") (timezone "Europe/Paris") (locale "fr_FR.UTF-8") + (file-systems (list (file-system + (device "/dev/disk/by-label/root") + (mount-point "/") + (type "ext3")))) (users (list (user-account (name "alice") (password "") diff --git a/gnu/system.scm b/gnu/system.scm index 6c94eb90c..7624b10ae 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -51,9 +51,20 @@ operating-system-timezone operating-system-locale operating-system-services + operating-system-file-systems operating-system-derivation - operating-system-profile)) + operating-system-profile + + + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-needed-for-boot? + file-system-flags + file-system-options)) ;;; Commentary: ;;; @@ -72,8 +83,8 @@ (default grub)) (bootloader-entries operating-system-bootloader-entries ; list (default '())) - (initrd operating-system-initrd ; monadic derivation - (default (gnu-system-initrd))) + (initrd operating-system-initrd ; (list fs) -> M derivation + (default qemu-initrd)) (host-name operating-system-host-name) ; string @@ -112,6 +123,22 @@ (sudoers operating-system-sudoers ; /etc/sudoers contents (default %sudoers-specification))) +;; File system declaration. +(define-record-type* file-system + make-file-system + file-system? + (device file-system-device) ; string + (mount-point file-system-mount-point) ; string + (type file-system-type) ; string + (flags file-system-flags ; list of symbols + (default '())) + (options file-system-options ; string or #f + (default #f)) + (needed-for-boot? file-system-needed-for-boot? ; Boolean + (default #f)) + (check? file-system-check? ; Boolean + (default #t))) + ;;; ;;; Derivation. @@ -311,16 +338,30 @@ we're running in the final root." (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) +(define (operating-system-root-file-system os) + "Return the root file system of OS." + (find (match-lambda + (($ _ "/") #t) + (_ #f)) + (operating-system-file-systems os))) + (define (operating-system-derivation os) "Return a derivation that builds OS." + (define boot-file-systems + (filter (match-lambda + (($ device mount-point type _ _ boot?) + (and boot? (not (string=? mount-point "/"))))) + (operating-system-file-systems os))) + (mlet* %store-monad ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) (services (sequence %store-monad (operating-system-services os))) (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) - (initrd (operating-system-initrd os)) + (initrd ((operating-system-initrd os) boot-file-systems)) (initrd-file -> #~(string-append #$initrd "/initrd")) + (root-fs -> (operating-system-root-file-system os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -328,7 +369,8 @@ we're running in the final root." " (technology preview)")) (linux kernel) (linux-arguments - (list "--root=/dev/sda1" + (list (string-append "--root=" + (file-system-device root-fs)) #~(string-append "--load=" #$boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 6e04ad150..8b4ab9c4e 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -30,11 +30,12 @@ #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (gnu system) ; for 'file-system' #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:export (expression->initrd - qemu-initrd - gnu-system-initrd)) + qemu-initrd)) ;;; Commentary: @@ -193,24 +194,29 @@ a list of Guile module names to be embedded in the initrd." (gexp->derivation name builder #:modules '((guix build utils))))) -(define* (qemu-initrd #:key +(define (file-system->spec fs) + "Return a list corresponding to file-system FS that can be passed to the +initrd code." + (match fs + (($ device mount-point type flags options) + (list device mount-point type flags options)))) + +(define* (qemu-initrd file-systems + #:key guile-modules-in-chroot? - volatile-root? - (mounts `((cifs "/store" ,(%store-prefix)) - (cifs "/xchg" "/xchg")))) + volatile-root?) "Return a monadic derivation that builds an initrd for use in a QEMU guest -where the store is shared with the host. MOUNTS is a list of file systems to -be mounted atop the root file system, where each item has the form: +where the store is shared with the host. FILE-SYSTEMS is a list of +file-systems to be mounted by the initrd, possibly in addition to the root +file system specified on the kernel command line via '--root'. - (FILE-SYSTEM-TYPE SOURCE TARGET) +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost. When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in the new root. This is necessary is the file specified as '--load' needs access to these modules (which is the case if it wants to even just print an -exception and backtrace!). - -When VOLATILE-ROOT? is true, the root file system is writable but any changes -to it are lost." +exception and backtrace!)." (define cifs-modules ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) @@ -219,14 +225,18 @@ to it are lost." ;; Modules for the 9p paravirtualized file system. '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) + (define (file-system-type-predicate type) + (lambda (fs) + (string=? (file-system-type fs) type))) + (define linux-modules ;; Modules added to the initrd and loaded from the initrd. `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" - ,@(if (assoc-ref mounts 'cifs) + ,@(if (find (file-system-type-predicate "cifs") file-systems) cifs-modules '()) - ,@(if (assoc-ref mounts '9p) + ,@(if (find (file-system-type-predicate "9p") file-systems) virtio-9p-modules '()) ,@(if volatile-root? @@ -238,7 +248,7 @@ to it are lost." (use-modules (guix build linux-initrd) (srfi srfi-26)) - (boot-system #:mounts '#$mounts + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? @@ -254,9 +264,4 @@ to it are lost." #:linux linux-libre #:linux-modules linux-modules)) -(define (gnu-system-initrd) - "Initrd for the GNU system itself, with nothing QEMU-specific." - (qemu-initrd #:guile-modules-in-chroot? #f - #:mounts '())) - ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index db24c4e76..c08031741 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -82,6 +82,22 @@ input tuple. The output file name is when building for SYSTEM." ((input (and (? string?) (? store-path?) file)) (return `(,input . ,file)))))) +(define %linux-vm-file-systems + ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg + ;; directory are shared with the host over 9p. + (list (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")) + (file-system + (mount-point "/xchg") + (device "xchg") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -130,9 +146,8 @@ made available under the /xchg CIFS share." (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) (initrd (if initrd ; use the default initrd? (return initrd) - (qemu-initrd #:guile-modules-in-chroot? #t - #:mounts `((9p "store" ,(%store-prefix)) - (9p "xchg" "/xchg")))))) + (qemu-initrd %linux-vm-file-systems + #:guile-modules-in-chroot? #t)))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -292,6 +307,22 @@ system as described by OS." #:initialize-store? #t #:inputs-to-copy `(("system" ,os-drv))))) +(define (virtualized-operating-system os) + "Return an operating system based on OS suitable for use in a virtualized +environment with the store shared with the host." + (operating-system (inherit os) + (initrd (cut qemu-initrd <> #:volatile-root? #t)) + (file-systems (list (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext3")) + (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))))) + (define* (system-qemu-image/shared-store os #:key (disk-image-size (* 15 (expt 2 20)))) @@ -314,14 +345,9 @@ with the host." (graphic? #t)) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host." - (define initrd - (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) - #:volatile-root? #t)) - (mlet* %store-monad - ((os -> (operating-system (inherit os) (initrd initrd))) + ((os -> (virtualized-operating-system os)) (os-drv (operating-system-derivation os)) - (initrd initrd) (image (system-qemu-image/shared-store os))) (define builder #~(call-with-output-file #$output @@ -332,7 +358,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ -net user \ -kernel " #$(operating-system-kernel os) "/bzImage \ - -initrd " #$initrd "/initrd \ + -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") "--load=" #$os-drv "/boot --root=/dev/vda1\" \ -drive file=" #$image diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 4decc3b15..1e0d6e27e 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,8 +30,7 @@ linux-command-line make-essential-device-nodes configure-qemu-networking - mount-qemu-smb-share - mount-qemu-9p + mount-file-system bind-mount load-linux-module* device-number @@ -170,33 +169,12 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." (logand (network-interface-flags sock interface) IFF_UP))) -(define (mount-qemu-smb-share share mount-point) - "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT. - -Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our -`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares - (the latter allows the store to be shared between the host and guest.)" - - (format #t "mounting QEMU's SMB share `~a'...\n" share) - (let ((server "10.0.2.4")) - (mount (string-append "//" server share) mount-point "cifs" 0 - (string->pointer "guest,sec=none")))) - -(define (mount-qemu-9p source mount-point) - "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT. - -This uses the 'virtio' transport, which requires the various virtio Linux -modules to be loaded." - - (format #t "mounting QEMU's 9p share '~a'...\n" source) - (let ((server "10.0.2.4")) - (mount source mount-point "9p" 0 - (string->pointer "trans=virtio")))) +;; Linux mount flags, from libc's . +(define MS_RDONLY 1) +(define MS_BIND 4096) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." - (define MS_BIND 4096) ; from libc's - (mount source target "" MS_BIND)) (define (load-linux-module* file) @@ -211,11 +189,67 @@ modules to be loaded." the last argument of `mknod'." (+ (* major 256) minor)) +(define* (mount-root-file-system root type + #:key volatile-root? unionfs) + "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? +is true, mount ROOT read-only and make it a union with a writable tmpfs using +UNIONFS." + (catch #t + (lambda () + (if volatile-root? + (begin + (mkdir-p "/real-root") + (mount root "/real-root" type MS_RDONLY) + (mkdir-p "/rw-root") + (mount "none" "/rw-root" "tmpfs") + + ;; We want read-write /dev nodes. + (make-essential-device-nodes #:root "/rw-root") + + ;; Make /root a union of the tmpfs and the actual root. + (unless (zero? (system* unionfs "-o" + "cow,allow_other,use_ino,suid,dev" + "/rw-root=RW:/real-root=RO" + "/root")) + (error "unionfs failed"))) + (mount root "/root" "ext3"))) + (lambda args + (format (current-error-port) "exception while mounting '~a': ~s~%" + root args) + (start-repl)))) + +(define* (mount-file-system spec #:key (root "/root")) + "Mount the file system described by SPEC under ROOT. SPEC must have the +form: + + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + +DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; +FLAGS must be a list of symbols." + (define flags->bit-mask + (match-lambda + (('read-only rest ...) + (or MS_RDONLY (flags->bit-mask rest))) + (('bind-mount rest ...) + (or MS_BIND (flags->bit-mask rest))) + (() + 0))) + + (match spec + ((source mount-point type (flags ...) options) + (let ((mount-point (string-append root "/" mount-point))) + (mkdir-p mount-point) + (mount source mount-point type (flags->bit-mask flags) + (if options + (string->pointer options) + %null-pointer)))))) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs + (root-fs-type "ext3") (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -223,9 +257,7 @@ QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS, and finally booting into the new root if any. The initrd supports kernel command-line options '--load', '--root', and '--repl'. -MOUNTS must be a list of elements of the form: - - (FILE-SYSTEM-TYPE SOURCE TARGET) +MOUNTS must be a list suitable for 'mount-file-system'. When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in the new root. @@ -241,8 +273,6 @@ to it are lost." (resolve (string-append "/root" target))) file))) - (define MS_RDONLY 1) - (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -276,29 +306,9 @@ to it are lost." (unless (file-exists? "/root") (mkdir "/root")) (if root - (catch #t - (lambda () - (if volatile-root? - (begin - (mkdir-p "/real-root") - (mount root "/real-root" "ext3" MS_RDONLY) - (mkdir-p "/rw-root") - (mount "none" "/rw-root" "tmpfs") - - ;; We want read-write /dev nodes. - (make-essential-device-nodes #:root "/rw-root") - - ;; Make /root a union of the tmpfs and the actual root. - (unless (zero? (system* unionfs "-o" - "cow,allow_other,use_ino,suid,dev" - "/rw-root=RW:/real-root=RO" - "/root")) - (error "unionfs failed"))) - (mount root "/root" "ext3"))) - (lambda args - (format (current-error-port) "exception while mounting '~a': ~s~%" - root args) - (start-repl))) + (mount-root-file-system root root-fs-type + #:volatile-root? volatile-root? + #:unionfs unionfs) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -308,16 +318,7 @@ to it are lost." (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each (match-lambda - (('cifs source target) - (let ((target (string-append "/root/" target))) - (mkdir-p target) - (mount-qemu-smb-share source target))) - (('9p source target) - (let ((target (string-append "/root/" target))) - (mkdir-p target) - (mount-qemu-9p source target)))) - mounts) + (for-each mount-file-system mounts) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the -- cgit v1.3 From 3c986b75f5705b37833d15353aad9a8db6d7b65b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 00:43:37 +0200 Subject: ftp-client: Add missing CR in "USER" command. * guix/ftp-client.scm (%ftp-login): Add #\return before #\newline. Fixes access to some FTP servers, such as ftp://invisible-island.net ("ProFTPD 1.3.4a Server"). --- guix/ftp-client.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index dd9135e95..761980ac8 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -73,7 +73,8 @@ (throw 'ftp-error port command code message)))) (define (%ftp-login user pass port) - (let ((command (string-append "USER " user (string #\newline)))) + (let ((command (string-append "USER " user + (string #\return) (string #\newline)))) (display command port) (let-values (((code message) (%ftp-listen port))) (case code -- cgit v1.3 From 03ddfaf5fb5fab78f7180089158bea0494072b3c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 12:16:10 +0200 Subject: vm: Make root file system type a parameter, and default to ext4. * gnu/system/vm.scm (qemu-image): Add #:file-system-type parameter. Pass it to 'initialize-hard-disk'. * guix/build/linux-initrd.scm (mount-root-file-system): Always honor TYPE. (boot-system): Change #:root-fs-type to default to "ext4". Update docstring. * guix/build/vm.scm (initialize-hard-disk): Remove #:mkfs parameter; add #:file-system-type. Adjust 'mkfs' invocation and 'mount' call to honor #:file-system-type. --- gnu/system/vm.scm | 11 +++++++---- guix/build/linux-initrd.scm | 7 +++++-- guix/build/vm.scm | 9 +++++---- 3 files changed, 17 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c08031741..867e01ad5 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -188,13 +188,15 @@ made available under the /xchg CIFS share." (system (%current-system)) (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) + (file-system-type "ext4") grub-configuration (initialize-store? #f) (populate #f) (inputs-to-copy '())) - "Return a bootable, stand-alone QEMU image. The returned image is a full -disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its -configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) + "Return a bootable, stand-alone QEMU image, with a root partition of type +FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB +installation that uses GRUB-CONFIGURATION as its configuration +file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied into the image being built. When INITIALIZE-STORE? is true, initialize the @@ -235,6 +237,7 @@ such as /etc files." (initialize-hard-disk #:grub.cfg #$grub-configuration #:closures-to-copy graphs #:disk-image-size #$disk-image-size + #:file-system-type #$file-system-type #:initialize-store? #$initialize-store? #:directives '#$populate) (reboot)))) @@ -315,7 +318,7 @@ environment with the store shared with the host." (file-systems (list (file-system (mount-point "/") (device "/dev/vda1") - (type "ext3")) + (type "ext4")) (file-system (mount-point (%store-prefix)) (device "store") diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 1e0d6e27e..fd6c0c467 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -212,7 +212,7 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" "ext3"))) + (mount root "/root" type))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) @@ -249,7 +249,7 @@ FLAGS must be a list of symbols." qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs - (root-fs-type "ext3") + (root-fs-type "ext4") (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -257,6 +257,9 @@ QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS, and finally booting into the new root if any. The initrd supports kernel command-line options '--load', '--root', and '--repl'. +Mount the root file system, of type ROOT-FS-TYPE, specified by the '--root' +command-line argument, if any. + MOUNTS must be a list suitable for 'mount-file-system'. When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 33c898d96..1d1abad1d 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -183,7 +183,7 @@ as created and modified at the Epoch." (define* (initialize-hard-disk #:key grub.cfg disk-image-size - (mkfs "mkfs.ext3") + (file-system-type "ext4") initialize-store? (closures-to-copy '()) (directives '())) @@ -192,13 +192,14 @@ as created and modified at the Epoch." (- disk-image-size (* 5 (expt 2 20)))) (error "failed to create partition table")) - (display "creating ext3 partition...\n") - (unless (zero? (system* mkfs "-F" "/dev/sda1")) + (format #t "creating ~a partition...\n" file-system-type) + (unless (zero? (system* (string-append "mkfs." file-system-type) + "-F" "/dev/sda1")) (error "failed to create partition")) (display "mounting partition...\n") (mkdir "/fs") - (mount "/dev/sda1" "/fs" "ext3") + (mount "/dev/sda1" "/fs" file-system-type) (when (pair? closures-to-copy) ;; Populate the store. -- cgit v1.3 From ad896f23a5fac38294e7515587c0c5bda02e9a59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 00:18:46 +0200 Subject: activation: Fix deletion of setuid programs. * guix/build/activation.scm (activate-setuid-programs): When %SETUID-DIRECTORY exists, pass the right file names to 'delete-file'. --- guix/build/activation.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 6930a8c58..f9d9ba5cb 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,6 +19,7 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (srfi srfi-26) #:export (activate-etc activate-setuid-programs)) @@ -85,7 +86,8 @@ (format #t "setting up setuid programs in '~a'...~%" %setuid-directory) (if (file-exists? %setuid-directory) - (for-each delete-file + (for-each (compose delete-file + (cut string-append %setuid-directory "/" <>)) (scandir %setuid-directory (lambda (file) (not (member file '("." "..")))) -- cgit v1.3 From 3c05b4bc2528ea64b259477bf58dbcc6a7739f78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 00:30:39 +0200 Subject: linux-initrd: Check the root and other early file systems. * gnu/system.scm (operating-system-derivation)[boot-file-systems]: Keep "/". * gnu/system/linux-initrd.scm (file-system->spec): Keep the 'check?' flag. (qemu-initrd)[helper-packages]: New variable. Pass it as #:to-copy. : Add 'set-path-environment-variable' call. Remove #:unionfs argument for 'boot-system'. * gnu/system/vm.scm (%linux-vm-file-systems): Add 'check?' field/ (virtualized-operating-system): Likewise for the "9p" file system. * guix/build/linux-initrd.scm (mount-root-file-system): Change #:unionfs default. Call 'check-file-system' before mounting ROOT, when VOLATILE-ROOT? is false. (check-file-system): New procedure. (mount-file-system): Honor 'check?' element in list; add 'check-file-system' call. (boot-system): Remove #:root-fs-type and #:unionfs parameters. [root-mount-point?, root-fs-type]: New variables. Call 'mount-file-system' on all MOUNTS but "/". --- gnu/system.scm | 6 +++-- gnu/system/linux-initrd.scm | 27 +++++++++++++++----- gnu/system/vm.scm | 9 ++++--- guix/build/linux-initrd.scm | 62 ++++++++++++++++++++++++++++++++++++--------- 4 files changed, 80 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/gnu/system.scm b/gnu/system.scm index 7624b10ae..65d1ca341 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -349,8 +349,10 @@ we're running in the final root." "Return a derivation that builds OS." (define boot-file-systems (filter (match-lambda - (($ device mount-point type _ _ boot?) - (and boot? (not (string=? mount-point "/"))))) + (($ device "/") + #t) + (($ device mount-point type flags options boot?) + boot?)) (operating-system-file-systems os))) (mlet* %store-monad diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8b4ab9c4e..749dfa313 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options) - (list device mount-point type flags options)))) + (($ device mount-point type flags options _ check?) + (list device mount-point type flags options check?)))) (define* (qemu-initrd file-systems #:key @@ -243,24 +243,37 @@ exception and backtrace!)." '("fuse.ko") '()))) + (define helper-packages + ;; Packages to be copied on the initrd. + `(,@(if (find (lambda (fs) + (string-prefix? "ext" (file-system-type fs))) + file-systems) + (list e2fsck/static) + '()) + ,@(if volatile-root? + (list unionfs-fuse/static) + '()))) + (expression->initrd #~(begin (use-modules (guix build linux-initrd) + (guix build utils) (srfi srfi-26)) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? - #:unionfs (and=> #$(and volatile-root? unionfs-fuse/static) - (cut string-append <> "/bin/unionfs")) #:volatile-root? '#$volatile-root?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) - #:to-copy (if volatile-root? - (list unionfs-fuse/static) - '()) + #:to-copy helper-packages #:linux linux-libre #:linux-modules linux-modules)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 786e56403..b20831f44 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -90,13 +90,15 @@ input tuple. The output file name is when building for SYSTEM." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")) + (options "trans=virtio") + (check? #f)) (file-system (mount-point "/xchg") (device "xchg") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))) + (options "trans=virtio") + (check? #f)))) (define* (expression->derivation-in-linux-vm name exp #:key @@ -333,7 +335,8 @@ environment with the store shared with the host." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))))) + (options "trans=virtio") + (check? #f)))))) (define* (system-qemu-image/shared-store os diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index fd6c0c467..b2cbcae7d 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -190,7 +190,7 @@ the last argument of `mknod'." (+ (* major 256) minor)) (define* (mount-root-file-system root type - #:key volatile-root? unionfs) + #:key volatile-root? (unionfs "unionfs")) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it a union with a writable tmpfs using UNIONFS." @@ -212,20 +212,45 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" type))) + (begin + (check-file-system root type) + (mount root "/root" type)))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) (start-repl)))) +(define (check-file-system device type) + "Run a file system check of TYPE on DEVICE." + (define fsck + (string-append "fsck." type)) + + (let ((status (system* fsck "-v" "-p" device))) + (match (status:exit-val status) + (0 + #t) + (1 + (format (current-error-port) "'~a' corrected errors on ~a; continuing~%" + fsck device)) + (2 + (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%" + fsck device) + (sleep 3) + (reboot)) + (code + (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%" + fsck code device) + (start-repl))))) + (define* (mount-file-system spec #:key (root "/root")) "Mount the file system described by SPEC under ROOT. SPEC must have the form: - (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; -FLAGS must be a list of symbols." +FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to +run a file system check." (define flags->bit-mask (match-lambda (('read-only rest ...) @@ -236,8 +261,10 @@ FLAGS must be a list of symbols." 0))) (match spec - ((source mount-point type (flags ...) options) + ((source mount-point type (flags ...) options check?) (let ((mount-point (string-append root "/" mount-point))) + (when check? + (check-file-system source type)) (mkdir-p mount-point) (mount source mount-point type (flags->bit-mask flags) (if options @@ -248,8 +275,7 @@ FLAGS must be a list of symbols." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? unionfs - (root-fs-type "ext4") + volatile-root? (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -257,8 +283,8 @@ QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS, and finally booting into the new root if any. The initrd supports kernel command-line options '--load', '--root', and '--repl'. -Mount the root file system, of type ROOT-FS-TYPE, specified by the '--root' -command-line argument, if any. +Mount the root file system, specified by the '--root' command-line argument, +if any. MOUNTS must be a list suitable for 'mount-file-system'. @@ -276,6 +302,18 @@ to it are lost." (resolve (string-append "/root" target))) file))) + (define root-mount-point? + (match-lambda + ((device "/" _ ...) #t) + (_ #f))) + + (define root-fs-type + (or (any (match-lambda + ((device "/" type _ ...) type) + (_ #f)) + mounts) + "ext4")) + (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -310,8 +348,7 @@ to it are lost." (mkdir "/root")) (if root (mount-root-file-system root root-fs-type - #:volatile-root? volatile-root? - #:unionfs unionfs) + #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -321,7 +358,8 @@ to it are lost." (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each mount-file-system mounts) + (for-each mount-file-system + (remove root-mount-point? mounts)) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the -- cgit v1.3 From 1d4628329d37c5e5857c70f3720b941e4bbcfcd2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 22:24:47 +0200 Subject: linux-initrd: Improve root file system switching. * guix/build/linux-initrd.scm (move-essential-file-systems, switch-root): New procedures. (MS_MOVE): New variable. (boot-system): Remove 'mount-essential-file-systems' call for ROOT. Use 'switch-root' instead of chdir + chroot. --- guix/build/linux-initrd.scm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b2cbcae7d..b133550bc 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -62,6 +62,15 @@ (mkdir (scope "sys"))) (mount "none" (scope "sys") "sysfs")) +(define (move-essential-file-systems root) + "Move currently mounted essential file systems to ROOT." + (for-each (lambda (dir) + (let ((target (string-append root dir))) + (unless (file-exists? target) + (mkdir target)) + (mount dir target "" MS_MOVE))) + '("/proc" "/sys"))) + (define (linux-command-line) "Return the Linux kernel command line as a list of strings." (string-tokenize @@ -172,6 +181,7 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." ;; Linux mount flags, from libc's . (define MS_RDONLY 1) (define MS_BIND 4096) +(define MS_MOVE 8192) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." @@ -271,6 +281,15 @@ run a file system check." (string->pointer options) %null-pointer)))))) +(define (switch-root root) + "Switch to ROOT as the root file system, in a way similar to what +util-linux' switch_root(8) does." + (move-essential-file-systems root) + (chdir root) + ;; TODO: Delete files from the old root. + (mount root "/" "" MS_MOVE) + (chroot ".")) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? @@ -351,8 +370,6 @@ to it are lost." #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) - (mount-essential-file-systems #:root "/root") - (unless (file-exists? "/root/dev") (mkdir "/root/dev") (make-essential-device-nodes #:root "/root")) @@ -377,8 +394,7 @@ to it are lost." (if to-load (begin (format #t "loading '~a'...\n" to-load) - (chdir "/root") - (chroot "/root") + (switch-root "/root") ;; Obviously this has to be done each time we boot. Do it from here ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) -- cgit v1.3 From 515eba4543f658799b1e11d187fa599d0a9a0dce Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 May 2014 09:00:00 +0200 Subject: gnu-maintenance: Add missing type check. * guix/gnu-maintenance.scm (gnu-package?): Only call 'mirror-type' when URL is a string. --- guix/gnu-maintenance.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index d8b6af9d3..7b608daea 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -176,7 +176,7 @@ network to check in GNU's database." (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) - (case (and url (mirror-type url)) + (case (and (string? url) (mirror-type url)) ((gnu) #t) ((non-gnu) #f) (else -- cgit v1.3 From 26a728eb091daf89a01986eac2d51dc8f0b58b6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 18:09:25 +0200 Subject: linux-initrd: Delete files from the initrd ramfs when switching roots. * guix/build/linux-initrd.scm (switch-root): Delete file from the old root. Chdir to / after 'chroot' call. Re-open file descriptors 0, 1, and 2. (boot-system): Move 'loading' message after the 'switch-root' call. * gnu/system.scm (operating-system-boot-script): Add loop that closes file descriptor before calling 'execl'. --- gnu/system.scm | 9 +++++++++ guix/build/linux-initrd.scm | 48 ++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 54 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/gnu/system.scm b/gnu/system.scm index 65d1ca341..8a5fe47b3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -334,6 +334,15 @@ we're running in the final root." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Close any remaining open file descriptors to be on the + ;; safe side. This must be the very last thing we do, + ;; because Guile has internal FDs such as 'sleep_pipe' + ;; that need to be alive. + (let loop ((fd 3)) + (when (< fd 1024) + (false-if-exception (close-fdes fd)) + (loop (+ 1 fd)))) + ;; Start dmd. (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b133550bc..c09cdeafb 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -286,9 +286,51 @@ run a file system check." util-linux' switch_root(8) does." (move-essential-file-systems root) (chdir root) - ;; TODO: Delete files from the old root. + + ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd. + ;; TODO: Use 'statfs' to check the fs type, like klibc does. + (when (or (not (file-exists? "/init")) (directory-exists? "/home")) + (format (current-error-port) + "The root file system is probably not an initrd; \ +bailing out.~%root contents: ~s~%" (scandir "/")) + (force-output (current-error-port)) + (exit 1)) + + ;; Delete files from the old root, without crossing mount points (assuming + ;; there are no mount points in sub-directories.) That means we're leaving + ;; the empty ROOT directory behind us, but that's OK. + (let ((root-device (stat:dev (stat "/")))) + (for-each (lambda (file) + (unless (member file '("." "..")) + (let* ((file (string-append "/" file)) + (device (stat:dev (lstat file)))) + (when (= device root-device) + (delete-file-recursively file))))) + (scandir "/"))) + + ;; Make ROOT the new root. (mount root "/" "" MS_MOVE) - (chroot ".")) + (chroot ".") + (chdir "/") + + (when (file-exists? "/dev/console") + ;; Close the standard file descriptors since they refer to the old + ;; /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; Reopen them. + (let ((in (open-file "/dev/console" "rbl")) + (out (open-file "/dev/console" "wbl"))) + (dup2 (fileno in) 0) + (dup2 (fileno out) 1) + (dup2 (fileno out) 2) + + ;; Safely close IN and OUT. + (for-each (lambda (port) + (if (memv (fileno port) '(0 1 2)) + (set-port-revealed! port 1) + (close-port port))) + (list in out))))) (define* (boot-system #:key (linux-modules '()) @@ -393,8 +435,8 @@ to it are lost." (if to-load (begin - (format #t "loading '~a'...\n" to-load) (switch-root "/root") + (format #t "loading '~a'...\n" to-load) ;; Obviously this has to be done each time we boot. Do it from here ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) -- cgit v1.3 From 538cc2e0165a32d3c5de9022f522f37880b60f5d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 May 2014 14:32:36 +0200 Subject: Remove now unneeded (guix build gnome) module. * guix/build/gnome.scm: Remove. * Makefile.am (MODULES): Update accordingly. --- Makefile.am | 1 - guix/build/gnome.scm | 31 ------------------------------- 2 files changed, 32 deletions(-) delete mode 100644 guix/build/gnome.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 22bbdca13..14e9e4a4b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -59,7 +59,6 @@ MODULES = \ guix/build/download.scm \ guix/build/cmake-build-system.scm \ guix/build/git.scm \ - guix/build/gnome.scm \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ guix/build/linux-initrd.scm \ diff --git a/guix/build/gnome.scm b/guix/build/gnome.scm deleted file mode 100644 index cac4de8f2..000000000 --- a/guix/build/gnome.scm +++ /dev/null @@ -1,31 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Cyril Roelandt -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix build gnome) - #:export (gir-directory)) - -;;; Commentary: -;;; -;;; Tools commonly used when building GNOME programs. -;;; -;;; Code: - -(define (gir-directory inputs pkg-name) - "Return the GIR directory name for PKG-NAME found from INPUTS." - (string-append (assoc-ref inputs pkg-name) - "/share/gir-1.0")) -- cgit v1.3 From b1995341ce803c396068a6e41f8cd64b09bbf2f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 00:22:26 +0200 Subject: linux-initrd: Update /etc/mtab. * guix/build/linux-initrd.scm (mount-root-file-system): Populate /root/etc/mtab. (mount-file-system): Update ROOT/etc/mtab. --- guix/build/linux-initrd.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index c09cdeafb..6dd7c6e95 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -228,7 +228,9 @@ UNIONFS." (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) - (start-repl)))) + (start-repl))) + + (copy-file "/proc/mounts" "/root/etc/mtab")) (define (check-file-system device type) "Run a file system check of TYPE on DEVICE." @@ -279,7 +281,14 @@ run a file system check." (mount source mount-point type (flags->bit-mask flags) (if options (string->pointer options) - %null-pointer)))))) + %null-pointer)) + + ;; Update /etc/mtab. + (mkdir-p (string-append root "/etc")) + (let ((port (open-output-file (string-append root "/etc/mtab")))) + (format port "~a ~a ~a ~a 0 0~%" + source mount-point type options) + (close-port port)))))) (define (switch-root root) "Switch to ROOT as the root file system, in a way similar to what -- cgit v1.3 From 03178aec1dc63c630374b1aed2178140c185b9f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 19:44:44 +0200 Subject: git-download: Disable TLS certificate verification. * guix/build/git.scm (git-fetch): Add 'setenv' call. --- guix/build/git.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index 4245594c3..68b132265 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -31,6 +31,11 @@ #:key (git-command "git")) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit identifier. Return #t on success, #f otherwise." + + ;; Disable TLS certificate verification. The hash of the checkout is known + ;; in advance anyway. + (setenv "GIT_SSL_NO_VERIFY" "true") + (and (zero? (system* git-command "clone" url directory)) (with-directory-excursion directory (system* git-command "tag" "-l") -- cgit v1.3 From 474b832d5e596c5f0713afbcdea5a19c6770cfac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 23:21:45 +0200 Subject: linux-initrd: Don't leak /dev/console file descriptors. * guix/build/linux-initrd.scm (switch-root): Simplify /dev/console code. This fixes a bug where we would leak the IN and OUT file descriptors. --- guix/build/linux-initrd.scm | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 6dd7c6e95..16c741f93 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -324,22 +324,15 @@ bailing out.~%root contents: ~s~%" (scandir "/")) (when (file-exists? "/dev/console") ;; Close the standard file descriptors since they refer to the old - ;; /dev/console. - (for-each close-fdes '(0 1 2)) - - ;; Reopen them. - (let ((in (open-file "/dev/console" "rbl")) - (out (open-file "/dev/console" "wbl"))) - (dup2 (fileno in) 0) - (dup2 (fileno out) 1) - (dup2 (fileno out) 2) - - ;; Safely close IN and OUT. - (for-each (lambda (port) - (if (memv (fileno port) '(0 1 2)) - (set-port-revealed! port 1) - (close-port port))) - (list in out))))) + ;; /dev/console, and reopen them. + (let ((console (open-file "/dev/console" "r+b0"))) + (for-each close-fdes '(0 1 2)) + + (dup2 (fileno console) 0) + (dup2 (fileno console) 1) + (dup2 (fileno console) 2) + + (close-port console)))) (define* (boot-system #:key (linux-modules '()) -- cgit v1.3 From 02139eb9b2bdbe1b342a0550dd8725a764716c28 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 21:47:05 +0200 Subject: linux-initrd: Append to /etc/mtab. * guix/build/linux-initrd.scm (mount-file-system): Open /etc/mtab in append mode. --- guix/build/linux-initrd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 16c741f93..83636dfd7 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -285,7 +285,7 @@ run a file system check." ;; Update /etc/mtab. (mkdir-p (string-append root "/etc")) - (let ((port (open-output-file (string-append root "/etc/mtab")))) + (let ((port (open-file (string-append root "/etc/mtab") "a"))) (format port "~a ~a ~a ~a 0 0~%" source mount-point type options) (close-port port)))))) -- cgit v1.3 From 29fa45f45d3192ad0f8d2c46523d7a7d6422c9e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 21:49:11 +0200 Subject: Add (guix build syscalls). * guix/build/syscalls.scm, tests/syscalls.scm: New files. * Makefile.am (MODULES): Add guix/build/syscalls.scm. (SCM_TESTS): Add tests/syscalls.scm. * guix/utils.scm (%libc-errno-pointer, errno): Remove; take from (guix build syscalls). --- Makefile.am | 4 +- guix/build/syscalls.scm | 156 ++++++++++++++++++++++++++++++++++++++++++++++++ guix/utils.scm | 33 +--------- tests/syscalls.scm | 47 +++++++++++++++ 4 files changed, 207 insertions(+), 33 deletions(-) create mode 100644 guix/build/syscalls.scm create mode 100644 tests/syscalls.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 14e9e4a4b..20bf650c9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/svn.scm \ guix/build/vm.scm \ guix/build/activation.scm \ + guix/build/syscalls.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ @@ -143,7 +144,8 @@ SCM_TESTS = \ tests/gexp.scm \ tests/nar.scm \ tests/union.scm \ - tests/profiles.scm + tests/profiles.scm \ + tests/syscalls.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm new file mode 100644 index 000000000..90cacc760 --- /dev/null +++ b/guix/build/syscalls.scm @@ -0,0 +1,156 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build syscalls) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:export (errno + MS_RDONLY + MS_REMOUNT + MS_BIND + MS_MOVE + mount + umount)) + +;;; Commentary: +;;; +;;; This module provides bindings to libc's syscall wrappers. It uses the +;;; FFI, and thus requires a dynamically-linked Guile. (For statically-linked +;;; Guile, we instead apply 'guile-linux-syscalls.patch'.) +;;; +;;; Code: + +(define %libc-errno-pointer + ;; Glibc's 'errno' pointer. + (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) + (and errno-loc + (let ((proc (pointer->procedure '* errno-loc '()))) + (proc))))) + +(define errno + (if %libc-errno-pointer + (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) + (lambda () + "Return the current errno." + ;; XXX: We assume that nothing changes 'errno' while we're doing all this. + ;; In particular, that means that no async must be running here. + + ;; Use one of the fixed-size native-ref procedures because they are + ;; optimized down to a single VM instruction, which reduces the risk + ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) + (let-syntax ((ref (lambda (s) + (syntax-case s () + ((_ bv) + (case (sizeof int) + ((4) + #'(bytevector-s32-native-ref bv 0)) + ((8) + #'(bytevector-s64-native-ref bv 0)) + (else + (error "unsupported 'int' size" + (sizeof int))))))))) + (ref bv)))) + (lambda () 0))) + +(define (augment-mtab source target type options) + "Augment /etc/mtab with information about the given mount point." + (let ((port (open-file "/etc/mtab" "a"))) + (format port "~a ~a ~a ~a 0 0~%" + source target type (or options "rw")) + (close-port port))) + +(define (read-mtab port) + "Read an mtab-formatted file from PORT, returning a list of tuples." + (let loop ((result '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse result) + (loop (cons (string-tokenize line) result)))))) + +(define (remove-from-mtab target) + "Remove mount point TARGET from /etc/mtab." + (define entries + (remove (match-lambda + ((device mount-point type options freq passno) + (string=? target mount-point)) + (_ #f)) + (call-with-input-file "/etc/fstab" read-mtab))) + + (call-with-output-file "/etc/fstab" + (lambda (port) + (for-each (match-lambda + ((device mount-point type options freq passno) + (format port "~a ~a ~a ~a ~a ~a~%" + device mount-point type options freq passno))) + entries)))) + +;; Linux mount flags, from libc's . +(define MS_RDONLY 1) +(define MS_REMOUNT 32) +(define MS_BIND 4096) +(define MS_MOVE 8192) + +(define mount + (let* ((ptr (dynamic-func "mount" (dynamic-link))) + (proc (pointer->procedure int ptr `(* * * ,unsigned-long *)))) + (lambda* (source target type #:optional (flags 0) options + #:key (update-mtab? #t)) + "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS +may be a bitwise-or of the MS_* constants, and OPTIONS may be a +string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When +UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on +error." + (let ((ret (proc (if source + (string->pointer source) + %null-pointer) + (string->pointer target) + (if type + (string->pointer type) + %null-pointer) + flags + (if options + (string->pointer options) + %null-pointer))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "mount" "mount ~S on ~S: ~A" + (list source target (strerror err)) + (list err))) + (when update-mtab? + (augment-mtab source target type options)))))) + +(define umount + (let* ((ptr (dynamic-func "umount2" (dynamic-link))) + (proc (pointer->procedure int ptr `(* ,int)))) + (lambda* (target #:optional (flags 0) + #:key (update-mtab? #t)) + "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* +constants from ." + (let ((ret (proc (string->pointer target) flags)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "umount" "~S: ~A" + (list target (strerror err)) + (list err))) + (when update-mtab? + (remove-from-mtab target)))))) + +;;; syscalls.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 53fc68d27..700a191d7 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -28,6 +28,7 @@ #:use-module (rnrs bytevectors) #:use-module ((rnrs io ports) #:select (put-bytevector)) #:use-module ((guix build utils) #:select (dump-port)) + #:use-module ((guix build syscalls) #:select (errno)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -366,38 +367,6 @@ that goes to PORT according to COMPRESSION, a symbol such as 'xz." ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu (else #(1 2 3))))) ; *-gnu* -(define %libc-errno-pointer - ;; Glibc's 'errno' pointer. - (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) - (and errno-loc - (let ((proc (pointer->procedure '* errno-loc '()))) - (proc))))) - -(define errno - (if %libc-errno-pointer - (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) - (lambda () - "Return the current errno." - ;; XXX: We assume that nothing changes 'errno' while we're doing all this. - ;; In particular, that means that no async must be running here. - - ;; Use one of the fixed-size native-ref procedures because they are - ;; optimized down to a single VM instruction, which reduces the risk - ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) - (let-syntax ((ref (lambda (s) - (syntax-case s () - ((_ bv) - (case (sizeof int) - ((4) - #'(bytevector-s32-native-ref bv 0)) - ((8) - #'(bytevector-s64-native-ref bv 0)) - (else - (error "unsupported 'int' size" - (sizeof int))))))))) - (ref bv)))) - (lambda () 0))) - (define fcntl-flock (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (proc (pointer->procedure int ptr `(,int ,int *)))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm new file mode 100644 index 000000000..5243ac9a3 --- /dev/null +++ b/tests/syscalls.scm @@ -0,0 +1,47 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-syscalls) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-64)) + +;; Test the (guix build syscalls) module, although there's not much that can +;; actually be tested without being root. + +(test-begin "syscalls") + +(test-equal "mount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (mount "/dev/null" "/does-not-exist" "ext2") + #f) + (compose system-error-errno list))) + +(test-equal "umount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (umount "/does-not-exist") + #f) + (compose system-error-errno list))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.3 From 023f391c7860d21aee9e9b3e601d7a81bb5d128d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 23:33:52 +0200 Subject: services: Add 'file-system-service'. * gnu/services/base.scm (file-system-service): New procedure. (user-processes-service): Add 'requirements' parameter. * gnu/services/dmd.scm (dmd-configuration-file): Use (guix build linux-initrd). * guix/build/linux-initrd.scm (guix): Export 'check-file-system'. * gnu/system.scm (file-union): New procedure. (essential-services): Use it. Add that to the returned list. --- gnu/services/base.scm | 30 ++++++++++++++++++++++++++++-- gnu/services/dmd.scm | 8 ++++++-- gnu/system.scm | 30 +++++++++++++++++++++++++----- guix/build/linux-initrd.scm | 1 + 4 files changed, 60 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index e0f2888ee..6431a3aab 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (root-file-system-service + file-system-service user-processes-service host-name-service mingetty-service @@ -87,19 +88,44 @@ This service must be the root of the service dependency graph so that its #f))))) (respawn? #f))))) -(define* (user-processes-service #:key (grace-delay 2)) +(define* (file-system-service device target type + #:key (check? #t) options) + "Return a service that mounts DEVICE on TARGET as a file system TYPE with +OPTIONS. When CHECK? is true, check the file system before mounting it." + (with-monad %store-monad + (return + (service + (provision (list (symbol-append 'file-system- (string->symbol target)))) + (requirement '(root-file-system)) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + #$(if check? + #~(check-file-system #$device #$type) + #~#t) + (mount #$device #$target #$type 0 #$options) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + (umount #$target) + #f)))))) + +(define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM has been sent are terminated with SIGKILL. +The returned service will depend on 'root-file-system' and on all the services +listed in REQUIREMENTS. + All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." (with-monad %store-monad (return (service (documentation "When stopped, terminate all user processes.") (provision '(user-processes)) - (requirement '(root-file-system)) + (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ ;; When this happens, all the processes have been diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 8d4c483cc..0d1728589 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -34,7 +34,9 @@ "Return the dmd configuration file for SERVICES." (define modules ;; Extra modules visible to dmd.conf. - '((guix build syscalls))) + '((guix build syscalls) + (guix build linux-initrd) + (guix build utils))) (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) @@ -46,7 +48,9 @@ (cons #$compiled %load-compiled-path))) (use-modules (ice-9 ftw) - (guix build syscalls)) + (guix build syscalls) + ((guix build linux-initrd) + #:select (check-file-system))) (register-services #$@(map (lambda (service) diff --git a/gnu/system.scm b/gnu/system.scm index 491e0ed7a..d76c3670f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -184,15 +184,35 @@ file." (gexp->derivation name builder)) +(define (other-file-system-services os) + "Return file system services for the file systems of OS that are not marked +as 'needed-for-boot'." + (define file-systems + (remove (lambda (fs) + (or (file-system-needed-for-boot? fs) + (string=? "/" (file-system-mount-point fs)))) + (operating-system-file-systems os))) + + (sequence %store-monad + (map (match-lambda + (($ device target type flags opts #f check?) + (file-system-service device target type + #:check? check? + #:options opts))) + file-systems))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet %store-monad ((procs (user-processes-service)) - (root-fs (root-file-system-service)) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (list host-name procs root-fs)))) + (mlet* %store-monad ((root-fs (root-file-system-service)) + (other-fs (other-file-system-services os)) + (procs (user-processes-service + (map (compose first service-provision) + other-fs))) + (host-name (host-name-service + (operating-system-host-name os)))) + (return (cons* host-name procs root-fs other-fs)))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 83636dfd7..0c3b2f0d9 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ linux-command-line make-essential-device-nodes configure-qemu-networking + check-file-system mount-file-system bind-mount load-linux-module* -- cgit v1.3 From ab6a279abbfa39b1e1bec0e363744d241972f844 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 22:41:01 +0200 Subject: system: Make accounts and groups at activation time. * gnu/services/base.scm (guix-build-accounts): Remove #:gid parameter; add #:group. Remove 'password' and 'gid' fields in 'user-account' form, and add 'group'. (guix-service): Remove #:build-user-gid parameter. Remove 'id' field in 'user-group' form. * gnu/system.scm (etc-directory): Remove #:groups and #:accounts. No longer produce files "passwd", "shadow", and "group". Adjust caller accordingly. (%root-account): New variable. (operating-system-accounts): Add 'users' variable. Add %ROOT-ACCOUNT only of 'operating-system-users' doesn't already contain a root account. (user-group->gexp, user-account->gexp): New procedures. (operating-system-boot-script): Add calls to 'setenv' and 'activate-users+groups' in gexp. * gnu/system/linux.scm (base-pam-services): Add PAM services for "user{add,del,mode}" and "group{add,del,mod}". * gnu/system/shadow.scm ()[gid]: Rename to... [group]: ... this. [supplementary-groups]: New field. [uid, password]: Default to #f. ()[id]: Default to #f. (group-file, passwd-file): Remove. * gnu/system/vm.scm (operating-system-default-contents)[user-directories]: Remove. Add "/home" to the directives. * guix/build/activation.scm (add-group, add-user, activate-users+groups): New procedures. --- build-aux/hydra/demo-os.scm | 3 +- gnu/services/base.scm | 10 ++--- gnu/system.scm | 95 +++++++++++++++++++++++++++++--------------- gnu/system/linux.scm | 14 ++++--- gnu/system/shadow.scm | 61 +++++----------------------- gnu/system/vm.scm | 15 +------ guix/build/activation.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 186 insertions(+), 109 deletions(-) (limited to 'guix') diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 03449abda..4116c063f 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -45,7 +45,8 @@ (locale "en_US.UTF-8") (users (list (user-account (name "guest") - (uid 1000) (gid 100) + (group "wheel") + (password "") (comment "Guest of GNU") (home-directory "/home/guest")))) (groups (list (user-group (name "root") (id 0)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 6431a3aab..1f5ff3e4c 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -237,8 +237,8 @@ stopped before 'kill' is called." (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key + (group "guixbuild") (first-uid 30001) - (gid 30000) (shadow shadow)) "Return a list of COUNT user accounts for Guix build users, with UIDs starting at FIRST-UID, and under GID." @@ -247,9 +247,8 @@ starting at FIRST-UID, and under GID." (lambda (n) (user-account (name (format #f "guixbuilder~2,'0d" n)) - (password "!") (uid (+ first-uid n -1)) - (gid gid) + (group group) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") (shell #~(string-append #$shadow "/sbin/nologin")))) @@ -257,11 +256,11 @@ starting at FIRST-UID, and under GID." 1)))) (define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) + (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (mlet %store-monad ((accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) + #:group builder-group))) (return (service (provision '(guix-daemon)) (requirement '(user-processes)) @@ -274,7 +273,6 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (user-accounts accounts) (user-groups (list (user-group (name builder-group) - (id build-user-gid) (members (map user-account-name user-accounts))))))))) diff --git a/gnu/system.scm b/gnu/system.scm index d76c3670f..bd69532a8 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -224,17 +224,12 @@ explicitly appear in OS." (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") - (accounts '()) - (groups '()) (pam-services '()) (profile "/var/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad - ((passwd (passwd-file accounts)) - (shadow (passwd-file accounts #:shadow? #t)) - (group (group-file groups)) - (pam.d (pam-services->directory pam-services)) + ((pam.d (pam-services->directory pam-services)) (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others @@ -278,10 +273,6 @@ alias ll='ls -l' ("profile" ,#~#$bashrc) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" #$timezone)) - ("passwd" ,#~#$passwd) - ("shadow" ,#~#$shadow) - ("group" ,#~#$group) - ("sudoers" ,#~#$sudoers))))) (define (operating-system-profile os) @@ -290,18 +281,28 @@ alias ll='ls -l' (union (operating-system-packages os) #:name "default-profile")) +(define %root-account + ;; Default root account. + (user-account + (name "root") + (password "") + (uid 0) (group "root") + (comment "System administrator") + (home-directory "/root"))) + (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." + (define users + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) + (mlet %store-monad ((services (operating-system-services os))) - (return (cons (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/root")) - (append (operating-system-users os) - (append-map service-user-accounts - services)))))) + (return (append users + (append-map service-user-accounts services))))) (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." @@ -312,12 +313,8 @@ alias ll='ls -l' (delete-duplicates (append (operating-system-pam-services os) (append-map service-pam-services services)))) - (accounts (operating-system-accounts os)) - (profile-drv (operating-system-profile os)) - (groups -> (append (operating-system-groups os) - (append-map service-user-groups services)))) - (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services + (profile-drv (operating-system-profile os))) + (etc-directory #:pam-services pam-services #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) #:sudoers (operating-system-sudoers os) @@ -339,6 +336,25 @@ alias ll='ls -l' "root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n") +(define (user-group->gexp group) + "Turn GROUP, a object, into a list-valued gexp suitable for +'active-groups'." + #~(list #$(user-group-name group) + #$(user-group-password group) + #$(user-group-id group))) + +(define (user-account->gexp account) + "Turn ACCOUNT, a object, into a list-valued gexp suitable for +'activate-users'." + #~`(#$(user-account-name account) + #$(user-account-uid account) + #$(user-account-group account) + #$(user-account-supplementary-groups account) + #$(user-account-comment account) + #$(user-account-home-directory account) + ,#$(user-account-shell account) ; this one is a gexp + #$(user-account-password account))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." @@ -346,15 +362,25 @@ we're running in the final root." '((guix build activation) (guix build utils))) - (mlet* %store-monad - ((services (operating-system-services os)) - (etc (operating-system-etc-directory os)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules)) - (dmd-conf (dmd-configuration-file services))) + (mlet* %store-monad ((services (operating-system-services os)) + (etc (operating-system-etc-directory os)) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) + (dmd-conf (dmd-configuration-file services)) + (accounts (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (append (operating-system-groups os) + (append-map service-user-groups services))) + + (define group-specs + (map user-group->gexp groups)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -368,6 +394,13 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Add users and user groups. + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) + "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)) + ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 3a43eb45e..5440f5852 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -154,11 +154,13 @@ should be the name of a file used as the message-of-the-day." (define* (base-pam-services #:key allow-empty-passwords?) "Return the list of basic PAM services everyone would want." - (list %pam-other-services - (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "passwd" - #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "sudo" - #:allow-empty-passwords? allow-empty-passwords?))) + (cons %pam-other-services + (map (cut unix-pam-service <> + #:allow-empty-passwords? allow-empty-passwords?) + '("su" "passwd" "sudo" + "useradd" "userdel" "usermod" + "groupadd" "groupdel" "groupmod" + ;; TODO: Add other Shadow programs? + )))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 52242ee4e..8745ddb87 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -30,9 +30,10 @@ #:export (user-account user-account? user-account-name - user-account-pass + user-account-password user-account-uid - user-account-gid + user-account-group + user-account-supplementary-groups user-account-comment user-account-home-directory user-account-shell @@ -42,11 +43,7 @@ user-group-name user-group-password user-group-id - user-group-members - - passwd-file - group-file - guix-build-accounts)) + user-group-members)) ;;; Commentary: ;;; @@ -58,9 +55,11 @@ user-account make-user-account user-account? (name user-account-name) - (password user-account-pass (default "")) - (uid user-account-uid) - (gid user-account-gid) + (password user-account-password (default #f)) + (uid user-account-uid (default #f)) + (group user-account-group) ; number | string + (supplementary-groups user-account-supplementary-groups + (default '())) ; list of strings (comment user-account-comment (default "")) (home-directory user-account-home-directory) (shell user-account-shell ; gexp @@ -71,47 +70,7 @@ user-group? (name user-group-name) (password user-group-password (default #f)) - (id user-group-id) + (id user-group-id (default #f)) (members user-group-members (default '()))) -(define (group-file groups) - "Return a /etc/group file for GROUPS, a list of objects." - (define contents - (let loop ((groups groups) - (result '())) - (match groups - ((($ name _ gid (users ...)) rest ...) - ;; XXX: Ignore the group password. - (loop rest - (cons (string-append name "::" (number->string gid) - ":" (string-join users ",")) - result))) - (() - (string-join (reverse result) "\n" 'suffix))))) - - (text-file "group" contents)) - -(define* (passwd-file accounts #:key shadow?) - "Return a password file for ACCOUNTS, a list of objects. If -SHADOW? is true, then it is a /etc/shadow file, otherwise it is a /etc/passwd -file." - ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! - (define account-exp - (match-lambda - (($ name pass uid gid comment home-dir shell) - (if shadow? ; XXX: use (crypt PASS …)? - #~(format #t "~a::::::::~%" #$name) - #~(format #t "~a:x:~a:~a:~a:~a:~a~%" - #$name #$(number->string uid) #$(number->string gid) - #$comment #$home-dir #$shell))))) - - (define builder - #~(begin - (with-output-to-file #$output - (lambda () - #$@(map account-exp accounts) - #t)))) - - (gexp->derivation (if shadow? "shadow" "passwd") builder)) - ;;; shadow.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 252085320..ede7ea772 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -267,16 +267,6 @@ such as /etc files." (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the basic contents of the root file system of OS." - (define (user-directories user) - (let ((home (user-account-home-directory user)) - ;; XXX: Deal with automatically allocated ids. - (uid (or (user-account-uid user) 0)) - (gid (or (user-account-gid user) 0)) - (root (string-append "/var/guix/profiles/per-user/" - (user-account-name user)))) - #~((directory #$root #$uid #$gid) - (directory #$home #$uid #$gid)))) - (mlet* %store-monad ((os-drv (operating-system-derivation os)) (build-gid (operating-system-build-gid os)) (profile (operating-system-profile os))) @@ -293,9 +283,8 @@ basic contents of the root file system of OS." (directory "/tmp") (directory "/var/guix/profiles/per-user/root" 0 0) - (directory "/root" 0 0) ; an exception - #$@(append-map user-directories - (operating-system-users os)))))) + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))))) (define* (system-qemu-image os #:key diff --git a/guix/build/activation.scm b/guix/build/activation.scm index f9d9ba5cb..895f2bca5 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,8 +19,11 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (activate-etc + #:export (activate-users+groups + activate-etc activate-setuid-programs)) ;;; Commentary: @@ -31,6 +34,98 @@ ;;; ;;; Code: +(define* (add-group name #:key gid password + (log-port (current-error-port))) + "Add NAME as a user group, with the given numeric GID if specified." + ;; Use 'groupadd' from the Shadow package. + (format log-port "adding group '~a'...~%" name) + (let ((args `(,@(if gid `("-g" ,(number->string gid)) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "groupadd" args)))) + +(define* (add-user name group + #:key uid comment home shell password + (supplementary-groups '()) + (log-port (current-error-port))) + "Create an account for user NAME part of GROUP, with the specified +properties. Return #t on success." + (format log-port "adding user '~a'...~%" name) + + (if (and uid (zero? uid)) + + ;; 'useradd' fails with "Cannot determine your user name" if the root + ;; account doesn't exist. Thus, for bootstrapping purposes, create that + ;; one manually. + (begin + (call-with-output-file "/etc/shadow" + (cut format <> "~a::::::::~%" name)) + (call-with-output-file "/etc/passwd" + (cut format <> "~a:x:~a:~a:~a:~a:~a~%" + name "0" "0" comment home shell)) + (chmod "/etc/shadow" #o600) + #t) + + ;; Use 'useradd' from the Shadow package. + (let ((args `(,@(if uid `("-u" ,(number->string uid)) '()) + "-g" ,(if (number? group) (number->string group) group) + ,@(if (pair? supplementary-groups) + `("-G" ,(string-join supplementary-groups ",")) + '()) + ,@(if comment `("-c" ,comment) '()) + ,@(if home `("-d" ,home "--create-home") '()) + ,@(if shell `("-s" ,shell) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "useradd" args))))) + +(define (activate-users+groups users groups) + "Make sure the accounts listed in USERS and the user groups listed in GROUPS +are all available. + +Each item in USERS is a list of all the characteristics of a user account; +each item in GROUPS is a tuple with the group name, group password or #f, and +numeric gid or #f." + (define (touch file) + (call-with-output-file file (const #t))) + + (define activate-user + (match-lambda + ((name uid group supplementary-groups comment home shell password) + (unless (false-if-exception (getpwnam name)) + (let ((profile-dir (string-append "/var/guix/profiles/per-user/" + name))) + (add-user name group + #:uid uid + #:supplementary-groups supplementary-groups + #:comment comment + #:home home + #:shell shell + #:password password) + + ;; Create the profile directory for the new account. + (let ((pw (getpwnam name))) + (mkdir-p profile-dir) + (chown profile-dir (passwd:uid pw) (passwd:gid pw)))))))) + + ;; 'groupadd' aborts if the file doesn't already exist. + (touch "/etc/group") + + ;; Create the root account so we can use 'useradd' and 'groupadd'. + (activate-user (find (match-lambda + ((name (? zero?) _ ...) #t) + (_ #f)) + users)) + + ;; Then create the groups. + (for-each (match-lambda + ((name password gid) + (add-group name #:gid gid #:password password))) + groups) + + ;; Finally create the other user accounts. + (for-each activate-user users)) + (define (activate-etc etc) "Install ETC, a directory in the store, as the source of static files for /etc." -- cgit v1.3 From 17a4d344899dca6a429fc79bc3b54edbe5079956 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:35:35 +0200 Subject: syscalls: Add 'processes' to list all the live processes. * guix/build/syscalls.scm (kernel?, processes): New procedures. --- guix/build/syscalls.scm | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 90cacc760..7a1bad733 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -22,13 +22,15 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:export (errno MS_RDONLY MS_REMOUNT MS_BIND MS_MOVE mount - umount)) + umount + processes)) ;;; Commentary: ;;; @@ -153,4 +155,29 @@ constants from ." (when update-mtab? (remove-from-mtab target)))))) +(define (kernel? pid) + "Return #t if PID designates a \"kernel thread\" rather than a normal +user-land process." + (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid) + (compose string-tokenize read-string)))) + ;; See proc.txt in Linux's documentation for the list of fields. + (match stat + ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt + cmin_flt maj_flt cmaj_flt utime stime cutime cstime + priority nice num_thread it_real_value start_time + vsize rss rsslim + (= string->number start_code) (= string->number end_code) _ ...) + ;; Got this obscure trick from sysvinit's 'killall5' program. + (and (zero? start_code) (zero? end_code)))))) + +(define (processes) + "Return the list of live processes." + (sort (filter-map (lambda (file) + (let ((pid (string->number file))) + (and pid + (not (kernel? pid)) + pid))) + (scandir "/proc")) + <)) + ;;; syscalls.scm ends here -- cgit v1.3 From 7d57cfd3b6625d7ab7f796b90b9606c28ec3aeef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:21 +0200 Subject: system: When unionfs-fuse is used for /, don't kill it when halting. * guix/build/linux-initrd.scm (pidof): New procedure. (mount-root-file-system)[mark-as-not-killable]: New procedure. Use it for unionfs when VOLATILE-ROOT?. * gnu/services/base.scm (%do-not-kill-file): New variable. (user-processes-service)[stop]: Honor it. --- gnu/services/base.scm | 42 +++++++++++++++++++++++++++++++++++++++--- guix/build/linux-initrd.scm | 26 +++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 1f5ff3e4c..aec605058 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -110,6 +110,11 @@ OPTIONS. When CHECK? is true, check the file system before mounting it." (umount #$target) #f)))))) +(define %do-not-kill-file + ;; Name of the file listing PIDs of processes that must survive when halting + ;; the system. Typical example is user-space file systems. + "/etc/dmd/do-not-kill") + (define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before @@ -128,6 +133,25 @@ stopped before 'kill' is called." (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those + ;; listed in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + ;; When this happens, all the processes have been ;; killed, including 'deco', so DMD-OUTPUT-PORT and ;; thus CURRENT-OUTPUT-PORT are dangling. @@ -136,9 +160,21 @@ stopped before 'kill' is called." (display "sending all processes the TERM signal\n" port))) - (kill -1 SIGTERM) - (sleep #$grace-delay) - (kill -1 SIGKILL) + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We + ;; would like to (kill -1 SIGSTOP) to get a fixed + ;; list of processes, like 'killall5' does, but + ;; that seems unreliable. + (kill-except omitted-pids SIGTERM) + (sleep #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) (display "all processes have been terminated\n") #f)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 0c3b2f0d9..b488668ee 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -200,11 +200,30 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." the last argument of `mknod'." (+ (* major 256) minor)) +(define (pidof program) + "Return the PID of the first presumed instance of PROGRAM." + (let ((program (basename program))) + (find (lambda (pid) + (let ((exe (format #f "/proc/~a/exe" pid))) + (and=> (false-if-exception (readlink exe)) + (compose (cut string=? program <>) basename)))) + (filter-map string->number (scandir "/proc"))))) + (define* (mount-root-file-system root type #:key volatile-root? (unionfs "unionfs")) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it a union with a writable tmpfs using UNIONFS." + (define (mark-as-not-killable pid) + ;; Tell the 'user-processes' dmd service that PID must be kept alive when + ;; shutting down. + (mkdir-p "/root/etc/dmd") + (let ((port (open-file "/root/etc/dmd/do-not-kill" "a"))) + (chmod port #o600) + (write pid port) + (newline port) + (close-port port))) + (catch #t (lambda () (if volatile-root? @@ -222,7 +241,12 @@ UNIONFS." "cow,allow_other,use_ino,suid,dev" "/rw-root=RW:/real-root=RO" "/root")) - (error "unionfs failed"))) + (error "unionfs failed")) + + ;; Make sure unionfs remains alive till the end. Because + ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we + ;; have to resort to 'pidof' here. + (mark-as-not-killable (pidof unionfs))) (begin (check-file-system root type) (mount root "/root" type)))) -- cgit v1.3 From 7f17ff78419b6088cbc8cec6e5f567a317fba809 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:47 +0200 Subject: linux-initrd: Make /dev/ttyS0, for debugging. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/ttyS0. --- guix/build/linux-initrd.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b488668ee..a89ff86bb 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -124,6 +124,10 @@ (device-number 4 n)) (loop (+ 1 n))))) + ;; Serial line. + (mknod (scope "dev/ttyS0") 'char-special #o660 + (device-number 4 64)) + ;; Pseudo ttys. (mknod (scope "dev/ptmx") 'char-special #o666 (device-number 5 2)) -- cgit v1.3 From f3b692acdd6da6c6a660f3d1b8de79e7f6ca25c7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 19:05:21 +0200 Subject: activation: Silence warning from 'useradd'. * guix/build/activation.scm (add-user): Don't pass '--create-home' when HOME already exists. --- guix/build/activation.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 895f2bca5..267c592b5 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -73,7 +73,11 @@ properties. Return #t on success." `("-G" ,(string-join supplementary-groups ",")) '()) ,@(if comment `("-c" ,comment) '()) - ,@(if home `("-d" ,home "--create-home") '()) + ,@(if home + (if (file-exists? home) + `("-d" ,home) ; avoid warning from 'useradd' + `("-d" ,home "--create-home")) + '()) ,@(if shell `("-s" ,shell) '()) ,@(if password `("-p" ,password) '()) ,name))) -- cgit v1.3 From 150e20ddde726abdfe77fa666351738cccb06281 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 22:55:14 +0200 Subject: vm: Support initialization of the store DB when the store is shared. * gnu/system/vm.scm (qemu-image): Rename #:inputs-to-copy to #:inputs, and #:initialize-store? to #:register-closures?. Add #:copy-inputs?. Adjust build gexp accordingly. (system-qemu-image): Remove #:initialize-store? argument and add #:copy-inputs?. (system-qemu-image/shared-store): Add #:inputs, #:register-closures?, and #:copy-inputs? arguments. * guix/build/vm.scm (register-closure): New procedure. (MS_BIND): New variable. (initialize-hard-disk): Rename #:initialize-store? to #:register-closures?, #:closures-to-copy to #:closures, and add #:copy-closures?. Add 'target-directory' and 'target-store' variables. Call 'populate-store' only when COPY-CLOSURES?. Bind-mount the store to TARGET-STORE when REGISTER-CLOSURES? and not COPY-CLOSURES?. Add call to 'register-closure'. --- gnu/system/vm.scm | 40 ++++++++++++++++++-------------- guix/build/vm.scm | 68 +++++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 72 insertions(+), 36 deletions(-) (limited to 'guix') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f42feb394..7008c5dab 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,25 +192,26 @@ made available under the /xchg CIFS share." (disk-image-size (* 100 (expt 2 20))) (file-system-type "ext4") grub-configuration - (initialize-store? #f) + (register-closures? #t) (populate #f) - (inputs-to-copy '())) + (inputs '()) + copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) -INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied -into the image being built. When INITIALIZE-STORE? is true, initialize the -store database in the image so that Guix can be used in the image. +INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy +all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, +register INPUTS in the store database of the image so that Guix can be used in +the image. POPULATE is a list of directives stating directories or symlinks to be created in the disk image partition. It is evaluated once the image has been populated with INPUTS-TO-COPY. It can be used to provide additional files, such as /etc files." (mlet %store-monad - ((graph (sequence %store-monad - (map input->name+output inputs-to-copy)))) + ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm name #~(begin @@ -221,26 +222,27 @@ such as /etc files." '#$(append (list qemu parted grub e2fsprogs util-linux) (map (compose car (cut assoc-ref %final-inputs <>)) '("sed" "grep" "coreutils" "findutils" "gawk")) - (if initialize-store? (list guix) '()))) + (if register-closures? (list guix) '()))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. - (to-copy + (to-register '#$(map (match-lambda ((name thing) thing) ((name thing output) `(,thing ,output))) - inputs-to-copy))) + inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (let ((graphs '#$(match inputs-to-copy + (let ((graphs '#$(match inputs (((names . _) ...) names)))) (initialize-hard-disk #:grub.cfg #$grub-configuration - #:closures-to-copy graphs + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size #:file-system-type #$file-system-type - #:initialize-store? #$initialize-store? #:directives '#$populate) (reboot)))) #:system system @@ -318,8 +320,8 @@ of the GNU system as described by OS." #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:initialize-store? #t - #:inputs-to-copy `(("system" ,os-drv)))))) + #:inputs `(("system" ,os-drv)) + #:copy-inputs? #t)))) (define (virtualized-operating-system os) "Return an operating system based on OS suitable for use in a virtualized @@ -358,10 +360,14 @@ with the host." (os-dir -> (derivation->output-path os-drv)) (grub.cfg -> (string-append os-dir "/grub.cfg")) (populate (operating-system-default-contents os))) - ;; TODO: Initialize the database so Guix can be used in the guest. (qemu-image #:grub-configuration grub.cfg #:populate populate - #:disk-image-size disk-image-size))) + #:disk-image-size disk-image-size + #:inputs `(("system" ,os-drv)) + + ;; XXX: Passing #t here is too slow, so let it off by default. + #:register-closures? #f + #:copy-inputs? #f))) (define* (system-qemu-image/shared-store-script os diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 1d1abad1d..2c13a8904 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -180,13 +180,36 @@ as created and modified at the Epoch." (utime file 0 0 0 0)))) (find-files directory ""))) +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +(define MS_BIND 4096) ; again! + (define* (initialize-hard-disk #:key grub.cfg disk-image-size (file-system-type "ext4") - initialize-store? - (closures-to-copy '()) + (closures '()) + copy-closures? + (register-closures? #t) (directives '())) + "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a +FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is +true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is +true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to +further populate the partition." + (define target-directory + "/fs") + + (define target-store + (string-append target-directory (%store-directory))) + (unless (initialize-partition-table "/dev/sda" #:partition-size (- disk-image-size (* 5 (expt 2 20)))) @@ -198,36 +221,43 @@ as created and modified at the Epoch." (error "failed to create partition")) (display "mounting partition...\n") - (mkdir "/fs") - (mount "/dev/sda1" "/fs" file-system-type) + (mkdir target-directory) + (mount "/dev/sda1" target-directory file-system-type) - (when (pair? closures-to-copy) + (when copy-closures? ;; Populate the store. - (populate-store (map (cut string-append "/xchg/" <>) - closures-to-copy) - "/fs")) + (populate-store (map (cut string-append "/xchg/" <>) closures) + target-directory)) ;; Populate /dev. - (make-essential-device-nodes #:root "/fs") + (make-essential-device-nodes #:root target-directory) ;; Optionally, register the inputs in the image's store. - (when initialize-store? + (when register-closures? + (unless copy-closures? + ;; XXX: 'guix-register' wants to palpate the things it registers, so + ;; bind-mount the store on the target. + (mkdir-p target-store) + (mount (%store-directory) target-store "" MS_BIND)) + + (display "registering closures...\n") (for-each (lambda (closure) - (let ((status (system* "guix-register" "--prefix" "/fs" - (string-append "/xchg/" closure)))) - (unless (zero? status) - (error "failed to register store items" closure)))) - closures-to-copy)) + (register-closure target-directory + (string-append "/xchg/" closure))) + closures) + (unless copy-closures? + (system* "umount" target-store))) ;; Evaluate the POPULATE directives. - (for-each (cut evaluate-populate-directive <> "/fs") + (display "populating...\n") + (for-each (cut evaluate-populate-directive <> target-directory) directives) - (unless (install-grub grub.cfg "/dev/sda" "/fs") + (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) - (reset-timestamps "/fs") + (reset-timestamps target-directory) - (zero? (system* "umount" "/fs"))) + (zero? (system* "umount" target-directory))) ;;; vm.scm ends here -- cgit v1.3 From 5ce3defed18c204989dceed64d3434ed9f3f1a92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 23:37:46 +0200 Subject: system: Add (guix build install) module. * guix/build/vm.scm (install-grub, evaluate-populate-directive, reset-timestamps, register-closure): Move to... * guix/build/install.scm: ... here. New file. * Makefile.am (MODULES): Add it. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add (guix build install) to #:modules. --- Makefile.am | 1 + gnu/system/vm.scm | 5 ++- guix/build/install.scm | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/build/vm.scm | 46 +--------------------------- 4 files changed, 86 insertions(+), 48 deletions(-) create mode 100644 guix/build/install.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 20bf650c9..a08215ef1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -70,6 +70,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/install.scm \ guix/build/activation.scm \ guix/build/syscalls.scm \ guix/packages.scm \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7008c5dab..58e5416b3 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -109,6 +109,7 @@ input tuple. The output file name is when building for SYSTEM." (env-vars '()) (modules '((guix build vm) + (guix build install) (guix build linux-initrd) (guix build utils))) (guile-for-build @@ -179,9 +180,7 @@ made available under the /xchg CIFS share." ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars - #:modules `((guix build utils) - (guix build vm) - (guix build linux-initrd)) + #:modules modules #:guile-for-build guile-for-build #:references-graphs references-graphs))) diff --git a/guix/build/install.scm b/guix/build/install.scm new file mode 100644 index 000000000..37153703e --- /dev/null +++ b/guix/build/install.scm @@ -0,0 +1,82 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build install) + #:use-module (guix build utils) + #:use-module (guix build install) + #:use-module (ice-9 match) + #:export (install-grub + evaluate-populate-directive + reset-timestamps + register-closure)) + +;;; Commentary: +;;; +;;; This module supports the installation of the GNU system on a hard disk. +;;; It is meant to be used both in a build environment (in derivations that +;;; build VM images), and on the bare metal (when really installing the +;;; system.) +;;; +;;; Code: + +(define* (install-grub grub.cfg device mount-point) + "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on +MOUNT-POINT. Return #t on success." + (mkdir-p (string-append mount-point "/boot/grub")) + (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) + (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" (string-append mount-point "/boot") + device))) + +(define (evaluate-populate-directive directive target) + "Evaluate DIRECTIVE, an sexp describing a file or directory to create under +directory TARGET." + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + ((new '-> old) + (symlink old (string-append target new))))) + +(define (reset-timestamps directory) + "Reset the timestamps of all the files under DIRECTORY, so that they appear +as created and modified at the Epoch." + (display "clearing file timestamps...\n") + (for-each (lambda (file) + (let ((s (lstat file))) + ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so + ;; the timestamp of symlinks cannot be changed, and there are + ;; symlinks here pointing to /gnu/store, which is the host, + ;; read-only store. + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files directory ""))) + +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +;;; install.scm ends here diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2c13a8904..12f952bd1 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -19,6 +19,7 @@ (define-module (guix build vm) #:use-module (guix build utils) #:use-module (guix build linux-initrd) + #:use-module (guix build install) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) @@ -124,15 +125,6 @@ partition of PARTITION-SIZE MiB. Return #t on success." "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) -(define* (install-grub grub.cfg device mount-point) - "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) - (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." @@ -153,42 +145,6 @@ REFERENCE-GRAPHS, a list of reference-graph files." (string-append target thing))) (things-to-copy))) -(define (evaluate-populate-directive directive target) - "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) - -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (display "clearing file timestamps...\n") - (for-each (lambda (file) - (let ((s (lstat file))) - ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so - ;; the timestamp of symlinks cannot be changed, and there are - ;; symlinks here pointing to /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory ""))) - -(define (register-closure store closure) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'." - (let ((status (system* "guix-register" "--prefix" store - closure))) - (unless (zero? status) - (error "failed to register store items" closure)))) - (define MS_BIND 4096) ; again! (define* (initialize-hard-disk #:key -- cgit v1.3 From 4cca91832b3fceed35eb46439fac7c12466d229d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 10:22:19 +0200 Subject: authenticate: Add compatibility hack for Guile 2.0.5. * guix/scripts/authenticate.scm (%default-port-conversion-strategy): New variable. Reported by Andreas Enge . --- guix/scripts/authenticate.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 1b1e0b08c..e9900689f 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 -- cgit v1.3 From 7889394e059a2362d3227fb02256de4afd46129c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 21:56:00 +0200 Subject: guix system: Add 'build' action. * guix/scripts/system.scm (show-help): Document 'build' action. (guix-system): Honor 'build' action. * doc/guix.texi (Invoking guix system): Add 'build' action. --- doc/guix.texi | 5 +++++ guix/scripts/system.scm | 19 +++++++++++++------ 2 files changed, 18 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 770e7ab06..4881ec6e1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3204,6 +3204,11 @@ operating system is instantiate. Currently the following values are supported: @table @code +@item build +Build the operating system's derivation, which includes all the +configuration files and programs needed to boot and run the system. +This action does not actually install anything. + @item vm @cindex virtual machine Build a virtual machine that contain the operating system declared in diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 582027244..0739534b5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -24,6 +24,7 @@ #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix scripts build) + #:use-module (gnu system) #:use-module (gnu system vm) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -71,9 +72,15 @@ (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")) + (show-build-options-help) (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) @@ -131,9 +138,7 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (alist-cons 'argument arg result))) (let ((action (string->symbol arg))) (case action - ((vm) - (alist-cons 'action action result)) - ((vm-image) + ((build vm vm-image) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -147,6 +152,8 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (read-operating-system file) (leave (_ "no configuration file specified~%")))) (mdrv (case action + ((build) + (operating-system-derivation os)) ((vm-image) (let ((size (assoc-ref opts 'image-size))) (system-qemu-image os -- cgit v1.3 From 87a52da7d0da82bd8df9c86dcac7029c375b50c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 23:31:48 +0200 Subject: linux-initrd: Factorize kernel command-line option parsing. * guix/build/linux-initrd.scm (find-long-option): New procedure. (boot-system): Use it instead of the local 'option'. --- guix/build/linux-initrd.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index a89ff86bb..9093e7269 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -28,6 +28,7 @@ #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line + find-long-option make-essential-device-nodes configure-qemu-networking check-file-system @@ -78,6 +79,15 @@ (call-with-input-file "/proc/cmdline" get-string-all))) +(define (find-long-option option arguments) + "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\". +Return the value associated with OPTION, or #f on failure." + (let ((opt (string-append option "="))) + (and=> (find (cut string-prefix? opt <>) + arguments) + (lambda (arg) + (substring arg (+ 1 (string-index arg #\=))))))) + (define* (make-essential-device-nodes #:key (root "/")) "Make essential device nodes under ROOT/dev." ;; The hand-made udev! @@ -411,14 +421,8 @@ to it are lost." (mount-essential-file-systems) (let* ((args (linux-command-line)) - (option (lambda (opt) - (let ((opt (string-append opt "="))) - (and=> (find (cut string-prefix? opt <>) - args) - (lambda (arg) - (substring arg (+ 1 (string-index arg #\=)))))))) - (to-load (option "--load")) - (root (option "--root"))) + (to-load (find-long-option "--load" args)) + (root (find-long-option "--root" args))) (when (member "--repl" args) (start-repl)) -- cgit v1.3 From e901ef297d9afe9a159dcf2bbd9779c9fbf822be Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 00:08:39 +0200 Subject: store: Add #:store parameter to 'register-path'. * guix/store.scm (register-path): Add #:store and honor it. --- guix/store.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 2b924db21..1731c14f2 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -797,17 +797,21 @@ signing them if SIGN? is true." (loop tail))))))) (define* (register-path path - #:key (references '()) deriver) + #:key (references '()) deriver store) "Register PATH as a valid store file, with REFERENCES as its list of -references, and DERIVER as its deriver (.drv that led to it.) Return #t on -success. +references, and DERIVER as its deriver (.drv that led to it.) If STORE is not +#f, it must be a string denoting the directory name of the new store to +initialize. Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook." ;; Currently this is implemented by calling out to the fine C++ blob. (catch 'system-error (lambda () - (let ((pipe (open-pipe* OPEN_WRITE %guix-register-program))) + (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program + (if store + `("--prefix" ,store) + '())))) (and pipe (begin (format pipe "~a~%~a~%~a~%" -- cgit v1.3 From b4140694aca6a717ec130e3788b9d877d1b1e534 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 17:39:30 +0200 Subject: system: Make /run/current-system at activation time. * gnu/system.scm (etc-directory): Change default value of #:profile. Change contents of SHELLS. Use /run/current-system/profile/{s,}bin in BASHRC. (operating-system-boot-script)[%modules]: Add (guix build linux-initrd). Add call to 'activate-current-system' in gexp. (operating-system-initrd-file, operating-system-grub.cfg): New procedures. (operating-system-derivation): Don't build grub.cfg here and remove it from the file union. * gnu/system/vm.scm (qemu-image): Remove #:populate. (operating-system-build-gid, operating-system-default-contents): Remove. (system-qemu-image): Remove call to 'operating-system-default-contents'. Use 'operating-system-grub.cfg' to get grub.cfg. Add GRUB.CFG to #:inputs. (system-qemu-image/shared-store): Likewise, but don't add GRUB.CFG to #:inputs. (system-qemu-image/shared-store-script): Pass --system kernel option. * guix/build/activation.scm (%booted-system, %current-system): New variables. (boot-time-system, activate-current-system): New procedures. * guix/build/install.scm (evaluate-populate-directive): Add case for ('directory name uid gid mode). (directives, populate-root-file-system): New procedures. * guix/build/vm.scm (initialize-hard-disk): Replace calls to 'evaluate-populate-directive' by a call to 'populate-root-file-system'. * gnu/services/dmd.scm (dmd-configuration-file): Use /run/current-system/profile/bin. * gnu/services/xorg.scm (slim-service): Likewise. --- gnu/services/dmd.scm | 2 +- gnu/services/xorg.scm | 2 +- gnu/system.scm | 56 ++++++++++++++++++++++++++++---------------- gnu/system/vm.scm | 59 ++++++----------------------------------------- guix/build/activation.scm | 33 +++++++++++++++++++++++++- guix/build/install.scm | 50 +++++++++++++++++++++++++++++++-------- guix/build/vm.scm | 3 +-- 7 files changed, 118 insertions(+), 87 deletions(-) (limited to 'guix') diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 0d1728589..982c196fe 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -64,7 +64,7 @@ services)) ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + (setenv "PATH" "/run/current-system/profile/bin") (format #t "starting services...~%") (for-each start '#$(append-map service-provision services)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 1988cfa6a..7215297f6 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -139,7 +139,7 @@ When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." (mlet %store-monad ((startx (or startx (xorg-start-command))) (xinitrc (xinitrc))) (text-file* "slim.cfg" " -default_path /run/current-system/bin +default_path /run/current-system/profile/bin default_xserver " startx " xserver_arguments :0 vt7 xauth_path " xauth "/bin/xauth diff --git a/gnu/system.scm b/gnu/system.scm index 9ce94d023..ec3e2fcd6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -55,6 +55,7 @@ operating-system-derivation operating-system-profile + operating-system-grub.cfg file-system @@ -263,7 +264,7 @@ explicitly appear in OS." (locale "C") (timezone "Europe/Paris") (skeletons '()) (pam-services '()) - (profile "/var/run/current-system/profile") + (profile "/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad @@ -273,8 +274,8 @@ explicitly appear in OS." (shells (text-file "shells" ; used by xterm and others "\ /bin/sh -/run/current-system/bin/sh -/run/current-system/bin/bash\n")) +/run/current-system/profile/bin/sh +/run/current-system/profile/bin/bash\n")) (issue (text-file "issue" " This is an alpha preview of the GNU system. Welcome. @@ -293,8 +294,8 @@ export LC_ALL=\"" locale "\" export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin -export PATH=/run/setuid-programs:$PATH +export PATH=/run/setuid-programs:/run/current-system/profile/sbin +export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -402,7 +403,8 @@ alias ll='ls -l' we're running in the final root." (define %modules '((guix build activation) - (guix build utils))) + (guix build utils) + (guix build linux-initrd))) (mlet* %store-monad ((services (operating-system-services os)) (etc (operating-system-etc-directory os)) @@ -446,6 +448,9 @@ we're running in the final root." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Set up /run/current-system. + (activate-current-system #:boot? #t) + ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, ;; because Guile has internal FDs such as 'sleep_pipe' @@ -466,8 +471,8 @@ we're running in the final root." (_ #f)) (operating-system-file-systems os))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." +(define (operating-system-initrd-file os) + "Return a gexp denoting the initrd file of OS." (define boot-file-systems (filter (match-lambda (($ device "/") @@ -476,15 +481,16 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) + (mlet %store-monad + ((initrd ((operating-system-initrd os) boot-file-systems))) + (return #~(string-append #$initrd "/initrd")))) + +(define (operating-system-grub.cfg os) + "Return the GRUB configuration file for OS." (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory os)) - (services (operating-system-services os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd ((operating-system-initrd os) boot-file-systems)) - (initrd-file -> #~(string-append #$initrd "/initrd")) + ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) + (kernel -> (operating-system-kernel os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -494,15 +500,25 @@ we're running in the final root." (linux-arguments (list (string-append "--root=" (file-system-device root-fs)) - #~(string-append "--load=" #$boot))) - (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries))) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot"))) + (initrd #~(string-append #$system "/initrd")))))) + (grub-configuration-file entries))) + +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) + (boot (operating-system-boot-script os)) + (kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os))) (file-union "system" `(("boot" ,#~#$boot) ("kernel" ,#~#$kernel) - ("initrd" ,initrd-file) + ("initrd" ,initrd) ("profile" ,#~#$profile) - ("grub.cfg" ,#~#$grub.cfg) ("etc" ,#~#$etc))))) ;;; system.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 58e5416b3..4bf0e0608 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,7 +192,6 @@ made available under the /xchg CIFS share." (file-system-type "ext4") grub-configuration (register-closures? #t) - (populate #f) (inputs '()) copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type @@ -203,12 +202,7 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in -the image. - -POPULATE is a list of directives stating directories or symlinks to be created -in the disk image partition. It is evaluated once the image has been -populated with INPUTS-TO-COPY. It can be used to provide additional files, -such as /etc files." +the image." (mlet %store-monad ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm @@ -241,8 +235,7 @@ such as /etc files." #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size - #:file-system-type #$file-system-type - #:directives '#$populate) + #:file-system-type #$file-system-type) (reboot)))) #:system system #:make-disk-image? #t @@ -254,39 +247,6 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define (operating-system-build-gid os) - "Return as a monadic value the group id for build users of OS, or #f." - (mlet %store-monad ((services (operating-system-services os))) - (return (any (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - services)))) - -(define (operating-system-default-contents os) - "Return a list of directives suitable for 'system-qemu-image' describing the -basic contents of the root file system of OS." - (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (build-gid (operating-system-build-gid os)) - (profile (operating-system-profile os))) - (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0)) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/guix/gcroots") - ("/var/guix/gcroots/system" -> #$os-drv) - (directory "/run") - ("/run/current-system" -> #$profile) - (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/bash") - (directory "/tmp") - (directory "/var/guix/profiles/per-user/root" 0 0) - - (directory "/root" 0 0) ; an exception - (directory "/home" 0 0))))) - (define* (system-qemu-image os #:key (file-system-type "ext4") @@ -312,14 +272,12 @@ of the GNU system as described by OS." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:inputs `(("system" ,os-drv)) + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)) #:copy-inputs? #t)))) (define (virtualized-operating-system os) @@ -356,11 +314,8 @@ environment with the store shared with the host." with the host." (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:inputs `(("system" ,os-drv)) @@ -390,7 +345,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -kernel " #$(operating-system-kernel os) "/bzImage \ -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") - "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" \ -serial stdio \ -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 267c592b5..49f98c021 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -18,13 +18,15 @@ (define-module (guix build activation) #:use-module (guix build utils) + #:use-module (guix build linux-initrd) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (activate-users+groups activate-etc - activate-setuid-programs)) + activate-setuid-programs + activate-current-system)) ;;; Commentary: ;;; @@ -195,4 +197,33 @@ numeric gid or #f." (for-each make-setuid-program programs)) +(define %booted-system + ;; The system we booted in (a symlink.) + "/run/booted-system") + +(define %current-system + ;; The system that is current (a symlink.) This is not necessarily the same + ;; as %BOOTED-SYSTEM, for instance because we can re-build a new system + ;; configuration and activate it, without rebooting. + "/run/current-system") + +(define (boot-time-system) + "Return the '--system' argument passed on the kernel command line." + (find-long-option "--system" (linux-command-line))) + +(define* (activate-current-system #:optional (system (boot-time-system)) + #:key boot?) + "Atomically make SYSTEM the current system. When BOOT? is true, also make +it the booted system." + (format #t "making '~a' the current system...~%" system) + (when boot? + (when (file-exists? %booted-system) + (delete-file %booted-system)) + (symlink system %booted-system)) + + ;; Atomically make SYSTEM current. + (let ((new (string-append %current-system ".new"))) + (symlink system new) + (rename-file new %current-system))) + ;;; activation.scm ends here diff --git a/guix/build/install.scm b/guix/build/install.scm index 37153703e..a0be6e9d3 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -19,9 +19,10 @@ (define-module (guix build install) #:use-module (guix build utils) #:use-module (guix build install) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub - evaluate-populate-directive + populate-root-file-system reset-timestamps register-closure)) @@ -46,15 +47,44 @@ MOUNT-POINT. Return #t on success." (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) + (let loop ((directive directive)) + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + (('directory name uid gid mode) + (loop `(directory ,name ,uid ,gid)) + (chmod (string-append target name) mode)) + ((new '-> old) + (symlink old (string-append target new)))))) + +(define (directives store) + "Return a list of directives to populate the root file system that will host +STORE." + `((directory ,store 0 0) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/guix/gcroots") + (directory "/run") + ("/var/guix/gcroots/booted-system" -> "/run/booted-system") + ("/var/guix/gcroots/current-system" -> "/run/current-system") + (directory "/bin") + ("/bin/sh" -> "/run/current-system/profile/bin/bash") + (directory "/tmp" 0 0 #o1777) ; sticky bit + (directory "/var/guix/profiles/per-user/root" 0 0) + + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))) + +(define (populate-root-file-system target) + "Make the essential non-store files and directories on TARGET. This +includes /etc, /var, /run, /bin/sh, etc." + (for-each (cut evaluate-populate-directive <> target) + (directives (%store-directory)))) (define (reset-timestamps directory) "Reset the timestamps of all the files under DIRECTORY, so that they appear diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 12f952bd1..b9bb66cdb 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -206,8 +206,7 @@ further populate the partition." ;; Evaluate the POPULATE directives. (display "populating...\n") - (for-each (cut evaluate-populate-directive <> target-directory) - directives) + (populate-root-file-system target-directory) (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) -- cgit v1.3 From 15d299874c635d14a84710005d0ed4b05968ff6f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 19:11:53 +0200 Subject: vm: Avoid resetting timestamps twice. * guix/build/vm.scm (initialize-hard-disk): Don't call 'reset-timestamps' when REGISTER-CLOSURES? is true. * guix/build/install.scm (register-closure): Mention timestamps in docstring. --- guix/build/install.scm | 2 +- guix/build/vm.scm | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/install.scm b/guix/build/install.scm index a0be6e9d3..564735a7f 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -103,7 +103,7 @@ as created and modified at the Epoch." (define (register-closure store closure) "Register CLOSURE in STORE, where STORE is the directory name of the target store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'." +by 'guix-register'. As a side effect, this resets timestamps on store files." (let ((status (system* "guix-register" "--prefix" store closure))) (unless (zero? status) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index b9bb66cdb..e67b431b5 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -211,7 +211,10 @@ further populate the partition." (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) - (reset-timestamps target-directory) + ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; once more in that case. + (unless register-closures? + (reset-timestamps target-directory)) (zero? (system* "umount" target-directory))) -- cgit v1.3 From bb31e0a3ee2ba23fa7a57471b0aa2363404f4c27 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 19:12:43 +0200 Subject: store: Change #:store parameter to #:prefix. * guix/store.scm (register-path): Change #:store to #:prefix. --- guix/store.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 1731c14f2..073e024e3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -797,10 +797,10 @@ signing them if SIGN? is true." (loop tail))))))) (define* (register-path path - #:key (references '()) deriver store) + #:key (references '()) deriver prefix) "Register PATH as a valid store file, with REFERENCES as its list of -references, and DERIVER as its deriver (.drv that led to it.) If STORE is not -#f, it must be a string denoting the directory name of the new store to +references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is +not #f, it must be the name of the directory containing the new store to initialize. Return #t on success. Use with care as it directly modifies the store! This is primarily meant to @@ -809,8 +809,8 @@ be used internally by the daemon's build hook." (catch 'system-error (lambda () (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program - (if store - `("--prefix" ,store) + (if prefix + `("--prefix" ,prefix) '())))) (and pipe (begin -- cgit v1.3 From 72b9d60df4723541e1a65f7a3d14abb757fbed97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 21:32:57 +0200 Subject: guix system: Add 'init' sub-command. * guix/scripts/system.scm (install): New procedure. (guix-system)[parse-option]: Remove check for extraneous arguments. [match-pair, option-arguments]: New procedures. Use 'option-arguments'. Honor 'init'. (show-help): Document 'init'. * doc/guix.texi (Invoking guix system): Document 'init'. --- doc/guix.texi | 15 +++++++++ guix/scripts/system.scm | 87 ++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 93 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4881ec6e1..4c32df3c9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3209,6 +3209,21 @@ Build the operating system's derivation, which includes all the configuration files and programs needed to boot and run the system. This action does not actually install anything. +@item init +Populate the given directory with all the files necessary to run the +operating system specified in @var{file}. This is useful for first-time +installations of the GNU system. For instance: + +@example +guix system init my-os-config.scm /mnt +@end example + +copies to @file{/mnt} all the store items required by the configuration +specified in @file{my-os-config.scm}. This includes configuration +files, packages, and so on. It also creates other essential files +needed for the system to operate correctly---e.g., the @file{/etc}, +@file{/var}, and @file{/run} directories, and the @file{/bin/sh} file. + @item vm @cindex virtual machine Build a virtual machine that contain the operating system declared in diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 0739534b5..ee5df6e95 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -19,14 +19,18 @@ (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 (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-system @@ -64,6 +68,38 @@ (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) +(define* (install store os-dir target + #:key (log-port (current-output-port))) + "Copy OS-DIR and its dependencies to directory TARGET. TARGET must be an +absolute directory name since that's what 'guix-register' expects." + (define to-copy + (let ((lst (delete-duplicates (cons os-dir (references store os-dir)) + string=?))) + (topologically-sorted store lst))) + + ;; Copy items to the new store. + (for-each (lambda (item) + (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)))) + to-copy) + + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate-root-file-system target) + + ;; TODO: Install GRUB. + ) + ;;; ;;; Options. @@ -79,7 +115,9 @@ Build the operating system declared in FILE according to ACTION.\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")) + - 'vm-image', build a freestanding virtual machine image\n")) + (display (_ "\ + - 'init', initialize a root file system to run GNU.\n")) (show-build-options-help) (display (_ " @@ -132,27 +170,50 @@ Build the operating system declared in FILE according to ACTION.\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 - ((build vm vm-image) + ((build vm vm-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) + (unless (= count 1) + (fail))) + ((init) + (unless (= count 2) + (fail)))) + args)) + (with-error-handling (let* ((opts (parse-options)) - (file (assoc-ref opts 'argument)) + (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) + ((build init) (operating-system-derivation os)) ((vm-image) (let ((size (assoc-ref opts 'image-size))) @@ -171,4 +232,12 @@ Build the operating system declared in FILE according to ACTION.\n")) (unless dry? (build-derivations store (list drv)) (display (derivation->output-path drv)) - (newline))))) + (newline) + + (when (eq? action 'init) + (let ((target (second args))) + (format #t (_ "initializing operating system under '~a'...~%") + target) + + (install store (derivation->output-path drv) + (canonicalize-path target)))))))) -- cgit v1.3 From 6ffd11f129405c7bd663201096d8fcfcde6344a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 22:06:38 +0200 Subject: system: Prevent grub.cfg from being GC'd. * guix/build/install.scm (install-grub): Use 'copy-file' instead of 'symlink' for GRUB.CFG. --- guix/build/install.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/install.scm b/guix/build/install.scm index 564735a7f..f61c16f13 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -38,11 +38,18 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) + (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) + (pivot (string-append target ".new"))) + (mkdir-p (dirname target)) + + ;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root. + ;; Do that atomically. + (copy-file grub.cfg pivot) + (rename-file pivot target) + + (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" (string-append mount-point "/boot") + device)))) (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -- cgit v1.3 From c711f07c3e1f512fbd6d61ab5acc62064ad46697 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sun, 18 May 2014 23:49:07 -0500 Subject: guix: licenses: Add CeCILL-C license. * guix/licenses.scm (cecill-c): New variable. --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index fce3d2b89..c3464b5f5 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -26,6 +26,7 @@ boost1.0 bsd-2 bsd-3 bsd-4 bsd-style cddl1.0 + cecill-c cpl1.0 epl1.0 expat @@ -112,6 +113,11 @@ which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CDDLv1.0" "https://www.gnu.org/licenses/license-list#CDDL")) +(define cecill-c + (license "CeCILL-C" + "http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html" + "https://www.gnu.org/licenses/license-list.html#CeCILL")) + (define cpl1.0 (license "CPL 1.0" "http://directory.fsf.org/wiki/License:CPLv1.0" -- cgit v1.3 From e38e18ff010e53a788cec30f25ee3d59341b0708 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:00:46 +0200 Subject: vm: Make the device name a parameter. * guix/build/vm.scm (initialize-partition-table): Honor 'device' parameter. (initialize-hard-disk): Add 'device' parameter and honor it. * gnu/system/vm.scm (qemu-image): Adjust accordingly. --- gnu/system/vm.scm | 3 ++- guix/build/vm.scm | 18 +++++++++++------- 2 files changed, 13 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4bf0e0608..ee9ac81ce 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -230,7 +230,8 @@ the image." (let ((graphs '#$(match inputs (((names . _) ...) names)))) - (initialize-hard-disk #:grub.cfg #$grub-configuration + (initialize-hard-disk "/dev/sda" + #:grub.cfg #$grub-configuration #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e67b431b5..cf661a33f 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -121,7 +121,7 @@ The data at PORT is the format produced by #:references-graphs." "Create on DEVICE a partition table of type LABEL-TYPE, with a single partition of PARTITION-SIZE MiB. Return #t on success." (display "creating partition table...\n") - (zero? (system* "parted" "/dev/sda" "mklabel" label-type + (zero? (system* "parted" device "mklabel" label-type "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) @@ -147,7 +147,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define MS_BIND 4096) ; again! -(define* (initialize-hard-disk #:key +(define* (initialize-hard-disk device + #:key grub.cfg disk-image-size (file-system-type "ext4") @@ -155,7 +156,7 @@ REFERENCE-GRAPHS, a list of reference-graph files." copy-closures? (register-closures? #t) (directives '())) - "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to @@ -166,19 +167,22 @@ further populate the partition." (define target-store (string-append target-directory (%store-directory))) - (unless (initialize-partition-table "/dev/sda" + (define partition + (string-append device 1)) + + (unless (initialize-partition-table device #:partition-size (- disk-image-size (* 5 (expt 2 20)))) (error "failed to create partition table")) (format #t "creating ~a partition...\n" file-system-type) (unless (zero? (system* (string-append "mkfs." file-system-type) - "-F" "/dev/sda1")) + "-F" partition)) (error "failed to create partition")) (display "mounting partition...\n") (mkdir target-directory) - (mount "/dev/sda1" target-directory file-system-type) + (mount partition target-directory file-system-type) (when copy-closures? ;; Populate the store. @@ -208,7 +212,7 @@ further populate the partition." (display "populating...\n") (populate-root-file-system target-directory) - (unless (install-grub grub.cfg "/dev/sda" target-directory) + (unless (install-grub grub.cfg device target-directory) (error "failed to install GRUB")) ;; 'guix-register' resets timestamps and everything, so no need to do it -- cgit v1.3 From c79d54fe41b0a85c76b11ab2643895de2823d477 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:36:15 +0200 Subject: guix system: 'guix system init' installs GRUB by default. * guix/scripts/system.scm (install): Add #:grub?, #:grub.cfg, and #:device parameters; honor them. (show-help): Document '--no-grub'. (%options): Add '--no-grub'. (%default-options): Add 'install-grub?'. (guix-system): Honor 'install-grub?' option from OPTS. Adjust 'install' call accordingly. * doc/guix.texi (Invoking guix system): Document '--no-grub'. --- doc/guix.texi | 3 ++ guix/scripts/system.scm | 86 +++++++++++++++++++++++++++++++++---------------- 2 files changed, 61 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4c32df3c9..917be1fc4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3224,6 +3224,9 @@ files, packages, and so on. It also creates other essential files needed for the system to operate correctly---e.g., the @file{/etc}, @file{/var}, and @file{/run} directories, and the @file{/bin/sh} file. +This command also installs GRUB on the device specified in +@file{my-os-config}, unless the @option{--no-grub} option was passed. + @item vm @cindex virtual machine Build a virtual machine that contain the operating system declared in diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ee5df6e95..c02ad36c0 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -29,6 +29,8 @@ #: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) @@ -69,9 +71,12 @@ file args)))))) (define* (install store os-dir target - #:key (log-port (current-output-port))) + #: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." +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=?))) @@ -97,8 +102,9 @@ absolute directory name since that's what 'guix-register' expects." (format log-port "populating '~a'...~%" target) (populate-root-file-system target) - ;; TODO: Install GRUB. - ) + (when grub? + (unless (install-grub grub.cfg device target) + (leave (_ "failed to install GRUB on device '~a'~%") device)))) ;;; @@ -122,6 +128,8 @@ Build the operating system declared in FILE according to ACTION.\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")) @@ -143,6 +151,9 @@ Build the operating system declared in FILE according to ACTION.\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))) @@ -155,7 +166,8 @@ Build the operating system declared in FILE according to ACTION.\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))) ;;; @@ -205,39 +217,57 @@ Build the operating system declared in FILE according to ACTION.\n")) args)) (with-error-handling - (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)))) - (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)))) + (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) (when (eq? action 'init) - (let ((target (second args))) + (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)))))))) + (canonicalize-path target) + #:grub? grub? + #:grub.cfg (derivation->output-path grub.cfg) + #:device device))))))) -- cgit v1.3 From c56d19fb113d96a5af7c6d0500d256e633fe3eb9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:42:34 +0200 Subject: guix system: Factorize out closure copy. * guix/scripts/system.scm (copy-closure): New procedure. (install): Use it. --- guix/scripts/system.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index c02ad36c0..78bff2811 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -70,6 +70,22 @@ (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) @@ -83,19 +99,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (topologically-sorted store lst))) ;; Copy items to the new store. - (for-each (lambda (item) - (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)))) + (for-each (cut copy-closure store <> target #:log-port log-port) to-copy) ;; Create a bunch of additional files. -- cgit v1.3 From 79b0d4e1049afe1ceb5d420a9ceb11c230a1da24 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:47:27 +0200 Subject: guix system: Check whether we are installing to /. * guix/scripts/system.scm (install): Check whether TARGET is / and warn. --- guix/scripts/system.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 78bff2811..af48c57b5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -98,9 +98,11 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." string=?))) (topologically-sorted store lst))) - ;; Copy items to the new store. - (for-each (cut copy-closure store <> target #:log-port log-port) - to-copy) + (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) -- cgit v1.3 From 52ddf2ae6fb369ec64aae75fc311d6cc57a713b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 23:08:43 +0200 Subject: ui: Gracefully deal with zero-output derivations. * guix/ui.scm (show-what-to-build)[built-or-substitutable?]: New procedure. Check whether OUT is #f. Use it. * tests/ui.scm ("show-what-to-build, zero outputs"): New test. --- guix/ui.scm | 17 +++++++++-------- tests/ui.scm | 12 ++++++++++++ 2 files changed, 21 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 259dddd48..48b5c745c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -261,6 +261,14 @@ error." derivations listed in DRV. Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are available for download." + (define (built-or-substitutable? drv) + (let ((out (derivation->output-path drv))) + ;; If DRV has zero outputs, OUT is #f. + (or (not out) + (or (valid-path? store out) + (and use-substitutes? + (has-substitutes? store out)))))) + (let*-values (((build download) (fold2 (lambda (drv build download) (let-values (((b d) @@ -275,14 +283,7 @@ available for download." ((build) ; add the DRV themselves (delete-duplicates (append (map derivation-file-name - (remove (lambda (drv) - (let ((out (derivation->output-path - drv))) - (or (valid-path? store out) - (and use-substitutes? - (has-substitutes? store - out))))) - drv)) + (remove built-or-substitutable? drv)) (map derivation-input-path build)))) ((download) ; add the references of DOWNLOAD (if use-substitutes? diff --git a/tests/ui.scm b/tests/ui.scm index 886223ef5..4bf7a779c 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -19,6 +19,8 @@ (define-module (test-ui) #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-64)) @@ -189,6 +191,16 @@ interface, and powerful string processing.") (lambda args #t))) +(test-equal "show-what-to-build, zero outputs" + "" + (with-store store + (let ((drv (derivation store "zero" "/bin/sh" '() + #:outputs '()))) + (with-error-to-string + (lambda () + ;; This should print nothing. + (show-what-to-build store (list drv))))))) + (test-end "ui") -- cgit v1.3 From 9bea3b42b49434bccd9acd296569d2a874eddb6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:52:31 +0200 Subject: vm: Fix typo. Regression introduced in e38e18f. * guix/build/vm.scm (initialize-hard-disk)[partition]: Use a string. --- guix/build/vm.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/vm.scm b/guix/build/vm.scm index cf661a33f..e3f6d27ee 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -168,7 +168,7 @@ further populate the partition." (string-append target-directory (%store-directory))) (define partition - (string-append device 1)) + (string-append device "1")) (unless (initialize-partition-table device #:partition-size -- cgit v1.3 From eb7ccb1afaaa5db3a6c4fdec0a9f22919d100952 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:56:20 +0200 Subject: linux-initrd: Display a backtrace when the initial program fails. * guix/build/linux-initrd.scm (boot-system): Add pre-unwind handler in 'catch' form around 'primitive-load', and call 'format' and 'display-backtrace' from there. --- guix/build/linux-initrd.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 9093e7269..8db9f02ca 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -482,10 +482,12 @@ to it are lost." (catch #t (lambda () (primitive-load to-load)) + (lambda args + (start-repl)) (lambda args (format (current-error-port) "'~a' raised an exception: ~s~%" to-load args) - (start-repl))) + (display-backtrace (make-stack #t) (current-error-port)))) (format (current-error-port) "boot program '~a' terminated, rebooting~%" to-load) -- cgit v1.3 From d28869afadd37757aca79c0f6272b962e2083e32 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 15:29:23 +0200 Subject: store: Flush the output when the build process emits '\r'. This allows progress reports emitted by 'substitute-binary' to be correctly displayed. * guix/store.scm (%newlines): New variable. (process-stderr) <%stderr-next>: Flush (current-build-output-port) when S contains one of %NEWLINES. --- guix/store.scm | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 073e024e3..864303ddb 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -370,6 +370,12 @@ to OUT, using chunks of BUFFER-SIZE bytes." (min (- len total) buffer-size) buffer-size))))))) +(define %newlines + ;; Newline characters triggering a flush of 'current-build-output-port'. + ;; Unlike Guile's _IOLBF, we flush upon #\return so that progress reports + ;; that use that trick are correctly displayed. + (char-set #\newline #\return)) + (define* (process-stderr server #:optional user-port) "Read standard output and standard error from SERVER, writing it to CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and @@ -412,6 +418,8 @@ encoding conversion errors." ;; Log a string. (let ((s (read-latin1-string p))) (display s (current-build-output-port)) + (when (string-any %newlines s) + (flush-output-port (current-build-output-port))) #f)) ((= k %stderr-error) ;; Report an error. -- cgit v1.3 From d1f477199d649cbe33558ed218fa8063553decc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 23:19:13 +0200 Subject: vm: Remove misleading comment. * guix/build/vm.scm (load-in-linux-vm): Remove misleading comment. --- guix/build/vm.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e3f6d27ee..3c51ff8f3 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -94,8 +94,7 @@ the #:references-graphs parameter of 'derivation'." (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" ; XXX: who mkdir'd OUTPUT? - output) + (copy-file "image.qcow2" output) (begin (mkdir output) (copy-recursively "xchg" output)))) -- cgit v1.3 From 641f9a2a1f3a1ad0b4c3003a2efc5c7975286cc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 23:31:46 +0200 Subject: vm: Modularize build-side code. * guix/build/install.scm (install-grub): Call 'error' if 'system*' returns non-zero. * guix/build/vm.scm (initialize-partition-table): Make 'partition-size' a positional parameter. Call 'error' when 'system*' returns non-zero'. (format-partition, initialize-root-partition): New procedures. (initialize-hard-disk): Use them. --- guix/build/install.scm | 10 +++-- guix/build/vm.scm | 102 ++++++++++++++++++++++++++++--------------------- 2 files changed, 64 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/guix/build/install.scm b/guix/build/install.scm index f61c16f13..663a87b4b 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -37,7 +37,7 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." +MOUNT-POINT." (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) (pivot (string-append target ".new"))) (mkdir-p (dirname target)) @@ -47,9 +47,11 @@ MOUNT-POINT. Return #t on success." (copy-file grub.cfg pivot) (rename-file pivot target) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device)))) + (unless (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" + (string-append mount-point "/boot") + device)) + (error "failed to install GRUB")))) (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 3c51ff8f3..2a8843c63 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -25,6 +25,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (load-in-linux-vm + format-partition + initialize-root-partition + initialize-partition-table initialize-hard-disk)) ;;; Commentary: @@ -113,16 +116,20 @@ The data at PORT is the format produced by #:references-graphs." (loop (read-line port) result))))) -(define* (initialize-partition-table device +(define* (initialize-partition-table device partition-size #:key (label-type "msdos") - partition-size) + (offset (expt 2 20))) "Create on DEVICE a partition table of type LABEL-TYPE, with a single -partition of PARTITION-SIZE MiB. Return #t on success." - (display "creating partition table...\n") - (zero? (system* "parted" device "mklabel" label-type - "mkpart" "primary" "ext2" "1MiB" - (format #f "~aB" partition-size)))) +partition of PARTITION-SIZE bytes starting at OFFSET bytes. Return #t on +success." + (format #t "creating partition table with a ~a B partition...\n" + partition-size) + (unless (zero? (system* "parted" device "mklabel" label-type + "mkpart" "primary" "ext2" + (format #f "~aB" offset) + (format #f "~aB" partition-size))) + (error "failed to create partition table"))) (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in @@ -146,43 +153,19 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define MS_BIND 4096) ; again! -(define* (initialize-hard-disk device - #:key - grub.cfg - disk-image-size - (file-system-type "ext4") - (closures '()) - copy-closures? - (register-closures? #t) - (directives '())) - "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a -FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is -true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is -true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to -further populate the partition." - (define target-directory - "/fs") +(define (format-partition partition type) + "Create a file system TYPE on PARTITION." + (format #t "creating ~a partition...\n" type) + (unless (zero? (system* (string-append "mkfs." type) "-F" partition)) + (error "failed to create partition"))) +(define* (initialize-root-partition target-directory + #:key copy-closures? register-closures? + closures) + "Initialize the root partition mounted at TARGET-DIRECTORY." (define target-store (string-append target-directory (%store-directory))) - (define partition - (string-append device "1")) - - (unless (initialize-partition-table device - #:partition-size - (- disk-image-size (* 5 (expt 2 20)))) - (error "failed to create partition table")) - - (format #t "creating ~a partition...\n" file-system-type) - (unless (zero? (system* (string-append "mkfs." file-system-type) - "-F" partition)) - (error "failed to create partition")) - - (display "mounting partition...\n") - (mkdir target-directory) - (mount partition target-directory file-system-type) - (when copy-closures? ;; Populate the store. (populate-store (map (cut string-append "/xchg/" <>) closures) @@ -207,12 +190,43 @@ further populate the partition." (unless copy-closures? (system* "umount" target-store))) - ;; Evaluate the POPULATE directives. + ;; Add the non-store directories and files. (display "populating...\n") - (populate-root-file-system target-directory) + (populate-root-file-system target-directory)) + +(define* (initialize-hard-disk device + #:key + grub.cfg + disk-image-size + (file-system-type "ext4") + (closures '()) + copy-closures? + (register-closures? #t)) + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a +FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is +true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is +true, copy all of CLOSURES to the partition." + (define target-directory + "/fs") + + (define partition + (string-append device "1")) + + (initialize-partition-table device + (- disk-image-size (* 5 (expt 2 20)))) + + (format-partition partition file-system-type) + + (display "mounting partition...\n") + (mkdir target-directory) + (mount partition target-directory file-system-type) + + (initialize-root-partition target-directory + #:copy-closures? copy-closures? + #:register-closures? register-closures? + #:closures closures) - (unless (install-grub grub.cfg device target-directory) - (error "failed to install GRUB")) + (install-grub grub.cfg device target-directory) ;; 'guix-register' resets timestamps and everything, so no need to do it ;; once more in that case. -- cgit v1.3 From 6d763bdddbea7a95f9f0bd5d5a1ada5e80c37fde Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 22 May 2014 21:58:08 +0200 Subject: guix: download: Update imagemagick mirrors. * guix/download.scm (%mirrors)[imagemagick]: Update and add the legacy subdirectory of the main site as a last resort. --- guix/download.scm | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 8ec17ae55..47b72f432 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -157,13 +157,30 @@ "ftp://ftp.nara.wide.ad.jp/pub/CPAN/" "http://mirrors.163.com/cpan/" "ftp://cpan.mirror.ac.za/") - (imagemagick ; from http://www.imagemagick.org/script/download.php + (imagemagick + ;; from http://www.imagemagick.org/script/download.php + ;; (without mirrors that are unavailable or not up to date) + ;; mirrors keeping old versions at the top level + "ftp://ftp.sunet.se/pub/multimedia/graphics/ImageMagick/" + "ftp://sunsite.icm.edu.pl/packages/ImageMagick/" + ;; mirrors moving old versions to "legacy" + "http://mirrors-au.go-parts.com/mirrors/ImageMagick/" + "ftp://mirror.aarnet.edu.au/pub/imagemagick/" "http://mirror.checkdomain.de/imagemagick/" - "ftp://gd.tuwien.ac.at/pub/graphics/ImageMagick/" - "http://www.imagemagick.org/download" - "ftp://mirror.searchdaimon.com/ImageMagick" + "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/" + "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/" + "ftp://ftp.nluug.nl/pub/ImageMagick/" + "http://ftp.surfnet.nl/pub/ImageMagick/" + "http://mirror.searchdaimon.com/ImageMagick" + "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/" + "http://mirrors-ru.go-parts.com/mirrors/ImageMagick/" "http://mirror.is.co.za/pub/imagemagick/" - "ftp://mirror.aarnet.edu.au/pub/imagemagick/") + "http://mirrors-uk.go-parts.com/mirrors/ImageMagick/" + "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/" + "ftp://ftp.fifi.org/pub/ImageMagick/" + "http://www.imagemagick.org/download/" + ;; one legacy location as a last resort + "http://www.imagemagick.org/download/legacy/") (debian "http://ftp.de.debian.org/debian/" "http://ftp.fr.debian.org/debian/" -- cgit v1.3 From 3035b50f28c1bcbc0a2bb09457a69ea9c06d69e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 21:57:39 +0200 Subject: linux-initrd: Build /dev/loop* nodes. * guix/build/linux-initrd.scm (make-essential-device-nodes): Build /dev/loop[0-7]. --- guix/build/linux-initrd.scm | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 8db9f02ca..5be3c1ac2 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -168,6 +168,14 @@ Return the value associated with OPTION, or #f on failure." (symlink "/proc/self/fd/1" (scope "dev/stdout")) (symlink "/proc/self/fd/2" (scope "dev/stderr")) + ;; Loopback devices. + (let loop ((i 0)) + (when (< i 8) + (mknod (scope (string-append "dev/loop" (number->string i))) + 'block-special #o660 + (device-number 7 i)) + (loop (+ 1 i)))) + ;; File systems in user space (FUSE). (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) -- cgit v1.3 From c4a74364b9ddb5c34bce788d453f93aa307731dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 22:30:13 +0200 Subject: vm: Make the image format a parameter. * guix/build/vm.scm (load-in-linux-vm): Add #:disk-image-format parameter; add 'image-file' variable. Honor DISK-IMAGE-FORMAT. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add #:disk-image-format parameter, and honor it. (qemu-image): Likewise. --- gnu/system/vm.scm | 18 ++++++++++++------ guix/build/vm.scm | 10 +++++++--- 2 files changed, 19 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 0d41791d8..39ce5bb6e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -119,6 +119,7 @@ input tuple. The output file name is when building for SYSTEM." (make-disk-image? #f) (references-graphs #f) (memory-size 256) + (disk-image-format "qcow2") (disk-image-size (* 100 (expt 2 20)))) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a @@ -127,8 +128,9 @@ store; it should put its output files in the `/xchg' directory, which is copied to the derivation's output when the VM terminates. The virtual machine runs with MEMORY-SIZE MiB of memory. -When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of -DISK-IMAGE-SIZE bytes and return it. +When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type +DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and +return it. MODULES is the set of modules imported in the execution environment of EXP. @@ -174,6 +176,7 @@ made available under the /xchg CIFS share." #:linux linux #:initrd initrd #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? + #:disk-image-format #$disk-image-format #:disk-image-size #$disk-image-size #:references-graphs graphs)))) @@ -190,15 +193,17 @@ made available under the /xchg CIFS share." (system (%current-system)) (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) + (disk-image-format "qcow2") (file-system-type "ext4") grub-configuration (register-closures? #t) (inputs '()) copy-inputs?) - "Return a bootable, stand-alone QEMU image, with a root partition of type -FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB -installation that uses GRUB-CONFIGURATION as its configuration -file (GRUB-CONFIGURATION must be the name of a file in the VM.) + "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., +'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. The +returned image is a full disk image, with a GRUB installation that uses +GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the +name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, @@ -242,6 +247,7 @@ the image." #:system system #:make-disk-image? #t #:disk-image-size disk-image-size + #:disk-image-format disk-image-format #:references-graphs graph))) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2a8843c63..4de536abb 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -50,6 +50,7 @@ (qemu (qemu-command)) (memory-size 512) linux initrd make-disk-image? (disk-image-size 100) + (disk-image-format "qcow2") (references-graphs '())) "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy the result to OUTPUT. @@ -60,9 +61,12 @@ it via /dev/hda. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by the #:references-graphs parameter of 'derivation'." + (define image-file + (string-append "image." disk-image-format)) (when make-disk-image? - (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2" + (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format + image-file (number->string disk-image-size))) (error "qemu-img failed"))) @@ -92,12 +96,12 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - '("-hda" "image.qcow2") + `("-hda" ,image-file) '()))) (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" output) + (copy-file image-file output) (begin (mkdir output) (copy-recursively "xchg" output)))) -- cgit v1.3 From f19c6e5fe79c8bbd3c9ea25cd0380681bd99ce13 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 22:32:53 +0200 Subject: vm: Use a para-virtualized disk when creating an image. * guix/build/vm.scm (load-in-linux-vm): When MAKE-DISK-IMAGE?, use '-drive ...,if=virtio' for better performance. * gnu/system/vm.scm (qemu-image): Use /dev/vda instead of /dev/sda. --- gnu/system/vm.scm | 2 +- guix/build/vm.scm | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 39ce5bb6e..7d0ffd971 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -236,7 +236,7 @@ the image." (let ((graphs '#$(match inputs (((names . _) ...) names)))) - (initialize-hard-disk "/dev/sda" + (initialize-hard-disk "/dev/vda" #:grub.cfg #$grub-configuration #:closures graphs #:copy-closures? #$copy-inputs? diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 4de536abb..e559542f0 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -96,7 +96,8 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - `("-hda" ,image-file) + `("-drive" ,(string-append "file=" image-file + ",if=virtio")) '()))) (error "qemu failed" qemu)) -- cgit v1.3 From fb729425dcd80b8ef34c075867d2f204bc4d55cb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 23:22:15 +0200 Subject: guix system: Add 'disk-image' action. * guix/scripts/system.scm (show-help): Add 'disk-image'. (guix-system)[parse-options]: Support 'disk-image' action. [option-arguments]: Likewise. Handle the 'disk-image' action. * doc/guix.texi (Invoking guix system): Document 'disk-image'. --- doc/guix.texi | 20 +++++++++++++++++--- guix/scripts/system.scm | 12 +++++++++--- 2 files changed, 26 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index edb1dceea..ddb076349 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3236,9 +3236,23 @@ Build a virtual machine that contain the operating system declared in The VM shares its store with the host system. @item vm-image -Return a virtual machine image of the operating system declared in -@var{file} that stands alone. Use the @option{--image-size} option to -specify the size of the image. +@itemx disk-image +Return a virtual machine or disk image of the operating system declared +in @var{file} that stands alone. Use the @option{--image-size} option +to specify the size of the image. + +When using @code{vm-image}, the returned image is in qcow2 format, which +the QEMU emulator can efficiently use. + +When using @code{disk-image}, a raw disk image is produced; it can be +copied as is to a USB stick, for instance. Assuming @code{/dev/sdc} is +the device corresponding to a USB stick, one can copy the image on it +using the following command: + +@example +# dd if=$(guix system disk-image my-os.scm) of=/dev/sdc +@end example + @end table @var{options} can contain any of the common build options provided by diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index af48c57b5..345d8c3e5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -129,6 +129,8 @@ Build the operating system declared in FILE according to ACTION.\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) @@ -191,7 +193,7 @@ Build the operating system declared in FILE according to ACTION.\n")) (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image init) + ((build vm vm-image disk-image init) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -214,7 +216,7 @@ Build the operating system declared in FILE according to ACTION.\n")) action)) (case action - ((build vm vm-image) + ((build vm vm-image disk-image) (unless (= count 1) (fail))) ((init) @@ -238,7 +240,11 @@ Build the operating system declared in FILE according to ACTION.\n")) (system-qemu-image os #:disk-image-size size))) ((vm) - (system-qemu-image/shared-store-script os)))) + (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)) -- cgit v1.3 From a68d976b666a5097585cf221f4f8d793f90f3464 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 May 2014 22:19:37 +0200 Subject: download: Enlarge your receive buffer. * guix/build/download.scm (open-connection-for-uri): Remove call to 'setsockopt'. * guix/http-client.scm (open-socket-for-uri)[rmem-max, buffer-size]: New variables. Add call to 'setsockopt'. --- guix/build/download.scm | 2 -- guix/http-client.scm | 12 ++++++++++++ 2 files changed, 12 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 5d881b93e..d98933a90 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -167,8 +167,6 @@ which is not available during bootstrap." ;; Buffer input and output on this port. (setvbuf s _IOFBF) - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) (if (eq? 'https (uri-scheme uri)) (tls-wrap s) diff --git a/guix/http-client.scm b/guix/http-client.scm index 1f05df4b0..4770628e4 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -162,7 +162,19 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true." (define* (open-socket-for-uri uri #:key (buffered? #t)) "Return an open port for URI. When BUFFERED? is false, the returned port is unbuffered." + (define rmem-max + ;; The maximum size for a receive buffer on Linux, see socket(7). + "/proc/sys/net/core/rmem_max") + + (define buffer-size + (if (file-exists? rmem-max) + (call-with-input-file rmem-max read) + 126976)) ; the default for Linux, per 'rmem_default' + (let ((s ((@ (web client) open-socket-for-uri) uri))) + ;; Work around by restoring a decent + ;; buffer size. + (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) (unless buffered? (setvbuf s _IONBF)) s)) -- cgit v1.3 From 484a2b3a5ac7337e5d3b8773f6ce8c356b72742b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 15:51:57 +0200 Subject: system: Separate the activation script from the boot script. * gnu/system.scm (operating-system-activation-script): New procedure, containing most of the former 'operating-system-boot-script'. (operating-system-boot-script): Call it, and 'primitive-load' its result. * guix/build/activation.scm (%booted-system): Remove. (activate-current-system): Remove #:boot? parameter and related code. --- gnu/system.scm | 27 ++++++++++++++++++++++----- guix/build/activation.scm | 18 ++++-------------- 2 files changed, 26 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/gnu/system.scm b/gnu/system.scm index 6cb7d303d..1d708179b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -348,9 +348,10 @@ alias ll='ls -l' ,#$(user-account-shell account) ; this one is a gexp #$(user-account-password account))) -(define (operating-system-boot-script os) - "Return the boot script for OS---i.e., the code started by the initrd once -we're running in the final root." +(define (operating-system-activation-script os) + "Return the activation script for OS---i.e., the code that \"activates\" the +stateful part of OS, including user accounts and groups, special directories, +etc." (define %modules '((guix build activation) (guix build utils) @@ -360,7 +361,6 @@ we're running in the final root." (etc (operating-system-etc-directory os)) (modules (imported-modules %modules)) (compiled (compiled-modules %modules)) - (dmd-conf (dmd-configuration-file services)) (accounts (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) @@ -399,7 +399,24 @@ we're running in the final root." (activate-setuid-programs (list #$@setuid-progs)) ;; Set up /run/current-system. - (activate-current-system #:boot? #t) + (activate-current-system))))) + +(define (operating-system-boot-script os) + "Return the boot script for OS---i.e., the code started by the initrd once +we're running in the final root." + (mlet* %store-monad ((services (operating-system-services os)) + (activate (operating-system-activation-script os)) + (dmd-conf (dmd-configuration-file services))) + (gexp->file "boot" + #~(begin + ;; Activate the system. + ;; TODO: Use 'load-compiled'. + (primitive-load #$activate) + + ;; Keep track of the booted system. + (false-if-exception (delete-file "/run/booted-system")) + (symlink (readlink "/run/current-system") + "/run/booted-system") ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 49f98c021..62e69a915 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -197,29 +197,19 @@ numeric gid or #f." (for-each make-setuid-program programs)) -(define %booted-system - ;; The system we booted in (a symlink.) - "/run/booted-system") - (define %current-system ;; The system that is current (a symlink.) This is not necessarily the same - ;; as %BOOTED-SYSTEM, for instance because we can re-build a new system - ;; configuration and activate it, without rebooting. + ;; as the system we booted (aka. /run/booted-system) because we can re-build + ;; a new system configuration and activate it, without rebooting. "/run/current-system") (define (boot-time-system) "Return the '--system' argument passed on the kernel command line." (find-long-option "--system" (linux-command-line))) -(define* (activate-current-system #:optional (system (boot-time-system)) - #:key boot?) - "Atomically make SYSTEM the current system. When BOOT? is true, also make -it the booted system." +(define* (activate-current-system #:optional (system (boot-time-system))) + "Atomically make SYSTEM the current system." (format #t "making '~a' the current system...~%" system) - (when boot? - (when (file-exists? %booted-system) - (delete-file %booted-system)) - (symlink system %booted-system)) ;; Atomically make SYSTEM current. (let ((new (string-append %current-system ".new"))) -- cgit v1.3 From 517830cc0154dbe4a77741e7ee61703c194086a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 17:53:30 +0200 Subject: system: Always create /var/empty. * guix/build/install.scm (directives): Add /var/empty. --- guix/build/install.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build/install.scm b/guix/build/install.scm index 663a87b4b..24de95406 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -78,6 +78,7 @@ STORE." (directory "/var/log") ; for dmd (directory "/var/run/nscd") (directory "/var/guix/gcroots") + (directory "/var/empty") ; for no-login accounts (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.3 From 4b2615e1cae8e21df8f180abf261d1dc22a2459e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 18:09:11 +0200 Subject: services: nscd: Provide an 'activate' script to make /var/run/nscd. * gnu/services/base.scm (nscd-service): Add 'activate' field. * guix/build/install.scm (directives): Remove /var/run/nscd; add /var/run. * doc/guix.texi (Defining Services): Add 'activate' field in example. Document it. --- doc/guix.texi | 19 +++++++++++++------ gnu/services/base.scm | 5 +++++ guix/build/install.scm | 2 +- 3 files changed, 19 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index ddb076349..bd853e6ea 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3299,6 +3299,9 @@ like: (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" "--foreground")) @@ -3307,12 +3310,16 @@ like: @end lisp @noindent -The @code{start} and @code{stop} fields are G-expressions -(@pxref{G-Expressions}). They refer to dmd's facilities to start and -stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd -Manual}). The @code{provision} field specifies the name under which -this service is known to dmd, and @code{documentation} specifies on-line -documentation. Thus, the commands @command{deco start ncsd}, +The @code{activate}, @code{start}, and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). The @code{activate} field contains a script to +run at ``activation'' time; it makes sure that the @file{/var/run/nscd} +directory exists before @command{nscd} is started. + +The @code{start} and @code{stop} fields refer to dmd's facilities to +start and stop processes (@pxref{Service De- and Constructors,,, dmd, +GNU dmd Manual}). The @code{provision} field specifies the name under +which this service is known to dmd, and @code{documentation} specifies +on-line documentation. Thus, the commands @command{deco start ncsd}, @command{deco stop nscd}, and @command{deco doc nscd} will do what you would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). diff --git a/gnu/services/base.scm b/gnu/services/base.scm index aec605058..dc0161408 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -225,6 +225,11 @@ stopped before 'kill' is called." (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) (requirement '(user-processes)) + + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) + (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" diff --git a/guix/build/install.scm b/guix/build/install.scm index 24de95406..afa7d1dd8 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -76,9 +76,9 @@ STORE." `((directory ,store 0 0) (directory "/etc") (directory "/var/log") ; for dmd - (directory "/var/run/nscd") (directory "/var/guix/gcroots") (directory "/var/empty") ; for no-login accounts + (directory "/var/run") (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.3 From 884af1b4ecb0c6ede9fb431105c5c931d1bd1619 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 25 May 2014 01:31:15 +0200 Subject: store: Remove misleading 'setsockopt' call. * guix/store.scm (open-connection): Remove misleading 'setsockopt' call, erroneously introduced in df1fab58. This would actually shrink the receive buffer from 124 KiB to 12 KiB, though it had little impact on performance. --- guix/store.scm | 10 ---------- 1 file changed, 10 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 864303ddb..0c99e623e 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -290,16 +290,6 @@ operate, should the disk become full. Return a server object." (socket PF_UNIX SOCK_STREAM 0))) (a (make-socket-address PF_UNIX file))) - (catch 'system-error - (lambda () - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))) - (lambda args - ;; On the Hurd, the pflocal server's implementation of `socket_setopt' - ;; always returns ENOPROTOOPT. Ignore it. - (unless (= (system-error-errno args) ENOPROTOOPT) - (apply throw args)))) - (catch 'system-error (cut connect s a) (lambda args -- cgit v1.3 From 5895f2444317ba74eeab21d517c703c3687165c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 May 2014 22:01:51 +0200 Subject: store: Work around 'get-bytevector-n' bug that affects 'import-paths'. Fixes . * guix/store.scm (process-stderr) <%stderr-read>: Use 'get-bytevector-n!' instead of 'get-bytevector-n'. --- guix/store.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 0c99e623e..8c774a6db 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -397,11 +397,13 @@ encoding conversion errors." #f) ((= k %stderr-read) ;; Read a byte stream from USER-PORT. + ;; Note: Avoid 'get-bytevector-n' to work around + ;; in Guile up to 2.0.11. (let* ((max-len (read-int p)) - (data (get-bytevector-n user-port max-len)) - (len (bytevector-length data))) + (data (make-bytevector max-len)) + (len (get-bytevector-n! user-port data 0 max-len))) (write-int len p) - (put-bytevector p data) + (put-bytevector p data 0 len) (write-padding len p) #f)) ((= k %stderr-next) -- cgit v1.3