From a76611c4359ca4d92483e500f2ce95053222661b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jan 2014 21:32:59 +0100 Subject: offload: Do not try to retrieve anything upon build failure. * guix/scripts/offload.scm (offload): Add 'log-port' keyword parameter. Handle log display here. Return the result of (close-pipe pipe). (process-request): Adjust 'offload' call site accordingly. Call 'retrieve-files' only when 'offload' returns zero; exit when 'offload' returns non-zero. --- guix/scripts/offload.scm | 45 ++++++++++++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index d919ede3c7..1f68160785 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -170,9 +170,9 @@ running lsh gateway upon success, or #f on failure." (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200)) + (build-timeout 7200) (log-port (current-output-port))) "Perform DRV on MACHINE, assuming DRV and its prerequisites are available -there. Return a read pipe from where to read the build log." +there, and write the build log to LOG-PORT. Return the exit status." (format (current-error-port) "offloading '~a' to '~a'...~%" (derivation-file-name drv) (build-machine-name machine)) (format (current-error-port) "@ build-remote ~a ~a~%" @@ -185,7 +185,13 @@ there. Return a read pipe from where to read the build log." ,(format #f "--max-silent-time=~a" max-silent-time) ,(derivation-file-name drv))))) - pipe)) + (let loop ((line (read-line pipe))) + (unless (eof-object? line) + (display line log-port) + (newline log-port) + (loop (read-line pipe)))) + + (close-pipe pipe))) (define (send-files files machine) "Send the subset of FILES that's missing to MACHINE's store. Return #t on @@ -291,20 +297,25 @@ success, #f otherwise." (outputs (string-tokenize (read-line)))) (when (send-files (cons (derivation-file-name drv) inputs) machine) - (let ((log (offload drv machine - #:print-build-trace? print-build-trace? - #:max-silent-time max-silent-time - #:build-timeout build-timeout))) - (let loop ((line (read-line log))) - (if (eof-object? line) - (close-pipe log) - (begin - (display line) (newline) - (loop (read-line log)))))) - (retrieve-files outputs machine))) - (format (current-error-port) "done with offloaded '~a'~%" - (derivation-file-name drv)) - (kill pid SIGTERM)) + (let ((status (offload drv machine + #:print-build-trace? print-build-trace? + #:max-silent-time max-silent-time + #:build-timeout build-timeout))) + (kill pid SIGTERM) + (if (zero? status) + (begin + (retrieve-files outputs machine) + (format (current-error-port) + "done with offloaded '~a'~%" + (derivation-file-name drv))) + (begin + (format (current-error-port) + "derivation '~a' offloaded to '~a' failed \ +with exit code ~a~%" + (derivation-file-name drv) + (build-machine-name machine) + (status:exit-val status)) + (primitive-exit (status:exit-val status)))))))) (#f (display "# decline\n"))) (display "# decline\n")))) -- cgit v1.2.3 From f06afd4da2be6571e7a78e9745907ee9afc57967 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jan 2014 23:31:28 +0100 Subject: download: Add archive.apache.org to the Apache mirrors. * guix/download.scm (%mirrors)[apache]: Add archive.apache.org as a last resort. --- guix/download.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 8a3e9fd06a..2cc8a4a5b8 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; ;;; This file is part of GNU Guix. @@ -108,7 +108,10 @@ "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/" "http://apache.belnet.be/" "http://mirrors.ircam.fr/pub/apache/" - "http://apache-mirror.rbc.ru/pub/apache/") + "http://apache-mirror.rbc.ru/pub/apache/" + + ;; As a last resort, try the archive. + "http://archive.apache.org/dist/") (xorg ; from http://www.x.org/wiki/Releases/Download "http://www.x.org/releases/" ; main mirrors "ftp://mirror.csclub.uwaterloo.ca/x.org/" ; North America -- cgit v1.2.3 From 413d5351aa3dd3e122f807cb944405c156d254e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 Jan 2014 13:04:48 +0100 Subject: monads: Add 'imported-modules' and 'compiled-modules'. * guix/monads.scm (package-file): Fix typo. (imported-modules, compiled-modules): New procedures. --- guix/monads.scm | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/monads.scm b/guix/monads.scm index 410fdbecb2..ad80a0698d 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,9 @@ package->derivation built-derivations derivation-expression - lower-inputs)) + lower-inputs) + #:replace (imported-modules + compiled-modules)) ;;; Commentary: ;;; @@ -310,7 +312,7 @@ containing TEXT." (define* (package-file package #:optional file #:key (system (%current-system)) (output "out")) - "Return as a monadic value in the absolute file name of FILE within the + "Return as a monadic value the absolute file name of FILE within the OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the OUTPUT directory of PACKAGE." (lambda (store) @@ -342,6 +344,12 @@ input list as a monadic value." (define package->derivation (store-lift package-derivation)) +(define imported-modules + (store-lift (@ (guix derivations) imported-modules))) + +(define compiled-modules + (store-lift (@ (guix derivations) compiled-modules))) + (define built-derivations (store-lift build-derivations)) -- cgit v1.2.3 From d4254711821f7df93e33aa4a3f6484b901c7b5e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 29 Jan 2014 21:57:56 +0100 Subject: gnu: linux-initrd: Factorize boot code. * guix/build/linux-initrd.scm (boot-system): New procedure. * gnu/system/linux-initrd.scm (qemu-initrd): Add keyword parameters 'guile-modules-in-chroot?' and 'mounts'. Change builder to simply call 'boot-system'. (gnu-system-initrd): Change to a simple call to 'qemu-initrd'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Call 'qemu-initrd' with #:guile-modules-in-chroot?. --- gnu/system/linux-initrd.scm | 192 +++++++------------------------------------- gnu/system/vm.scm | 4 +- guix/build/linux-initrd.scm | 121 +++++++++++++++++++++++++++- 3 files changed, 152 insertions(+), 165 deletions(-) (limited to 'guix') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index a28b913c3e..ea9d708dac 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -19,6 +19,8 @@ (define-module (gnu system linux-initrd) #:use-module (guix monads) #:use-module (guix utils) + #:use-module ((guix store) + #:select (%store-prefix)) #:use-module (gnu packages cpio) #:use-module (gnu packages compression) #:use-module (gnu packages linux) @@ -181,180 +183,46 @@ list of Guile module names to be embedded in the initrd." #:modules '((guix build utils)) #:inputs inputs))) -(define (qemu-initrd) +(define* (qemu-initrd #:key + guile-modules-in-chroot? + (mounts `((cifs "/store" ,(%store-prefix)) + (cifs "/xchg" "/xchg")))) "Return a monadic derivation that builds an initrd for use in a QEMU guest -where the store is shared with the host." - (expression->initrd - '(begin - (use-modules (srfi srfi-1) - (srfi srfi-26) - (ice-9 match) - ((system base compile) #:select (compile-file)) - (guix build utils) - (guix build linux-initrd)) - - (display "Welcome, this is GNU's early boot Guile.\n") - (display "Use '--repl' for an initrd REPL.\n\n") - - (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"))) - - (when (member "--repl" args) - ((@ (system repl repl) start-repl))) - - (display "loading CIFS and companion modules...\n") - (for-each (compose load-linux-module* - (cut string-append "/modules/" <>)) - (list "md4.ko" "ecb.ko" "cifs.ko")) - - (unless (configure-qemu-networking) - (display "network interface is DOWN\n")) +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: - ;; Make /dev nodes. - (make-essential-device-nodes) + (FILE-SYSTEM-TYPE SOURCE TARGET) - ;; Prepare the real root file system under /root. - (unless (file-exists? "/root") - (mkdir "/root")) - (if root - (mount root "/root" "ext3") - (mount "none" "/root" "tmpfs")) - (mount-essential-file-systems #:root "/root") +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!)." + (define cifs-modules + ;; Modules needed to mount CIFS file systems. + '("md4.ko" "ecb.ko" "cifs.ko")) - (mkdir-p "/root/xchg") - (mkdir-p "/root/nix/store") + (define linux-modules + ;; Modules added to the initrd and loaded from the initrd. + (if (assoc-ref mounts 'cifs) + cifs-modules + '())) - (unless (file-exists? "/root/dev") - (mkdir "/root/dev") - (make-essential-device-nodes #:root "/root")) - - ;; Mount the host's store and exchange directory. - (mount-qemu-smb-share "/store" "/root/nix/store") - (mount-qemu-smb-share "/xchg" "/root/xchg") - - ;; Copy the directories that contain .scm and .go files so that the - ;; child process in the chroot can load modules (we would bind-mount - ;; them but for some reason that fails with EINVAL -- XXX). - (mkdir-p "/root/share") - (mkdir-p "/root/lib") - (mount "none" "/root/share" "tmpfs") - (mount "none" "/root/lib" "tmpfs") - (copy-recursively "/share" "/root/share" - #:log (%make-void-port "w")) - (copy-recursively "/lib" "/root/lib" - #:log (%make-void-port "w")) - - - (if to-load - (letrec ((resolve - (lambda (file) - ;; If FILE is a symlink to an absolute file name, - ;; resolve it as if we were under /root. - (let ((st (lstat file))) - (if (eq? 'symlink (stat:type st)) - (let ((target (readlink file))) - (resolve (string-append "/root" target))) - file))))) - (format #t "loading boot file '~a'...\n" to-load) - (compile-file (resolve (string-append "/root/" to-load)) - #:output-file "/root/loader.go" - #:opts %auto-compilation-options) - (match (primitive-fork) - (0 - (chroot "/root") - (load-compiled "/loader.go") + (expression->initrd + `(begin + (use-modules (guix build linux-initrd)) - ;; TODO: Remove /lib, /share, and /loader.go. - ) - (pid - (format #t "boot file loaded under PID ~a~%" pid) - (let ((status (waitpid pid))) - (reboot))))) - (begin - (display "no boot file passed via '--load'\n") - (display "entering a warm and cozy REPL\n") - ((@ (system repl repl) start-repl)))))) + (boot-system #:mounts ',mounts + #:linux-modules ',linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? ',guile-modules-in-chroot?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) #:linux linux-libre - #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) + #:linux-modules linux-modules)) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." - (expression->initrd - '(begin - (use-modules (srfi srfi-1) - (srfi srfi-26) - (ice-9 match) - (guix build utils) - (guix build linux-initrd)) - - (display "Welcome, this is GNU's early boot Guile.\n") - (display "Use '--repl' for an initrd REPL.\n\n") - - (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"))) - - (when (member "--repl" args) - ((@ (system repl repl) start-repl))) - - ;; Make /dev nodes. - (make-essential-device-nodes) - - ;; Prepare the real root file system under /root. - (mkdir-p "/root") - (if root - ;; Assume ROOT has a usable /dev tree. - (mount root "/root" "ext3") - (begin - (mount "none" "/root" "tmpfs") - (make-essential-device-nodes #:root "/root"))) - - (mount-essential-file-systems #:root "/root") - - (mkdir-p "/root/tmp") - (mount "none" "/root/tmp" "tmpfs") - - ;; XXX: We don't copy our fellow Guile modules to /root (see - ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can - ;; happen if it throws, to display the exception!), then we're - ;; screwed. Hopefully TO-LOAD is a simple expression that just does - ;; '(execlp ...)'. - - (if to-load - (begin - (format #t "loading '~a'...\n" to-load) - (chroot "/root") - (primitive-load to-load) - (format (current-error-port) - "boot program '~a' terminated, rebooting~%" - to-load) - (sleep 2) - (reboot)) - (begin - (display "no init file passed via '--load'\n") - (display "entering a warm and cozy REPL\n") - ((@ (system repl repl) start-repl)))))) - #:name "qemu-system-initrd" - #:modules '((guix build linux-initrd) - (guix build utils)) - #:linux linux-libre)) + (qemu-initrd #:guile-modules-in-chroot? #f)) ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index fa93654144..151535303a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -178,9 +178,9 @@ made available under the /xchg CIFS share." (user-builder (text-file "builder-in-linux-vm" (object->string exp*))) (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) - (initrd (if initrd + (initrd (if initrd ; use the default initrd? (return initrd) - (qemu-initrd))) ; default initrd + (qemu-initrd #:guile-modules-in-chroot? #t))) (inputs (lower-inputs `(("qemu" ,qemu) ("linux" ,linux) ("initrd" ,initrd) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index ae18a16e11..039a60acf3 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -19,6 +19,12 @@ (define-module (guix build linux-initrd) #:use-module (rnrs io ports) #:use-module (system foreign) + #:autoload (system repl repl) (start-repl) + #:autoload (system base compile) (compile-file) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line make-essential-device-nodes @@ -26,7 +32,8 @@ mount-qemu-smb-share bind-mount load-linux-module* - device-number)) + device-number + boot-system)) ;;; Commentary: ;;; @@ -151,4 +158,116 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our the last argument of `mknod'." (+ (* major 256) minor)) +(define* (boot-system #:key + (linux-modules '()) + qemu-guest-networking? + guile-modules-in-chroot? + (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 +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) + +When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in +the new root." + (define (resolve file) + ;; If FILE is a symlink to an absolute file name, resolve it as if we were + ;; under /root. + (let ((st (lstat file))) + (if (eq? 'symlink (stat:type st)) + (let ((target (readlink file))) + (resolve (string-append "/root" target))) + file))) + + (display "Welcome, this is GNU's early boot Guile.\n") + (display "Use '--repl' for an initrd REPL.\n\n") + + (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"))) + + (when (member "--repl" args) + (start-repl)) + + (display "loading kernel modules...\n") + (for-each (compose load-linux-module* + (cut string-append "/modules/" <>)) + linux-modules) + + (when qemu-guest-networking? + (unless (configure-qemu-networking) + (display "network interface is DOWN\n"))) + + ;; Make /dev nodes. + (make-essential-device-nodes) + + ;; Prepare the real root file system under /root. + (unless (file-exists? "/root") + (mkdir "/root")) + (if root + (mount root "/root" "ext3") + (mount "none" "/root" "tmpfs")) + (mount-essential-file-systems #:root "/root") + + (unless (file-exists? "/root/dev") + (mkdir "/root/dev") + (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))) + ;; TODO: Add 9p. + ) + mounts) + + (when guile-modules-in-chroot? + ;; Copy the directories that contain .scm and .go files so that the + ;; child process in the chroot can load modules (we would bind-mount + ;; them but for some reason that fails with EINVAL -- XXX). + (mkdir-p "/root/share") + (mkdir-p "/root/lib") + (mount "none" "/root/share" "tmpfs") + (mount "none" "/root/lib" "tmpfs") + (copy-recursively "/share" "/root/share" + #:log (%make-void-port "w")) + (copy-recursively "/lib" "/root/lib" + #:log (%make-void-port "w"))) + + (if to-load + (begin + (format #t "loading '~a'...\n" to-load) + (chroot "/root") + ;; TODO: Remove /lib, /share, and /loader.go. + (catch #t + (lambda () + (primitive-load to-load)) + (lambda args + (format (current-error-port) "'~a' raised an exception: ~s~%" + to-load args) + (start-repl))) + (format (current-error-port) + "boot program '~a' terminated, rebooting~%" + to-load) + (sleep 2) + (reboot)) + (begin + (display "no boot file passed via '--load'\n") + (display "entering a warm and cozy REPL\n") + (start-repl))))) + ;;; linux-initrd.scm ends here -- cgit v1.2.3 From 83b9e6a1854d4fb86f0269afac33200dce996f06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 01:40:02 +0100 Subject: gnu: linux-initrd: Start a REPL when the root could not be mounted. * guix/build/linux-initrd.scm (boot-system): Catch errors when mounting ROOT and call 'start-repl' upon error. --- guix/build/linux-initrd.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 039a60acf3..69cb58763f 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -217,7 +217,13 @@ the new root." (unless (file-exists? "/root") (mkdir "/root")) (if root - (mount root "/root" "ext3") + (catch #t + (lambda () + (mount root "/root" "ext3")) + (lambda args + (format (current-error-port) "exception while mounting '~a': ~s~%" + root args) + (start-repl))) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") -- cgit v1.2.3 From fc4bc4b6debecf9acc7e86ecb519c03b5b598bc4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 01:43:16 +0100 Subject: gnu: linux-initrd: Properly distinguish between /dev/sda* and /dev/vda*. * guix/build/linux-initrd.scm (make-essential-device-nodes): Rename devices with major = 8 to /dev/sda*. Make /dev/vda* devices. * gnu/system/vm.scm (qemu-image): Change '/dev/vda' to '/dev/sda'. * gnu/system.scm (operating-system-derivation): Likewise. --- gnu/system.scm | 2 +- gnu/system/vm.scm | 8 ++++---- guix/build/linux-initrd.scm | 13 +++++++++---- 3 files changed, 14 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/gnu/system.scm b/gnu/system.scm index 5fb4a7483e..e9ecfd2732 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -330,7 +330,7 @@ alias ll='ls -l' (package-full-name kernel) " (technology preview)")) (linux kernel) - (linux-arguments `("--root=/dev/vda1" + (linux-arguments `("--root=/dev/sda1" ,(string-append "--load=" boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index bd7718a14a..5407522652 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -294,18 +294,18 @@ such as /etc files." (assoc-ref %build-inputs "gawk") "/bin")) (display "creating partition table...\n") - (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" + (and (zero? (system* parted "/dev/sda" "mklabel" "msdos" "mkpart" "primary" "ext2" "1MiB" ,(format #f "~aB" (- disk-image-size (* 5 (expt 2 20)))))) (begin (display "creating ext3 partition...\n") - (and (zero? (system* mkfs "-F" "/dev/vda1")) + (and (zero? (system* mkfs "-F" "/dev/sda1")) (let ((store (string-append "/fs" ,%store-directory))) (display "mounting partition...\n") (mkdir "/fs") - (mount "/dev/vda1" "/fs" "ext3") + (mount "/dev/sda1" "/fs" "ext3") (mkdir-p "/fs/boot/grub") (symlink grub.cfg "/fs/boot/grub/grub.cfg") @@ -379,7 +379,7 @@ such as /etc files." (and (zero? (system* grub "--no-floppy" "--boot-directory" "/fs/boot" - "/dev/vda")) + "/dev/sda")) (zero? (system* umount "/fs")) (reboot)))))))) #:system system diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 69cb58763f..b9fc9b1523 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -81,10 +81,15 @@ (unless (file-exists? (scope "dev")) (mkdir (scope "dev"))) - ;; Make the device nodes for QEMU's hard disk and partitions. - (mknod (scope "dev/vda") 'block-special #o644 (device-number 8 0)) - (mknod (scope "dev/vda1") 'block-special #o644 (device-number 8 1)) - (mknod (scope "dev/vda2") 'block-special #o644 (device-number 8 2)) + ;; Make the device nodes for SCSI disks. + (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0)) + (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1)) + (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2)) + + ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM. + (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0)) + (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1)) + (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2)) ;; TTYs. (mknod (scope "dev/tty") 'char-special #o600 -- cgit v1.2.3 From 4919d68432c69d386300053b0de178f9efb0334f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 12:21:10 +0100 Subject: gnu: linux-initrd: Recognize 9p file systems. * gnu/system/linux-initrd.scm (qemu-initrd)[virtio-9p-modules]: New variable. [linux-modules]: Append VIRTIO-9P-MODULES when a 9p file system is in MOUNTS. * guix/build/linux-initrd.scm (mount-qemu-9p): New procedure. (boot-system): Recognize '9p' in MOUNTS, and use 'mount-qemu-9p'. --- gnu/system/linux-initrd.scm | 15 ++++++++++++--- guix/build/linux-initrd.scm | 18 ++++++++++++++++-- 2 files changed, 28 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 408fb9f211..1cc1d3b147 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -207,11 +207,20 @@ exception and backtrace!)." ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) + (define virtio-9p-modules + ;; Modules for the 9p paravirtualized file system. + '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) + (define linux-modules ;; Modules added to the initrd and loaded from the initrd. - (if (assoc-ref mounts 'cifs) - cifs-modules - '())) + `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" + "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" + ,@(if (assoc-ref mounts 'cifs) + cifs-modules + '()) + ,@(if (assoc-ref mounts '9p) + virtio-9p-modules + '()))) (expression->initrd `(begin diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b9fc9b1523..7b22354f70 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ make-essential-device-nodes configure-qemu-networking mount-qemu-smb-share + mount-qemu-9p bind-mount load-linux-module* device-number @@ -145,6 +146,17 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our (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")))) + (define (bind-mount source target) "Bind-mount SOURCE at TARGET." (define MS_BIND 4096) ; from libc's @@ -242,8 +254,10 @@ the new root." (let ((target (string-append "/root/" target))) (mkdir-p target) (mount-qemu-smb-share source target))) - ;; TODO: Add 9p. - ) + (('9p source target) + (let ((target (string-append "/root/" target))) + (mkdir-p target) + (mount-qemu-9p source target)))) mounts) (when guile-modules-in-chroot? -- cgit v1.2.3 From 44ddf33ed5b86fd79921aba5572a82c2a940808c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 31 Jan 2014 14:26:30 +0100 Subject: gnu: linux-initrd: Allow the root file system to be volatile. * gnu/system/linux-initrd.scm (qemu-initrd): Add 'volatile-root?' parameter. * guix/build/linux-initrd.scm (boot-system): Likewise. Honor it. --- gnu/system/linux-initrd.scm | 9 +++++++-- guix/build/linux-initrd.scm | 35 +++++++++++++++++++++++++++++++++-- 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 1cc1d3b147..9520473d01 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -191,6 +191,7 @@ list of Guile module names to be embedded in the initrd." (define* (qemu-initrd #:key guile-modules-in-chroot? + volatile-root? (mounts `((cifs "/store" ,(%store-prefix)) (cifs "/xchg" "/xchg")))) "Return a monadic derivation that builds an initrd for use in a QEMU guest @@ -202,7 +203,10 @@ be mounted atop the root file system, where each item has the form: 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!)." +exception and backtrace!). + +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost." (define cifs-modules ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) @@ -229,7 +233,8 @@ exception and backtrace!)." (boot-system #:mounts ',mounts #:linux-modules ',linux-modules #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot?)) + #:guile-modules-in-chroot? ',guile-modules-in-chroot? + #:volatile-root? ',volatile-root?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 7b22354f70..d317f850f2 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -24,6 +24,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line @@ -179,6 +180,7 @@ the last argument of `mknod'." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? + 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 @@ -191,7 +193,10 @@ MOUNTS must be a list of elements of the form: (FILE-SYSTEM-TYPE SOURCE TARGET) When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in -the new root." +the new root. + +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost." (define (resolve file) ;; If FILE is a symlink to an absolute file name, resolve it as if we were ;; under /root. @@ -201,6 +206,8 @@ the new root." (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") @@ -236,12 +243,36 @@ the new root." (if root (catch #t (lambda () - (mount root "/root" "ext3")) + (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. + ) + (mount root "/root" "ext3"))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) (start-repl))) (mount "none" "/root" "tmpfs")) + (mount-essential-file-systems #:root "/root") (unless (file-exists? "/root/dev") -- cgit v1.2.3 From c04c6ff64c1dd3f9cbd1d32763d46b480e56eb59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 1 Feb 2014 01:07:14 +0100 Subject: gnu: linux-initrd: Make /dev/{mem,kmem}. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make dev/{mem,kmem}. --- 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 d317f850f2..ac7806cc3b 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -93,6 +93,10 @@ (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1)) (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2)) + ;; Memory (used by Xorg's VESA driver.) + (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1)) + (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2)) + ;; TTYs. (mknod (scope "dev/tty") 'char-special #o600 (device-number 5 0)) -- cgit v1.2.3 From 1c2215108b4f0cd849da08cd8d2896680958d8c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 1 Feb 2014 02:22:23 +0100 Subject: gnu: linux-initrd: Build /dev/input devices. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make dev/input devices. --- guix/build/linux-initrd.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index ac7806cc3b..5bf20fa6df 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -97,6 +97,13 @@ (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1)) (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2)) + ;; Inputs (used by Xorg.) + (unless (file-exists? (scope "dev/input")) + (mkdir (scope "dev/input"))) + (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63)) + (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32)) + (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64)) + ;; TTYs. (mknod (scope "dev/tty") 'char-special #o600 (device-number 5 0)) -- cgit v1.2.3 From 92cb2e28884ab6ecc5c113ef54eb5aeebae9bb2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Feb 2014 01:32:50 +0100 Subject: offload: Have 'build-machines' honor its argument. * guix/scripts/offload.scm (build-machines): Honor FILE. --- guix/scripts/offload.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1f68160785..00a145e5e9 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -108,7 +108,7 @@ determined." (save-module-excursion (lambda () (set-current-module %user-module) - (primitive-load %machine-file)))) + (primitive-load file)))) (lambda args (match args (('system-error . _) @@ -117,10 +117,10 @@ determined." (if (= ENOENT err) '() (leave (_ "failed to open machine file '~a': ~a~%") - %machine-file (strerror err))))) + file (strerror err))))) (_ (leave (_ "failed to load machine file '~a': ~s~%") - %machine-file args)))))) + file args)))))) (define (open-ssh-gateway machine) "Initiate an SSH connection gateway to MACHINE, and return the PID of the -- cgit v1.2.3 From 45adbd624f920d315259b102b923728d655a1efa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Feb 2014 23:12:54 +0100 Subject: monads: Add 'text-file*'. * guix/monads.scm (text-file*): New procedure. * tests/monads.scm ("text-file*"): New test. * doc/guix.texi (The Store Monad): Change example since the previous one would erroneously fail to retain a reference to Coreutils. Document 'text-file*'. --- doc/guix.texi | 48 ++++++++++++++++++++++++++++++++++++------------ guix/monads.scm | 53 ++++++++++++++++++++++++++++++++++++++++++++++++++++- tests/monads.scm | 26 +++++++++++++++++++++++++- 3 files changed, 113 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 91fa07f1a8..28b1cb8bd7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1590,23 +1590,22 @@ in a monad---values that carry this additional context---are called Consider this ``normal'' procedure: @example -(define (profile.sh store) - ;; Return the name of a shell script in the store that - ;; initializes the 'PATH' environment variable. - (let* ((drv (package-derivation store coreutils)) - (out (derivation->output-path drv))) - (add-text-to-store store "profile.sh" - (format #f "export PATH=~a/bin" out)))) +(define (sh-symlink store) + ;; Return a derivation that symlinks the 'bash' executable. + (let* ((drv (package-derivation store bash)) + (out (derivation->output-path drv)) + (sh (string-append out "/bin/bash"))) + (build-expression->derivation store "sh" + `(symlink ,sh %output)))) @end example Using @code{(guix monads)}, it may be rewritten as a monadic function: @example -(define (profile.sh) +(define (sh-symlink) ;; Same, but return a monadic value. - (mlet %store-monad ((bin (package-file coreutils "bin"))) - (text-file "profile.sh" - (string-append "export PATH=" bin)))) + (mlet %store-monad ((sh (package-file bash "bin"))) + (derivation-expression "sh" `(symlink ,sh %output)))) @end example There are two things to note in the second version: the @code{store} @@ -1672,7 +1671,32 @@ open store connection. @deffn {Monadic Procedure} text-file @var{name} @var{text} Return as a monadic value the absolute file name in the store of the file -containing @var{text}. +containing @var{text}, a string. +@end deffn + +@deffn {Monadic Procedure} text-file* @var{name} @var{text} @dots{} +Return as a monadic value a derivation that builds a text file +containing all of @var{text}. @var{text} may list, in addition to +strings, packages, derivations, and store file names; the resulting +store file holds references to all these. + +This variant should be preferred over @code{text-file} anytime the file +to create will reference items from the store. This is typically the +case when building a configuration file that embeds store file names, +like this: + +@example +(define (profile.sh) + ;; Return the name of a shell script in the store that + ;; initializes the 'PATH' environment variable. + (text-file* "profile.sh" + "export PATH=" coreutils "/bin:" + grep "/bin:" sed "/bin\n")) +@end example + +In this example, the resulting @file{/nix/store/@dots{}-profile.sh} file +will references @var{coreutils}, @var{grep}, and @var{sed}, thereby +preventing them from being garbage-collected during its lifetime. @end deffn @deffn {Monadic Procedure} package-file @var{package} [@var{file}] @ diff --git a/guix/monads.scm b/guix/monads.scm index ad80a0698d..db8b645402 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -23,6 +23,7 @@ #:use-module ((system syntax) #:select (syntax-local-binding)) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:export (;; Monads. @@ -53,6 +54,7 @@ store-lift run-with-store text-file + text-file* package-file package->derivation built-derivations @@ -305,10 +307,59 @@ in the store monad." (define* (text-file name text) "Return as a monadic value the absolute file name in the store of the file -containing TEXT." +containing TEXT, a string." (lambda (store) (add-text-to-store store name text '()))) +(define* (text-file* name #:rest text) + "Return as a monadic value a derivation that builds a text file containing +all of TEXT. TEXT may list, in addition to strings, packages, derivations, +and store file names; the resulting store file holds references to all these." + (define inputs + ;; Transform packages and derivations from TEXT into a valid input list. + (filter-map (match-lambda + ((? package? p) `("x" ,p)) + ((? derivation? d) `("x" ,d)) + ((x ...) `("x" ,@x)) + ((? string? s) + (and (direct-store-path? s) `("x" ,s))) + (x x)) + text)) + + (define (computed-text text inputs) + ;; Using the lowered INPUTS, return TEXT with derivations replaced with + ;; their output file name. + (define (real-string? s) + (and (string? s) (not (direct-store-path? s)))) + + (let loop ((inputs inputs) + (text text) + (result '())) + (match text + (() + (string-concatenate-reverse result)) + (((? real-string? head) rest ...) + (loop inputs rest (cons head result))) + ((_ rest ...) + (match inputs + (((_ (? derivation? drv) sub-drv ...) inputs ...) + (loop inputs rest + (cons (apply derivation->output-path drv + sub-drv) + result))) + (((_ file) inputs ...) + ;; FILE is the result of 'add-text-to-store' or so. + (loop inputs rest (cons file result)))))))) + + (define (builder inputs) + `(call-with-output-file (assoc-ref %outputs "out") + (lambda (port) + (display ,(computed-text text inputs) port)))) + + (mlet %store-monad ((inputs (lower-inputs inputs))) + (derivation-expression name (builder inputs) + #:inputs inputs))) + (define* (package-file package #:optional file #:key (system (%current-system)) (output "out")) diff --git a/tests/monads.scm b/tests/monads.scm index d3f78e1568..b51e705f01 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -126,6 +126,30 @@ (readlink (string-append out "/guile-rocks")))))) #:guile-for-build (package-derivation %store %bootstrap-guile))) +(test-assert "text-file*" + (let ((references (store-lift references))) + (run-with-store %store + (mlet* %store-monad + ((drv (package->derivation %bootstrap-guile)) + (guile -> (derivation->output-path drv)) + (file (text-file "bar" "This is bar.")) + (text (text-file* "foo" + %bootstrap-guile "/bin/guile " + `(,%bootstrap-guile "out") "/bin/guile " + drv "/bin/guile " + file)) + (done (built-derivations (list text))) + (out -> (derivation->output-path text)) + (refs (references out))) + ;; Make sure we get the right references and the right content. + (return (and (lset= string=? refs (list guile file)) + (equal? (call-with-input-file out get-string-all) + (string-append guile "/bin/guile " + guile "/bin/guile " + guile "/bin/guile " + file))))) + #:guile-for-build (package-derivation %store %bootstrap-guile)))) + (test-assert "mapm" (every (lambda (monad run) (with-monad monad -- cgit v1.2.3 From 26fc862a61adb231c57982ce687cac6931fd1e7e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 9 Feb 2014 23:28:18 +0100 Subject: gnu: linux-initrd: When booting, chdir to the new root before calling 'chroot'. * guix/build/linux-initrd.scm (boot-system): Add 'chdir' call right before 'chroot'. --- guix/build/linux-initrd.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 5bf20fa6df..80ce679496 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -318,6 +318,7 @@ to it are lost." (if to-load (begin (format #t "loading '~a'...\n" to-load) + (chdir "/root") (chroot "/root") ;; TODO: Remove /lib, /share, and /loader.go. (catch #t -- cgit v1.2.3 From 2de227af4bca7204e93f48d52555d576c25f1ca9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Feb 2014 00:03:34 +0100 Subject: download: Provide a 'User-Agent' field in HTTP requests. Fixes . Reported by Raimon Grau . * guix/build/download.scm (http-fetch)[headers]: New variable. Pass it as #:headers or #:extra-headers to 'http-get' and 'http-get*'. --- guix/build/download.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index ac2086d96e..f9715e10f7 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -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. ;;; @@ -201,6 +201,12 @@ which is not available during bootstrap." (string>? (micro-version) "7") (string>? (version) "2.0.7"))) + (define headers + ;; Some web sites, such as http://dist.schmorp.de, would block you if + ;; there's no 'User-Agent' header, presumably on the assumption that + ;; you're a spammer. So work around that. + '((User-Agent . "GNU Guile"))) + (let*-values (((connection) (open-connection-for-uri uri)) ((resp bv-or-port) @@ -210,11 +216,14 @@ which is not available during bootstrap." ;; version. So keep this compatibility hack for now. (if post-2.0.7? (http-get uri #:port connection #:decode-body? #f - #:streaming? #t) + #:streaming? #t + #:headers headers) (if (module-defined? (resolve-interface '(web client)) 'http-get*) - (http-get* uri #:port connection #:decode-body? #f) - (http-get uri #:port connection #:decode-body? #f)))) + (http-get* uri #:port connection #:decode-body? #f + #:headers headers) + (http-get uri #:port connection #:decode-body? #f + #:extra-headers headers)))) ((code) (response-code resp)) ((size) -- cgit v1.2.3 From 6ede17ca69a68457c7492601e24ef02fb62487f8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Feb 2014 00:05:39 +0100 Subject: union: Do not compare directories upon collision. * guix/build/union.scm (file=?): Return #f if FILE1 and FILE2 are not regular files. Fixes a bug whereby collisions among directories would lead to the invocation of 'file=?' and thus 'call-with-input-file' on directories. Reported by Mark H. Weaver . --- guix/build/union.scm | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/build/union.scm b/guix/build/union.scm index 1b09da45c7..6e2b296d81 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -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. ;;; @@ -103,21 +103,26 @@ single leaf." (leaf leaf)))) (define (file=? file1 file2) - "Return #t if the contents of FILE1 and FILE2 are identical, #f otherwise." - (and (= (stat:size (stat file1)) (stat:size (stat file2))) - (call-with-input-file file1 - (lambda (port1) - (call-with-input-file file2 - (lambda (port2) - (define len 8192) - (define buf1 (make-bytevector len)) - (define buf2 (make-bytevector len)) - (let loop () - (let ((n1 (get-bytevector-n! port1 buf1 0 len)) - (n2 (get-bytevector-n! port2 buf2 0 len))) - (and (equal? n1 n2) - (or (eof-object? n1) - (loop))))))))))) + "Return #t if FILE1 and FILE2 are regular files and their contents are +identical, #f otherwise." + (let ((st1 (stat file1)) + (st2 (stat file2))) + (and (eq? (stat:type st1) 'regular) + (eq? (stat:type st2) 'regular) + (= (stat:size st1) (stat:size st2)) + (call-with-input-file file1 + (lambda (port1) + (call-with-input-file file2 + (lambda (port2) + (define len 8192) + (define buf1 (make-bytevector len)) + (define buf2 (make-bytevector len)) + (let loop () + (let ((n1 (get-bytevector-n! port1 buf1 0 len)) + (n2 (get-bytevector-n! port2 buf2 0 len))) + (and (equal? n1 n2) + (or (eof-object? n1) + (loop)))))))))))) (define* (union-build output directories #:key (log-port (current-error-port))) -- cgit v1.2.3 From 99fbddf9a623757e39d88bfb431f8f7d6f24b75b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Feb 2014 23:30:09 +0100 Subject: store: Change 'export-paths' to always export in topological order. * guix/store.scm (export-paths): Pass PATHS through 'topologically-sorted' before iterating. * tests/store.scm ("export/import paths, ensure topological order"): New test. --- guix/store.scm | 6 +++--- tests/store.scm | 19 +++++++++++++++++++ 2 files changed, 22 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index eca0de7d97..b9b9d9e55a 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -732,10 +732,10 @@ is raised if the set of paths read from PORT is not signed (as per (= 1 (read-int s)))) (define* (export-paths server paths port #:key (sign? #t)) - "Export the store paths listed in PATHS to PORT, signing them if SIGN? -is true." + "Export the store paths listed in PATHS to PORT, in topological order, +signing them if SIGN? is true." (let ((s (nix-server-socket server))) - (let loop ((paths paths)) + (let loop ((paths (topologically-sorted server paths))) (match paths (() (write-int 0 port)) diff --git a/tests/store.scm b/tests/store.scm index a61d449fb4..7b0f3249d2 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -398,6 +398,25 @@ Deriver: ~a~%" get-string-all)) files))))))) +(test-assert "export/import paths, ensure topological order" + (let* ((file1 (add-text-to-store %store "foo" (random-text))) + (file2 (add-text-to-store %store "bar" (random-text) + (list file1))) + (files (list file1 file2)) + (dump1 (call-with-bytevector-output-port + (cute export-paths %store (list file1 file2) <>))) + (dump2 (call-with-bytevector-output-port + (cute export-paths %store (list file2 file1) <>)))) + (delete-paths %store files) + (and (every (negate file-exists?) files) + (bytevector=? dump1 dump2) + (let* ((source (open-bytevector-input-port dump1)) + (imported (import-paths %store source))) + (and (equal? imported (list file1 file2)) + (every file-exists? files) + (null? (references %store file1)) + (equal? (list file1) (references %store file2))))))) + (test-assert "import corrupt path" (let* ((text (random-text)) (file (add-text-to-store %store "text" text)) -- cgit v1.2.3 From d66b704b51dc9a63eabbaee994f98101d8387ae6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 11 Feb 2014 23:16:28 +0100 Subject: store: Add comments for the stracer. * guix/store.scm (%worker-magic-1, %worker-magic-2): Add comments. --- guix/store.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index b9b9d9e55a..8e88c5f86d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -100,8 +100,8 @@ (define %protocol-version #x10c) -(define %worker-magic-1 #x6e697863) -(define %worker-magic-2 #x6478696f) +(define %worker-magic-1 #x6e697863) ; "nixc" +(define %worker-magic-2 #x6478696f) ; "dxio" (define (protocol-major magic) (logand magic #xff00)) -- cgit v1.2.3 From bdff90a16a99ad95bd76a14847e1507454990588 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 11 Feb 2014 23:18:41 +0100 Subject: guix build: Move 'set-build-options' call earlier. * guix/scripts/build.scm (guix-build): Move 'set-build-options' call before 'show-what-to-build'. --- guix/scripts/build.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7cb3710853..b153da8493 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -279,11 +279,6 @@ build." (_ #f)) opts))) - (unless (assoc-ref opts 'log-file?) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?))) - ;; TODO: Add more options. (set-build-options store #:keep-failed? (assoc-ref opts 'keep-failed?) @@ -294,6 +289,11 @@ build." #:max-silent-time (assoc-ref opts 'max-silent-time) #:verbosity (assoc-ref opts 'verbosity)) + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?))) + (cond ((assoc-ref opts 'log-file?) (for-each (lambda (file) (let ((log (log-file store file))) -- cgit v1.2.3 From e7fc17b592a0d25c18fbc6774b1f8a6d2a9bbc69 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Feb 2014 00:13:06 +0100 Subject: guix build: Factorize common options. * guix/scripts/build.scm (show-build-options-help, set-build-options-from-command-line): New procedures. (show-help): Remove description of --dry-run, --fallback, --no-substitutes, --max-silent-time, and --cores. Call 'show-build-options-help'. (%standard-build-options): New variable. (%options): Remove --dry-run, --fallback, --no-substitutes, --verbosity, --max-silent-time, and --cores. Add %STANDARD-BUILD-OPTIONS. (guix-build): Use 'set-build-options-from-command-line' instead of 'set-build-options'. * guix/scripts/archive.scm (show-help): Remove description of --dry-run, --fallback, --no-substitutes, --max-silent-time, and --cores. Call 'show-build-options-help'. (%options): Remove --dry-run, --fallback, --no-substitutes, --verbosity, --max-silent-time, and --cores. Add %STANDARD-BUILD-OPTIONS. (export-from-store): Call 'set-build-options-from-command-line' instead of 'set-build-options. --- guix/scripts/archive.scm | 147 ++++++++++++++--------------------- guix/scripts/build.scm | 198 +++++++++++++++++++++++++++-------------------- 2 files changed, 169 insertions(+), 176 deletions(-) (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 32690c6b45..4788468584 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -71,17 +71,10 @@ Export/import one or more packages from/to the store.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " - -n, --dry-run do not build the derivations")) - (display (_ " - --fallback fall back to building when the substituter fails")) - (display (_ " - --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " - --max-silent-time=SECONDS - mark the build as failed after SECONDS of silence")) - (display (_ " - -c, --cores=N allow the use of up to N CPU cores for the build")) + + (newline) + (show-build-options-help) + (newline) (display (_ " -h, --help display this help and exit")) @@ -92,81 +85,60 @@ Export/import one or more packages from/to the store.\n")) (define %options ;; Specifications of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix build"))) + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix build"))) - (option '("export") #f #f - (lambda (opt name arg result) - (alist-cons 'export #t result))) - (option '("import") #f #f - (lambda (opt name arg result) - (alist-cons 'import #t result))) - (option '("missing") #f #f - (lambda (opt name arg result) - (alist-cons 'missing #t result))) - (option '("generate-key") #f #t - (lambda (opt name arg result) - (catch 'gcry-error - (lambda () - (let ((params - (string->canonical-sexp - (or arg "(genkey (rsa (nbits 4:4096)))")))) - (alist-cons 'generate-key params result))) - (lambda args - (leave (_ "invalid key generation parameters: ~s~%") - arg))))) - (option '("authorize") #f #f - (lambda (opt name arg result) - (alist-cons 'authorize #t result))) + (option '("export") #f #f + (lambda (opt name arg result) + (alist-cons 'export #t result))) + (option '("import") #f #f + (lambda (opt name arg result) + (alist-cons 'import #t result))) + (option '("missing") #f #f + (lambda (opt name arg result) + (alist-cons 'missing #t result))) + (option '("generate-key") #f #t + (lambda (opt name arg result) + (catch 'gcry-error + (lambda () + (let ((params + (string->canonical-sexp + (or arg "(genkey (rsa (nbits 4:4096)))")))) + (alist-cons 'generate-key params result))) + (lambda args + (leave (_ "invalid key generation parameters: ~s~%") + arg))))) + (option '("authorize") #f #f + (lambda (opt name arg result) + (alist-cons 'authorize #t result))) - (option '(#\S "source") #f #f - (lambda (opt name arg result) - (alist-cons 'source? #t result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '("target") #t #f - (lambda (opt name arg result) - (alist-cons 'target arg - (alist-delete 'target result eq?)))) - (option '(#\e "expression") #t #f - (lambda (opt name arg result) - (alist-cons 'expression arg result))) - (option '(#\c "cores") #t #f - (lambda (opt name arg result) - (let ((c (false-if-exception (string->number arg)))) - (if c - (alist-cons 'cores c result) - (leave (_ "~a: not a number~%") arg))))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result) - (alist-cons 'dry-run? #t result))) - (option '("fallback") #f #f - (lambda (opt name arg result) - (alist-cons 'fallback? #t - (alist-delete 'fallback? result)))) - (option '("no-substitutes") #f #f - (lambda (opt name arg result) - (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)))) - (option '("max-silent-time") #t #f - (lambda (opt name arg result) - (alist-cons 'max-silent-time (string->number* arg) - result))) - (option '(#\r "root") #t #f - (lambda (opt name arg result) - (alist-cons 'gc-root arg result))) - (option '("verbosity") #t #f - (lambda (opt name arg result) - (let ((level (string->number arg))) - (alist-cons 'verbosity level - (alist-delete 'verbosity result))))))) + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + + %standard-build-options)) (define (options->derivations+files store opts) "Given OPTS, the result of 'args-fold', return a list of derivations to @@ -219,16 +191,11 @@ build and a list of store files to transfer." resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) + (set-build-options-from-command-line store opts) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) - (set-build-options store - #:build-cores (or (assoc-ref opts 'cores) 0) - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:max-silent-time (assoc-ref opts 'max-silent-time)) - (if (or (assoc-ref opts 'dry-run?) (build-derivations store drv)) (export-paths store files (current-output-port)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index b153da8493..4a00505022 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -34,6 +34,11 @@ #:use-module (srfi srfi-37) #:autoload (gnu packages) (find-best-packages-by-name) #:export (derivation-from-expression + + %standard-build-options + set-build-options-from-command-line + show-build-options-help + guix-build)) (define (derivation-from-expression store str package-derivation @@ -101,30 +106,13 @@ present, return the preferred newest version." ;;; -;;; Command-line options. +;;; Standard command-line build options. ;;; -(define %default-options - ;; Alist of default option values. - `((system . ,(%current-system)) - (substitutes? . #t) - (build-hook? . #t) - (max-silent-time . 3600) - (verbosity . 0))) - -(define (show-help) - (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... -Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) - (display (_ " - -e, --expression=EXPR build the package or derivation EXPR evaluates to")) - (display (_ " - -S, --source build the packages' source derivations")) - (display (_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " - --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " - -d, --derivations return the derivation paths of the given packages")) +(define (show-build-options-help) + "Display on the current output port help about the standard command-line +options handled by 'set-build-options-from-command-line', and listed in +'%standard-build-options'." (display (_ " -K, --keep-failed keep build tree of failed builds")) (display (_ " @@ -138,62 +126,29 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) - (display (_ " - -c, --cores=N allow the use of up to N CPU cores for the build")) - (display (_ " - -r, --root=FILE make FILE a symlink to the result, and register it - as a garbage collector root")) (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " - --log-file return the log file names for the given derivations")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) + -c, --cores=N allow the use of up to N CPU cores for the build"))) -(define %options - ;; Specifications of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix build"))) +(define (set-build-options-from-command-line store opts) + "Given OPTS, an alist as returned by 'args-fold' given +'%standard-build-options', set the corresponding build options on STORE." + ;; TODO: Add more options. + (set-build-options store + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:use-build-hook? (assoc-ref opts 'build-hook?) + #:max-silent-time (assoc-ref opts 'max-silent-time) + #:verbosity (assoc-ref opts 'verbosity))) - (option '(#\S "source") #f #f - (lambda (opt name arg result) - (alist-cons 'source? #t result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '("target") #t #f - (lambda (opt name arg result) - (alist-cons 'target arg - (alist-delete 'target result eq?)))) - (option '(#\d "derivations") #f #f - (lambda (opt name arg result) - (alist-cons 'derivations-only? #t result))) - (option '(#\e "expression") #t #f - (lambda (opt name arg result) - (alist-cons 'expression arg result))) - (option '(#\K "keep-failed") #f #f +(define %standard-build-options + ;; List of standard command-line options for tools that build something. + (list (option '(#\K "keep-failed") #f #f (lambda (opt name arg result) (alist-cons 'keep-failed? #t result))) - (option '(#\c "cores") #t #f - (lambda (opt name arg result) - (let ((c (false-if-exception (string->number arg)))) - (if c - (alist-cons 'cores c result) - (leave (_ "~a: not a number~%") arg))))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result) - (alist-cons 'dry-run? #t result))) (option '("fallback") #f #f (lambda (opt name arg result) (alist-cons 'fallback? #t @@ -210,17 +165,97 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (alist-cons 'max-silent-time (string->number* arg) result))) - (option '(#\r "root") #t #f - (lambda (opt name arg result) - (alist-cons 'gc-root arg result))) (option '("verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number arg))) (alist-cons 'verbosity level (alist-delete 'verbosity result))))) - (option '("log-file") #f #f + (option '(#\c "cores") #t #f (lambda (opt name arg result) - (alist-cons 'log-file? #t result))))) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... +Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) + (display (_ " + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (_ " + -d, --derivations return the derivation paths of the given packages")) + (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " + --log-file return the log file names for the given derivations")) + (newline) + (show-build-options-help) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix build"))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) + (option '(#\d "derivations") #f #f + (lambda (opt name arg result) + (alist-cons 'derivations-only? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("log-file") #f #f + (lambda (opt name arg result) + (alist-cons 'log-file? #t result))) + + %standard-build-options)) (define (options->derivations store opts) "Given OPTS, the result of 'args-fold', return a list of derivations to @@ -279,16 +314,7 @@ build." (_ #f)) opts))) - ;; TODO: Add more options. - (set-build-options store - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:use-build-hook? (assoc-ref opts 'build-hook?) - #:max-silent-time (assoc-ref opts 'max-silent-time) - #:verbosity (assoc-ref opts 'verbosity)) - + (set-build-options-from-command-line store opts) (unless (assoc-ref opts 'log-file?) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) -- cgit v1.2.3 From 523e48969bd87d26ebbe0a3f4de27257b6d6cb77 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Feb 2014 23:45:58 +0100 Subject: Add 'guix system'. * guix/scripts/system.scm: New file. * Makefile.am (MODULES): Add it. * po/POTFILES.in: Likewise. * doc/guix.texi (Using the Configuration System): Link to "Invoking guix system". (Invoking guix system): New node. --- Makefile.am | 1 + doc/guix.texi | 43 +++++++++++--- guix/scripts/system.scm | 148 ++++++++++++++++++++++++++++++++++++++++++++++++ po/POTFILES.in | 1 + 4 files changed, 185 insertions(+), 8 deletions(-) create mode 100644 guix/scripts/system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 16b28eb181..6ad8eb9914 100644 --- a/Makefile.am +++ b/Makefile.am @@ -77,6 +77,7 @@ MODULES = \ guix/scripts/substitute-binary.scm \ guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ + guix/scripts/system.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/doc/guix.texi b/doc/guix.texi index af84b75108..e6636dc71f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2547,8 +2547,9 @@ instantiated. Then we show how this mechanism can be extended, for instance to support new system services. @menu -* Using the Configuration System:: Customizing your GNU system. -* Defining Services:: Adding new service definitions. +* Using the Configuration System:: Customizing your GNU system. +* Invoking guix system:: Instantiating a system configuration. +* Defining Services:: Adding new service definitions. @end menu @node Using the Configuration System @@ -2614,13 +2615,12 @@ daemon listening on port 2222, and allowing remote @code{root} logins right command-line options, possibly with supporting configuration files generated as needed (@pxref{Defining Services}). -@c TODO: update when that command exists Assuming the above snippet is stored in the @file{my-system-config.scm} -file, the (yet unwritten!) @command{guix system --boot -my-system-config.scm} command instantiates that configuration, and makes -it the default GRUB boot entry. The normal way to change the system's -configuration is by updating this file and re-running the @command{guix -system} command. +file, the @command{guix system boot my-system-config.scm} command +instantiates that configuration, and makes it the default GRUB boot +entry (@pxref{Invoking guix system}). The normal way to change the +system's configuration is by updating this file and re-running the +@command{guix system} command. At the Scheme level, the bulk of an @code{operating-system} declaration is instantiated with the following monadic procedure (@pxref{The Store @@ -2635,6 +2635,33 @@ the packages, configuration files, and other supporting files needed to instantiate @var{os}. @end deffn +@node Invoking guix system +@subsection Invoking @code{guix system} + +Once you have written an operating system declaration, as seen in the +previous section, it can be @dfn{instantiated} using the @command{guix +system} command. The synopsis is: + +@example +guix system @var{options}@dots{} @var{action} @var{file} +@end example + +@var{file} must be the name of a file containing an +@code{operating-system} declaration. @var{action} specifies how the +operating system is instantiate. Currently only one value is supported: + +@table @code +@item vm +@cindex virtual machine +Build a virtual machine that contain the operating system declared in +@var{file}, and return a script to run that virtual machine (VM). + +The VM shares its store with the host system. +@end table + +@var{options} can contain any of the common build options provided by +@command{guix build} (@pxref{Invoking guix build}). + @node Defining Services @subsection Defining Services diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm new file mode 100644 index 0000000000..5bb14c4383 --- /dev/null +++ b/guix/scripts/system.scm @@ -0,0 +1,148 @@ +;;; 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 scripts system) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix monads) + #:use-module (guix scripts build) + #:use-module (gnu system vm) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-system)) + +(define %user-module + ;; Module in which the machine description file is loaded. + (let ((module (make-fresh-user-module))) + (for-each (lambda (iface) + (module-use! module (resolve-interface iface))) + '((gnu system) + (gnu system dmd) + (gnu system shadow))) + module)) + +(define (read-operating-system file) + "Read the operating-system declaration from FILE and return it." + ;; TODO: Factorize. + (catch #t + (lambda () + ;; Avoid ABI incompatibility with the record. + (set! %fresh-auto-compile #t) + + (save-module-excursion + (lambda () + (set-current-module %user-module) + (primitive-load file)))) + (lambda args + (match args + (('system-error . _) + (let ((err (system-error-errno args))) + (leave (_ "failed to open operating system file '~a': ~a~%") + file (strerror err)))) + (_ + (leave (_ "failed to load machine file '~a': ~s~%") + file args)))))) + + +;;; +;;; Options. +;;; + +(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 value for ACTION is 'vm', which builds +a virtual machine of the given operating system.\n")) + (show-build-options-help) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix system"))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + %standard-build-options)) + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + + +;;; +;;; Entry point. +;;; + +(define (guix-system . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (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))) + (let ((action (string->symbol arg))) + (case action + ((vm) (alist-cons 'action action result)) + (else (leave (_ "~a: unknown action~%") + action)))))) + %default-options)) + + (with-error-handling + (let* ((opts (parse-options)) + (file (assoc-ref opts 'argument)) + (os (if file + (read-operating-system file) + (leave (_ "no configuration file specified~%")))) + (mdrv (system-qemu-image/shared-store-script os)) + (store (open-connection)) + (dry? (assoc-ref opts 'dry-run?)) + (drv (run-with-store store mdrv))) + (set-build-options-from-command-line store opts) + (show-what-to-build store (list drv) + #:dry-run? dry? + #:use-substitutes? (assoc-ref opts 'substitutes?)) + + (unless dry? + (build-derivations store (list drv)) + (display (derivation->output-path drv)) + (newline))))) diff --git a/po/POTFILES.in b/po/POTFILES.in index b329f21e92..ef864fe817 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -12,6 +12,7 @@ guix/scripts/hash.scm guix/scripts/pull.scm guix/scripts/substitute-binary.scm guix/scripts/authenticate.scm +guix/scripts/system.scm guix/gnu-maintenance.scm guix/ui.scm guix/http-client.scm -- cgit v1.2.3 From db4fdc04cc05495788ee54ae25baf8cd056917dc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 19 Feb 2014 20:58:24 +0100 Subject: gnu: Introduce the (gnu services ...) modules. * gnu/system/dmd.scm: Remove file. Move contents to... * gnu/services.scm, gnu/services/base.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/xorg.scm: ... here. New files. * gnu/system.scm, gnu/system/vm.scm: Adjust accordingly. * guix/scripts/system.scm (%user-module): Likewise. * doc/guix.texi (Using the Configuration System): Likewise. (Defining Services): Likewise. --- doc/guix.texi | 8 +- gnu-system.am | 11 +- gnu/services.scm | 62 ++++++ gnu/services/base.scm | 176 +++++++++++++++++ gnu/services/dmd.scm | 77 ++++++++ gnu/services/networking.scm | 80 ++++++++ gnu/services/xorg.scm | 186 ++++++++++++++++++ gnu/system.scm | 6 +- gnu/system/dmd.scm | 470 -------------------------------------------- gnu/system/vm.scm | 2 +- guix/scripts/system.scm | 2 +- 11 files changed, 600 insertions(+), 480 deletions(-) create mode 100644 gnu/services.scm create mode 100644 gnu/services/base.scm create mode 100644 gnu/services/dmd.scm create mode 100644 gnu/services/networking.scm create mode 100644 gnu/services/xorg.scm delete mode 100644 gnu/system/dmd.scm (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e6636dc71f..9a0deeac59 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2562,9 +2562,9 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: @findex operating-system @lisp -(use-modules (gnu system) +(use-modules (gnu services base) + (gnu services ssh) ; for 'lsh-service' (gnu system shadow) ; for 'user-account' - (gnu system service) ; for 'lsh-service' (gnu packages base) ; Coreutils, grep, etc. (gnu packages bash) ; Bash (gnu packages admin) ; dmd, Inetutils @@ -2603,7 +2603,7 @@ visible on the system, for all user accounts---i.e., in every user's The @code{services} field lists @dfn{system services} to be made available when the system starts. The @var{%standard-services} list, -from the @code{(gnu system)} module, provides the basic services one +from the @code{(gnu services base)} module, provides the basic services one would expect from a GNU system: a login service (mingetty) on each tty, syslogd, libc's name service cache daemon (nscd), etc. @@ -2666,7 +2666,7 @@ The VM shares its store with the host system. @node Defining Services @subsection Defining Services -The @code{(gnu system dmd)} module defines several procedures that allow +The @code{(gnu services @dots{})} modules define several procedures that allow users to declare the operating system's services (@pxref{Using the Configuration System}). These procedures are @emph{monadic procedures}---i.e., procedures that return a monadic value in the store diff --git a/gnu-system.am b/gnu-system.am index d231cfa57b..857c9bf663 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -70,7 +70,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/fonts.scm \ gnu/packages/fontutils.scm \ gnu/packages/freeipmi.scm \ - gnu/packages/games.scm \ + gnu/packages/games.scm \ gnu/packages/gawk.scm \ gnu/packages/gcal.scm \ gnu/packages/gcc.scm \ @@ -210,7 +210,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/vpn.scm \ gnu/packages/w3m.scm \ gnu/packages/wdiff.scm \ - gnu/packages/web.scm \ + gnu/packages/web.scm \ gnu/packages/wget.scm \ gnu/packages/which.scm \ gnu/packages/wordnet.scm \ @@ -223,8 +223,13 @@ GNU_SYSTEM_MODULES = \ gnu/packages/zile.scm \ gnu/packages/zip.scm \ \ + gnu/services.scm \ + gnu/services/base.scm \ + gnu/services/dmd.scm \ + gnu/services/networking.scm \ + gnu/services/xorg.scm \ + \ gnu/system.scm \ - gnu/system/dmd.scm \ gnu/system/grub.scm \ gnu/system/linux.scm \ gnu/system/linux-initrd.scm \ diff --git a/gnu/services.scm b/gnu/services.scm new file mode 100644 index 0000000000..eccde4e9a3 --- /dev/null +++ b/gnu/services.scm @@ -0,0 +1,62 @@ +;;; 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 (gnu services) + #:use-module (guix records) + #:export (service? + service + service-documentation + service-provision + service-requirement + service-respawn? + service-start + service-stop + service-inputs + service-user-accounts + service-user-groups + service-pam-services)) + +;;; Commentary: +;;; +;;; System services as cajoled by dmd. +;;; +;;; Code: + +(define-record-type* + service make-service + service? + (documentation service-documentation ; string + (default "[No documentation.]")) + (provision service-provision) ; list of symbols + (requirement service-requirement ; list of symbols + (default '())) + (respawn? service-respawn? ; Boolean + (default #t)) + (start service-start) ; expression + (stop service-stop ; expression + (default #f)) + (inputs service-inputs ; list of inputs + (default '())) + (user-accounts service-user-accounts ; list of + (default '())) + (user-groups service-user-groups ; list of + (default '())) + (pam-services service-pam-services ; list of + (default '()))) + +;;; services.scm ends here. diff --git a/gnu/services/base.scm b/gnu/services/base.scm new file mode 100644 index 0000000000..3d684a5bec --- /dev/null +++ b/gnu/services/base.scm @@ -0,0 +1,176 @@ +;;; 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 (gnu services base) + #:use-module (gnu services) + #:use-module (gnu system shadow) ; 'user-account', etc. + #:use-module (gnu system linux) ; 'pam-service', etc. + #:use-module (gnu packages admin) + #:use-module ((gnu packages base) + #:select (glibc-final)) + #:use-module (gnu packages package-management) + #:use-module (guix monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:export (host-name-service + mingetty-service + nscd-service + syslog-service + guix-service)) + +;;; Commentary: +;;; +;;; Base system services---i.e., services that 99% of the users will want to +;;; use. +;;; +;;; Code: + +(define (host-name-service name) + "Return a service that sets the host name to NAME." + (with-monad %store-monad + (return (service + (documentation "Initialize the machine's host name.") + (provision '(host-name)) + (start `(lambda _ + (sethostname ,name))) + (respawn? #f))))) + +(define* (mingetty-service tty + #:key + (motd (text-file "motd" "Welcome.\n")) + (allow-empty-passwords? #t)) + "Return a service to run mingetty on TTY." + (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) + (motd motd)) + (return + (service + (documentation (string-append "Run mingetty on " tty ".")) + (provision (list (symbol-append 'term- (string->symbol tty)))) + + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. + (requirement '(host-name)) + + (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) + (stop `(make-kill-destructor)) + (inputs `(("mingetty" ,mingetty) + ("motd" ,motd))) + + (pam-services + ;; Let 'login' be known to PAM. All the mingetty services will have + ;; that PAM service, but that's fine because they're all identical and + ;; duplicates are removed. + (list (unix-pam-service "login" + #:allow-empty-passwords? allow-empty-passwords? + #:motd motd))))))) + +(define* (nscd-service #:key (glibc glibc-final)) + "Return a service that runs libc's name service cache daemon (nscd)." + (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (return (service + (documentation "Run libc's name service cache daemon (nscd).") + (provision '(nscd)) + (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" + "--foreground")) + (stop `(make-kill-destructor)) + + (respawn? #f) + (inputs `(("glibc" ,glibc))))))) + +(define (syslog-service) + "Return a service that runs 'syslogd' with reasonable default settings." + + ;; Snippet adapted from the GNU inetutils manual. + (define contents " + # Log all kernel messages, authentication messages of + # level notice or higher and anything of level err or + # higher to the console. + # Don't log private authentication messages! + *.err;kern.*;auth.notice;authpriv.none /dev/console + + # Log anything (except mail) of level info or higher. + # Don't log private authentication messages! + *.info;mail.none;authpriv.none /var/log/messages + + # Same, in a different place. + *.info;mail.none;authpriv.none /dev/tty12 + + # The authpriv file has restricted access. + authpriv.* /var/log/secure + + # Log all the mail messages in one place. + mail.* /var/log/maillog +") + + (mlet %store-monad + ((syslog.conf (text-file "syslog.conf" contents)) + (syslogd (package-file inetutils "libexec/syslogd"))) + (return + (service + (documentation "Run the syslog daemon (syslogd).") + (provision '(syslogd)) + (start `(make-forkexec-constructor ,syslogd "--no-detach" + "--rcfile" ,syslog.conf)) + (stop `(make-kill-destructor)) + (inputs `(("inetutils" ,inetutils) + ("syslog.conf" ,syslog.conf))))))) + +(define* (guix-build-accounts count #:key + (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." + (with-monad %store-monad + (return (unfold (cut > <> count) + (lambda (n) + (user-account + (name (format #f "guixbuilder~2,'0d" n)) + (password "!") + (uid (+ first-uid n -1)) + (gid gid) + (comment (format #f "Guix Build User ~2d" n)) + (home-directory "/var/empty") + (shell (package-file shadow "sbin/nologin")) + (inputs `(("shadow" ,shadow))))) + 1+ + 1)))) + +(define* (guix-service #:key (guix guix) (builder-group "guixbuild") + (build-user-gid 30000) (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 ((daemon (package-file guix "bin/guix-daemon")) + (accounts (guix-build-accounts build-accounts + #:gid build-user-gid))) + (return (service + (provision '(guix-daemon)) + (start `(make-forkexec-constructor ,daemon + "--build-users-group" + ,builder-group)) + (stop `(make-kill-destructor)) + (inputs `(("guix" ,guix))) + (user-accounts accounts) + (user-groups (list (user-group + (name builder-group) + (id build-user-gid) + (members (map user-account-name + user-accounts))))))))) + +;;; base.scm ends here diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm new file mode 100644 index 0000000000..21719118eb --- /dev/null +++ b/gnu/services/dmd.scm @@ -0,0 +1,77 @@ +;;; 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 (gnu services dmd) + #:use-module (guix monads) + #:use-module (gnu services) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (dmd-configuration-file)) + +;;; Commentary: +;;; +;;; Instantiating system services as a dmd configuration file. +;;; +;;; Code: + +(define (dmd-configuration-file services etc) + "Return the dmd configuration file for SERVICES, that initializes /etc from +ETC (the name of a directory in the store) on startup." + (define config + `(begin + (use-modules (ice-9 ftw)) + + (register-services + ,@(map (lambda (service) + `(make + #:docstring ',(service-documentation service) + #:provides ',(service-provision service) + #:requires ',(service-requirement service) + #:respawn? ',(service-respawn? service) + #:start ,(service-start service) + #: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/nix/gcroots/etc-directory") + (symlink ,etc "/var/nix/gcroots/etc-directory")) + + (format #t "starting services...~%") + (for-each start ',(append-map service-provision services)))) + + (text-file "dmd.conf" (object->string config))) + +;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm new file mode 100644 index 0000000000..317800db50 --- /dev/null +++ b/gnu/services/networking.scm @@ -0,0 +1,80 @@ +;;; 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 (gnu services networking) + #:use-module (gnu services) + #:use-module (gnu packages admin) + #:use-module (gnu packages linux) + #:use-module (guix monads) + #:export (static-networking-service)) + +;;; Commentary: +;;; +;;; Networking services. +;;; +;;; Code: + +(define* (static-networking-service interface ip + #:key + gateway + (name-servers '()) + (inetutils inetutils) + (net-tools net-tools)) + "Return a service that starts INTERFACE with address IP. If GATEWAY is +true, it must be a string specifying the default network gateway." + + ;; TODO: Eventually we should do this using Guile's networking procedures, + ;; like 'configure-qemu-networking' does, but the patch that does this is + ;; not yet in stock Guile. + (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) + (route (package-file net-tools "sbin/route"))) + (return + (service + (documentation + (string-append "Set up networking on the '" interface + "' interface using a static IP address.")) + (provision '(networking)) + (start `(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* ,ifconfig ,interface ,ip "up")) + ,(if gateway + `(zero? (system* ,route "add" "-net" "default" + "gw" ,gateway)) + #t) + ,(if (pair? name-servers) + `(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + ',name-servers))) + #t)))) + (stop `(lambda _ + ;; Return #f is successfully stopped. + (not (and (system* ,ifconfig ,interface "down") + (system* ,route "del" "-net" "default"))))) + (respawn? #f) + (inputs `(("inetutils" ,inetutils) + ,@(if gateway + `(("net-tools" ,net-tools)) + '()))))))) + +;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm new file mode 100644 index 0000000000..702be27714 --- /dev/null +++ b/gnu/services/xorg.scm @@ -0,0 +1,186 @@ +;;; 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 (gnu services xorg) + #:use-module (gnu services) + #:use-module (gnu system linux) ; 'pam-service' + #:use-module ((gnu packages base) #:select (guile-final)) + #:use-module (gnu packages xorg) + #:use-module (gnu packages gl) + #:use-module (gnu packages slim) + #:use-module (gnu packages ratpoison) + #:use-module (gnu packages admin) + #:use-module (gnu packages bash) + #:use-module (guix monads) + #:use-module (guix derivations) + #:export (xorg-start-command + slim-service)) + +;;; Commentary: +;;; +;;; Services that relate to the X Window System. +;;; +;;; Code: + +(define* (xorg-start-command #:key + (guile guile-final) + (xorg-server xorg-server)) + "Return a derivation that builds a GUILE script to start the X server from +XORG-SERVER. Usually the X server is started by a login manager." + + (define (xserver.conf) + (text-file* "xserver.conf" " +Section \"Files\" + FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" + ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" + ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" + ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" + ModulePath \"" xorg-server "/lib/xorg/modules\" + ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" + ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" +EndSection + +Section \"ServerFlags\" + Option \"AllowMouseOpenFail\" \"on"" +EndSection + +Section \"Monitor\" + Identifier \"Monitor[0]\" +EndSection + +Section \"InputClass\" + Identifier \"Generic keyboard\" + MatchIsKeyboard \"on\" + Option \"XkbRules\" \"base\" + Option \"XkbModel\" \"pc104\" +EndSection + +Section \"ServerLayout\" + Identifier \"Layout\" + Screen \"Screen-vesa\" +EndSection + +Section \"Device\" + Identifier \"Device-vesa\" + Driver \"vesa\" +EndSection + +Section \"Screen\" + Identifier \"Screen-vesa\" + Device \"Device-vesa\" +EndSection")) + + (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) + (xorg-bin (package-file xorg-server "bin/X")) + (dri (package-file mesa "lib/dri")) + (xkbcomp-bin (package-file xkbcomp "bin")) + (xkb-dir (package-file xkeyboard-config + "share/X11/xkb")) + (config (xserver.conf))) + (define builder + ;; Write a small wrapper around the X server. + `(let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) + (write '(begin + (setenv "XORG_DRI_DRIVER_PATH" ,dri) + (setenv "XKB_BINDIR" ,xkbcomp-bin) + + (apply execl + + ,xorg-bin "-ac" "-logverbose" "-verbose" + "-xkbdir" ,xkb-dir + "-config" ,(derivation->output-path config) + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line)))) + port))) + (chmod out #o555) + #t)) + + (mlet %store-monad ((inputs (lower-inputs + `(("xorg" ,xorg-server) + ("xkbcomp" ,xkbcomp) + ("xkeyboard-config" ,xkeyboard-config) + ("mesa" ,mesa) + ("guile" ,guile) + ("xorg.conf" ,config))))) + (derivation-expression "start-xorg" builder + #:inputs inputs)))) + +(define* (slim-service #:key (slim slim) + (allow-empty-passwords? #t) auto-login? + (default-user "") + (xauth xauth) (dmd dmd) (bash bash) + startx) + "Return a service that spawns the SLiM graphical login manager, which in +turn start the X display server with STARTX, a command as returned by +'xorg-start-command'. + +When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. +When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." + (define (slim.cfg) + ;; TODO: Run "bash -login ~/.xinitrc %session". + (mlet %store-monad ((startx (or startx (xorg-start-command)))) + (text-file* "slim.cfg" " +default_path /run/current-system/bin +default_xserver " startx " +xserver_arguments :0 vt7 +xauth_path " xauth "/bin/xauth +authfile /var/run/slim.auth + +# The login command. '%session' is replaced by the chosen session name, one +# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. +login_cmd exec " ratpoison "/bin/ratpoison + +halt_cmd " dmd "/sbin/halt +reboot_cmd " dmd "/sbin/reboot +" (if auto-login? + (string-append "auto_login yes\ndefault_user " default-user) + "")))) + + (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) + (bash-bin (package-file bash "bin/bash")) + (slim.cfg (slim.cfg))) + (return + (service + (documentation "Xorg display server") + (provision '(xorg-server)) + (requirement '(host-name)) + (start + ;; XXX: Work around the inability to specify env. vars. directly. + `(make-forkexec-constructor + ,bash-bin "-c" + ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) + " " slim-bin + " -nodaemon"))) + (stop `(make-kill-destructor)) + (inputs `(("slim" ,slim) + ("slim.cfg" ,slim.cfg) + ("bash" ,bash))) + (respawn? #t) + (pam-services + ;; Tell PAM about 'slim'. + (list (unix-pam-service + "slim" + #:allow-empty-passwords? allow-empty-passwords?))))))) + +;;; xorg.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index 6918d5bcb8..f05b7a092a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -26,7 +26,11 @@ #:use-module (gnu packages bash) #:use-module (gnu packages admin) #:use-module (gnu packages package-management) - #:use-module (gnu system dmd) + #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu services base) + #:use-module ((gnu services networking) + #:select (static-networking-service)) #:use-module (gnu system grub) #:use-module (gnu system shadow) #:use-module (gnu system linux) diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm deleted file mode 100644 index c1ddec88d6..0000000000 --- a/gnu/system/dmd.scm +++ /dev/null @@ -1,470 +0,0 @@ -;;; 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 (gnu system dmd) - #:use-module (guix store) - #:use-module (guix packages) - #:use-module (guix derivations) - #:use-module (guix records) - #:use-module ((gnu packages base) - #:select (glibc-final guile-final)) - #:use-module ((gnu packages admin) - #:select (dmd mingetty inetutils shadow)) - #:use-module ((gnu packages package-management) - #:select (guix)) - #:use-module ((gnu packages linux) - #:select (net-tools)) - #:use-module (gnu packages xorg) - #:use-module (gnu packages bash) - #:use-module (gnu packages gl) - #:use-module (gnu packages slim) - #:use-module (gnu packages ratpoison) - - #:use-module (gnu system shadow) ; for user accounts/groups - #:use-module (gnu system linux) ; for PAM services - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (guix monads) - #:export (service? - service - service-provision - service-requirement - service-respawn? - service-start - service-stop - service-inputs - service-user-accounts - service-user-groups - service-pam-services - - host-name-service - syslog-service - mingetty-service - nscd-service - guix-service - static-networking-service - xorg-start-command - slim-service - - dmd-configuration-file)) - -;;; Commentary: -;;; -;;; System services as cajoled by dmd. -;;; -;;; Code: - -(define-record-type* - service make-service - service? - (documentation service-documentation ; string - (default "[No documentation.]")) - (provision service-provision) ; list of symbols - (requirement service-requirement ; list of symbols - (default '())) - (respawn? service-respawn? ; Boolean - (default #t)) - (start service-start) ; expression - (stop service-stop ; expression - (default #f)) - (inputs service-inputs ; list of inputs - (default '())) - (user-accounts service-user-accounts ; list of - (default '())) - (user-groups service-user-groups ; list of - (default '())) - (pam-services service-pam-services ; list of - (default '()))) - -(define (host-name-service name) - "Return a service that sets the host name to NAME." - (with-monad %store-monad - (return (service - (documentation "Initialize the machine's host name.") - (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) - (respawn? #f))))) - -(define* (mingetty-service tty - #:key - (motd (text-file "motd" "Welcome.\n")) - (allow-empty-passwords? #t)) - "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) - (return - (service - (documentation (string-append "Run mingetty on " tty ".")) - (provision (list (symbol-append 'term- (string->symbol tty)))) - - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. - (requirement '(host-name)) - - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) - - (pam-services - ;; Let 'login' be known to PAM. All the mingetty services will have - ;; that PAM service, but that's fine because they're all identical and - ;; duplicates are removed. - (list (unix-pam-service "login" - #:allow-empty-passwords? allow-empty-passwords? - #:motd motd))))))) - -(define* (nscd-service #:key (glibc glibc-final)) - "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) - (return (service - (documentation "Run libc's name service cache daemon (nscd).") - (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) - - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) - -(define (syslog-service) - "Return a service that runs 'syslogd' with reasonable default settings." - - ;; Snippet adapted from the GNU inetutils manual. - (define contents " - # Log all kernel messages, authentication messages of - # level notice or higher and anything of level err or - # higher to the console. - # Don't log private authentication messages! - *.err;kern.*;auth.notice;authpriv.none /dev/console - - # Log anything (except mail) of level info or higher. - # Don't log private authentication messages! - *.info;mail.none;authpriv.none /var/log/messages - - # Same, in a different place. - *.info;mail.none;authpriv.none /dev/tty12 - - # The authpriv file has restricted access. - authpriv.* /var/log/secure - - # Log all the mail messages in one place. - mail.* /var/log/maillog -") - - (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) - (return - (service - (documentation "Run the syslog daemon (syslogd).") - (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) - -(define* (guix-build-accounts count #:key - (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." - (with-monad %store-monad - (return (unfold (cut > <> count) - (lambda (n) - (user-account - (name (format #f "guixbuilder~2,'0d" n)) - (password "!") - (uid (+ first-uid n -1)) - (gid gid) - (comment (format #f "Guix Build User ~2d" n)) - (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) - 1+ - 1)))) - -(define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (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 ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) - (return (service - (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) - (user-accounts accounts) - (user-groups (list (user-group - (name builder-group) - (id build-user-gid) - (members (map user-account-name - user-accounts))))))))) - -(define* (static-networking-service interface ip - #:key - gateway - (name-servers '()) - (inetutils inetutils) - (net-tools net-tools)) - "Return a service that starts INTERFACE with address IP. If GATEWAY is -true, it must be a string specifying the default network gateway." - - ;; TODO: Eventually we should do this using Guile's networking procedures, - ;; like 'configure-qemu-networking' does, but the patch that does this is - ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) - (return - (service - (documentation - (string-append "Set up networking on the '" interface - "' interface using a static IP address.")) - (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ - ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) - -(define* (xorg-start-command #:key - (guile guile-final) - (xorg-server xorg-server)) - "Return a derivation that builds a GUILE script to start the X server from -XORG-SERVER. Usually the X server is started by a login manager." - - (define (xserver.conf) - (text-file* "xserver.conf" " -Section \"Files\" - FontPath \"" font-adobe75dpi "/share/font/X11/75dpi\" - ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" - ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" - ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" - ModulePath \"" xorg-server "/lib/xorg/modules\" - ModulePath \"" xorg-server "/lib/xorg/modules/extensions\" - ModulePath \"" xorg-server "/lib/xorg/modules/multimedia\" -EndSection - -Section \"ServerFlags\" - Option \"AllowMouseOpenFail\" \"on"" -EndSection - -Section \"Monitor\" - Identifier \"Monitor[0]\" -EndSection - -Section \"InputClass\" - Identifier \"Generic keyboard\" - MatchIsKeyboard \"on\" - Option \"XkbRules\" \"base\" - Option \"XkbModel\" \"pc104\" -EndSection - -Section \"ServerLayout\" - Identifier \"Layout\" - Screen \"Screen-vesa\" -EndSection - -Section \"Device\" - Identifier \"Device-vesa\" - Driver \"vesa\" -EndSection - -Section \"Screen\" - Identifier \"Screen-vesa\" - Device \"Device-vesa\" -EndSection")) - - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (xorg-bin (package-file xorg-server "bin/X")) - (dri (package-file mesa "lib/dri")) - (xkbcomp-bin (package-file xkbcomp "bin")) - (xkb-dir (package-file xkeyboard-config - "share/X11/xkb")) - (config (xserver.conf))) - (define builder - ;; Write a small wrapper around the X server. - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (setenv "XORG_DRI_DRIVER_PATH" ,dri) - (setenv "XKB_BINDIR" ,xkbcomp-bin) - - (apply execl - - ,xorg-bin "-ac" "-logverbose" "-verbose" - "-xkbdir" ,xkb-dir - "-config" ,(derivation->output-path config) - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line)))) - port))) - (chmod out #o555) - #t)) - - (mlet %store-monad ((inputs (lower-inputs - `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("guile" ,guile) - ("xorg.conf" ,config))))) - (derivation-expression "start-xorg" builder - #:inputs inputs)))) - -(define* (slim-service #:key (slim slim) - (allow-empty-passwords? #t) auto-login? - (default-user "") - (xauth xauth) (dmd dmd) (bash bash) - startx) - "Return a service that spawns the SLiM graphical login manager, which in -turn start the X display server with STARTX, a command as returned by -'xorg-start-command'. - -When ALLOW-EMPTY-PASSWORDS? is true, allow logins with an empty password. -When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." - (define (slim.cfg) - ;; TODO: Run "bash -login ~/.xinitrc %session". - (mlet %store-monad ((startx (or startx (xorg-start-command)))) - (text-file* "slim.cfg" " -default_path /run/current-system/bin -default_xserver " startx " -xserver_arguments :0 vt7 -xauth_path " xauth "/bin/xauth -authfile /var/run/slim.auth - -# The login command. '%session' is replaced by the chosen session name, one -# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " ratpoison "/bin/ratpoison - -halt_cmd " dmd "/sbin/halt -reboot_cmd " dmd "/sbin/reboot -" (if auto-login? - (string-append "auto_login yes\ndefault_user " default-user) - "")))) - - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) - (return - (service - (documentation "Xorg display server") - (provision '(xorg-server)) - (requirement '(host-name)) - (start - ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) - (respawn? #t) - (pam-services - ;; Tell PAM about 'slim'. - (list (unix-pam-service - "slim" - #:allow-empty-passwords? allow-empty-passwords?))))))) - - -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC on startup." - (define config - `(begin - (use-modules (ice-9 ftw)) - - (register-services - ,@(map (match-lambda - (($ documentation provision requirement - respawn? start stop) - `(make - #:docstring ,documentation - #:provides ',provision - #:requires ',requirement - #:respawn? ,respawn? - #:start ,start - #:stop ,stop))) - 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/nix/gcroots/etc-directory") - (symlink ,etc "/var/nix/gcroots/etc-directory")) - - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) - - (text-file "dmd.conf" (object->string config))) - -;;; dmd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index dea7d0599b..3c0ea8a351 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -44,8 +44,8 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system grub) - #:use-module (gnu system dmd) #:use-module (gnu system) + #:use-module (gnu services) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5bb14c4383..7799ccbc47 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -36,7 +36,7 @@ (for-each (lambda (iface) (module-use! module (resolve-interface iface))) '((gnu system) - (gnu system dmd) + (gnu services) (gnu system shadow))) module)) -- cgit v1.2.3 From c6d37be9511f6f10b766541977311341a9115ee9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Feb 2014 12:25:14 +0100 Subject: guix hash: Don't load the whole file in memory. * guix/scripts/hash.scm (guix-hash)[eof->null]: Remove. (guix-hash): Use 'port-sha256' to compute the hash instead of 'get-bytevector-all' and co. --- guix/scripts/hash.scm | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index ca3928b8e3..4e66aa0f3e 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -99,11 +99,6 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (alist-cons 'argument arg result)) %default-options)) - (define (eof->null x) - (if (eof-object? x) - #vu8() - x)) - (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -117,8 +112,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (catch 'system-error (lambda () (format #t "~a~%" - (call-with-input-file file - (compose fmt sha256 eof->null get-bytevector-all)))) + (fmt (call-with-input-file file port-sha256)))) (lambda args (leave (_ "~a~%") (strerror (system-error-errno args)))))) -- cgit v1.2.3 From a93e91ff484005e05491621664ab71f888ad2ba2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Feb 2014 17:37:55 +0100 Subject: nar: 'write-file' can write to non-file ports. * guix/nar.scm (write-contents): Use 'sendfile' only when P is a file port. * tests/nar.scm ("write-file supports non-file output ports"): New test. --- guix/nar.scm | 3 ++- tests/nar.scm | 7 +++++++ 2 files changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/nar.scm b/guix/nar.scm index 4bc2deb229..89a71302e0 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -112,7 +112,8 @@ (write-long-long size p) (call-with-binary-input-file file ;; Use `sendfile' when available (Guile 2.0.8+). - (if (compile-time-value (defined? 'sendfile)) + (if (and (compile-time-value (defined? 'sendfile)) + (file-port? p)) (cut sendfile p <> size 0) (cut dump <> p size))) (write-padding size p)) diff --git a/tests/nar.scm b/tests/nar.scm index 9f21f990c8..7ae8cf0aa7 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -183,6 +183,13 @@ (test-begin "nar") +(test-assert "write-file supports non-file output ports" + (let ((input (string-append (dirname (search-path %load-path "guix.scm")) + "/guix")) + (output (%make-void-port "w"))) + (write-file input output) + #t)) + (test-assert "write-file + restore-file" (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) -- cgit v1.2.3 From c1d52c71aa4fc8085a9737ad1b235ca53a854649 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Feb 2014 17:45:04 +0100 Subject: ui: Handle SRFI-35 '&message' conditions. * guix/ui.scm (call-with-error-handling): Add case for 'message-condition?'. * po/Makevars: Fix typo in comment. --- guix/ui.scm | 6 +++++- po/Makevars | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index d6058f806b..c232b32674 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -31,6 +31,7 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) @@ -186,7 +187,10 @@ General help using GNU software: ")) ((nix-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. (leave (_ "build failed: ~a~%") - (nix-protocol-error-message c)))) + (nix-protocol-error-message c))) + ((message-condition? c) + ;; Normally '&message' error conditions have an i18n'd message. + (leave (_ "~a~%") (gettext (condition-message c))))) ;; Catch EPIPE and the likes. (catch 'system-error thunk diff --git a/po/Makevars b/po/Makevars index ade615a452..d45ea4b979 100644 --- a/po/Makevars +++ b/po/Makevars @@ -6,7 +6,7 @@ subdir = po top_builddir = .. # These options get passed to xgettext. We want to catch standard -# gettext uses, package synopses and descriptions, and SRFI-34 error +# gettext uses, package synopses and descriptions, and SRFI-35 error # condition messages. XGETTEXT_OPTIONS = \ --language=Scheme --from-code=UTF-8 \ -- cgit v1.2.3 From 3140f2df423d1235c3766e3478a429ac89d882ed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Feb 2014 17:54:32 +0100 Subject: guix hash: Add '--recursive'. * guix/scripts/hash.scm (show-help): Add --recursive. (%options): Likewise. (guix-hash)[file-hash]: New procedure. Honor --recursive. Use it. * guix/nar.scm (write-file): Add missing field to the &nar-error condition raised upon unsupported file type; change its message to be more descriptive. * tests/guix-hash.sh: Add tests with -r. * doc/guix.texi (Invoking guix hash): Document --recursive. --- doc/guix.texi | 13 +++++++++++++ guix/nar.scm | 4 ++-- guix/scripts/hash.scm | 25 +++++++++++++++++++++---- tests/guix-hash.sh | 22 +++++++++++++++++++++- 4 files changed, 57 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 34f6810f34..ce011959ad 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1958,6 +1958,19 @@ If the @option{--format} option is not specified, @command{guix hash} will output the hash in @code{nix-base32}. This representation is used in the definitions of packages. +@item --recursive +@itemx -r +Compute the hash on @var{file} recursively. + +In this case, the hash is computed on an archive containing @var{file}, +including its children if it is a directory. Some of @var{file}'s +meta-data is part of the archive; for instance, when @var{file} is a +regular file, the hash is different depending on whether @var{file} is +executable or not. Meta-data such as time stamps has no impact on the +hash (@pxref{Invoking guix archive}). +@c FIXME: Replace xref above with xref to an ``Archive'' section when +@c it exists. + @end table @node Invoking guix refresh diff --git a/guix/nar.scm b/guix/nar.scm index 89a71302e0..9ba6e4ce2c 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -195,8 +195,8 @@ sub-directories of FILE as needed." (write-string "target" p) (write-string (readlink f) p)) (else - (raise (condition (&message (message "ENOSYS")) - (&nar-error))))) + (raise (condition (&message (message "unsupported file type")) + (&nar-error (file f) (port port)))))) (write-string ")" p)))) (define (restore-file port file) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 4e66aa0f3e..ea8c2ada6b 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -20,12 +20,14 @@ (define-module (guix scripts hash) #:use-module (guix base32) #:use-module (guix hash) + #:use-module (guix nar) #:use-module (guix ui) #:use-module (guix utils) #:use-module (rnrs io ports) #:use-module (rnrs files) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:export (guix-hash)) @@ -43,10 +45,12 @@ (display (_ "Usage: guix hash [OPTION] FILE Return the cryptographic hash of FILE. -Supported formats: 'nix-base32' (default), 'base32', and 'base16' -('hex' and 'hexadecimal' can be used as well).\n")) +Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' +and 'hexadecimal' can be used as well).\n")) (format #t (_ " -f, --format=FMT write the hash in the given format")) + (format #t (_ " + -r, --recursive compute the hash on FILE recursively")) (newline) (display (_ " -h, --help display this help and exit")) @@ -73,6 +77,9 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (alist-cons 'format fmt-proc (alist-delete 'format result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) (option '(#\h "help") #f #f (lambda args @@ -107,12 +114,22 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (reverse opts))) (fmt (assq-ref opts 'format))) + (define (file-hash file) + ;; Compute the hash of FILE. + ;; Catch and gracefully report possible '&nar-error' conditions. + (with-error-handling + (if (assoc-ref opts 'recursive?) + (let-values (((port get-hash) (open-sha256-port))) + (write-file file port) + (flush-output-port port) + (get-hash)) + (call-with-input-file file port-sha256)))) + (match args ((file) (catch 'system-error (lambda () - (format #t "~a~%" - (fmt (call-with-input-file file port-sha256)))) + (format #t "~a~%" (fmt (file-hash file)))) (lambda args (leave (_ "~a~%") (strerror (system-error-errno args)))))) diff --git a/tests/guix-hash.sh b/tests/guix-hash.sh index 53325ce1f4..23df01d417 100644 --- a/tests/guix-hash.sh +++ b/tests/guix-hash.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013 Ludovic Courtès +# Copyright © 2013, 2014 Ludovic Courtès # # This file is part of GNU Guix. # @@ -22,7 +22,27 @@ guix hash --version +tmpdir="guix-hash-$$" +trap 'rm -rf "$tmpdir"' EXIT + test `guix hash /dev/null` = 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73 test `guix hash -f nix-base32 /dev/null` = 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73 test `guix hash -f hex /dev/null` = e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 test `guix hash -f base32 /dev/null` = 4oymiquy7qobjgx36tejs35zeqt24qpemsnzgtfeswmrw6csxbkq + +mkdir "$tmpdir" +echo -n executable > "$tmpdir/exe" +chmod +x "$tmpdir/exe" +( cd "$tmpdir" ; ln -s exe symlink ) +mkdir "$tmpdir/subdir" + +test `guix hash -r "$tmpdir"` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p + +# Without '-r', this should fail. +if guix hash "$tmpdir" +then false; else true; fi + +# This should fail because /dev/null is a character device, which +# the archive format doesn't support. +if guix hash -r /dev/null +then false; else true; fi -- cgit v1.2.3 From 36bbbbd150f75c2a6dab2473643c3723e606e41d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Feb 2014 23:03:19 +0100 Subject: derivations: Add support for recursive fixed-output derivations. * guix/derivations.scm (): Add 'recursive?' field. Adjust 'make-derivation-output' callers. (%read-derivation) : When HASH-ALGO starts with 'r:', set the 'recursive?' field and drop 'r:' from the hash algo name. (write-derivation)[write-output]: Write the algo as 'r:HASH-ALGO' when the RECURSIVE? field is set. (derivation-hash) : Prepend "r:" when RECURSIVE? is set. (fixed-output-path): New procedure. (derivation): Add #:recursive? parameter. Use 'fixed-output-path' to compute the output file name of a fixed output derivation. (build-expression->derivation): Add #:recursive? parameter. Pass it to 'derivation'. * tests/derivations.scm ("fixed-output derivation, recursive", "build-expression->derivation produces recursive fixed-output", "build-expression->derivation uses recursive fixed-output"): New tests. * doc/guix.texi (Derivations): Document #:recursive? for 'derivation'. Add #:recursive? for 'build-expression->derivation'. --- doc/guix.texi | 9 ++++--- guix/derivations.scm | 71 ++++++++++++++++++++++++++++++++++++++------------- tests/derivations.scm | 70 ++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 127 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index ce011959ad..b2733fbec9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1478,7 +1478,7 @@ a derivation is the @code{derivation} procedure: @deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @ @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ - [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] @ + [#:recursive? #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] @ [#:system (%current-system)] [#:references-graphs #f] @ [#:local-build? #f] Build a derivation with the given arguments, and return the resulting @@ -1486,7 +1486,10 @@ Build a derivation with the given arguments, and return the resulting When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a @dfn{fixed-output derivation} is created---i.e., one whose result is -known in advance, such as a file download. +known in advance, such as a file download. If, in addition, +@var{recursive?} is true, then that fixed output may be an executable +file or a directory and @var{hash} must be the hash of an archive +containing this output. When @var{references-graphs} is true, it must be a list of file name/store path pairs. In that case, the reference graph of each store @@ -1526,7 +1529,7 @@ the caller to directly pass a Guile expression as the build script: @var{name} @var{exp} @ [#:system (%current-system)] [#:inputs '()] @ [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ - [#:env-vars '()] [#:modules '()] @ + [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:references-graphs #f] [#:local-build? #f] [#:guile-for-build #f] Return a derivation that executes Scheme expression @var{exp} as a builder for derivation @var{name}. @var{inputs} must be a list of diff --git a/guix/derivations.scm b/guix/derivations.scm index cc8e37c973..4f060a6aa2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -47,6 +47,7 @@ derivation-output-path derivation-output-hash-algo derivation-output-hash + derivation-output-recursive? derivation-input? @@ -91,11 +92,12 @@ (file-name derivation-file-name)) ; the .drv file name (define-record-type - (make-derivation-output path hash-algo hash) + (make-derivation-output path hash-algo hash recursive?) derivation-output? (path derivation-output-path) ; store path (hash-algo derivation-output-hash-algo) ; symbol | #f - (hash derivation-output-hash)) ; bytevector | #f + (hash derivation-output-hash) ; bytevector | #f + (recursive? derivation-output-recursive?)) ; Boolean (define-record-type (make-derivation-input path sub-derivations) @@ -241,14 +243,19 @@ that second value is the empty list." (match output ((name path "" "") (alist-cons name - (make-derivation-output path #f #f) + (make-derivation-output path #f #f #f) result)) ((name path hash-algo hash) ;; fixed-output - (let ((algo (string->symbol hash-algo)) - (hash (base16-string->bytevector hash))) + (let* ((rec? (string-prefix? "r:" hash-algo)) + (algo (string->symbol + (if rec? + (string-drop hash-algo 2) + hash-algo))) + (hash (base16-string->bytevector hash))) (alist-cons name - (make-derivation-output path algo hash) + (make-derivation-output path algo + hash rec?) result))))) '() x)) @@ -368,9 +375,12 @@ that form." (define (write-output output port) (match output - ((name . ($ path hash-algo hash)) + ((name . ($ path hash-algo hash recursive?)) (write-tuple (list name path - (or (and=> hash-algo symbol->string) "") + (if hash-algo + (string-append (if recursive? "r:" "") + (symbol->string hash-algo)) + "") (or (and=> hash bytevector->base16-string) "")) write @@ -476,11 +486,14 @@ in SIZE bytes." "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." (match drv (($ ((_ . ($ path - (? symbol? hash-algo) (? bytevector? hash))))) + (? symbol? hash-algo) (? bytevector? hash) + (? boolean? recursive?))))) ;; A fixed-output derivation. (sha256 (string->utf8 - (string-append "fixed:out:" (symbol->string hash-algo) + (string-append "fixed:out:" + (if recursive? "r:" "") + (symbol->string hash-algo) ":" (bytevector->base16-string hash) ":" path)))) (($ outputs inputs sources @@ -527,17 +540,33 @@ the derivation called NAME with hash HASH." name (string-append name "-" output)))) +(define (fixed-output-path output hash-algo hash recursive? name) + "Return an output path for the fixed output OUTPUT defined by HASH of type +HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for +'add-to-store'." + (if (and recursive? (eq? hash-algo 'sha256)) + (store-path "source" hash name) + (let ((tag (string-append "fixed:" output ":" + (if recursive? "r:" "") + (symbol->string hash-algo) ":" + (bytevector->base16-string hash) ":"))) + (store-path (string-append "output:" output) + (sha256 (string->utf8 tag)) + name)))) + (define* (derivation store name builder args #:key (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) - hash hash-algo hash-mode + hash hash-algo hash-mode recursive? references-graphs local-build?) "Build a derivation with the given arguments, and return the resulting object. When HASH, HASH-ALGO, and HASH-MODE are given, a fixed-output derivation is created---i.e., one whose result is known in -advance, such as a file download. +advance, such as a file download. If, in addition, RECURSIVE? is true, then +that fixed output may be an executable file or a directory and HASH must be +the hash of an archive containing this output. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs. In that case, the reference graph of each store path is exported in @@ -555,12 +584,16 @@ derivations where the costs of data transfers would outweigh the benefits." (let* ((drv-hash (derivation-hash drv)) (outputs (map (match-lambda ((output-name . ($ - _ algo hash)) - (let ((path (output-path output-name - drv-hash name))) + _ algo hash rec?)) + (let ((path (if hash + (fixed-output-path output-name + algo hash + rec? name) + (output-path output-name + drv-hash name)))) (cons output-name (make-derivation-output path algo - hash))))) + hash rec?))))) outputs))) (make-derivation outputs inputs sources system builder args (map (match-lambda @@ -618,7 +651,8 @@ derivations where the costs of data transfers would outweigh the benefits." (let* ((outputs (map (lambda (name) ;; Return outputs with an empty path. (cons name - (make-derivation-output "" hash-algo hash))) + (make-derivation-output "" hash-algo + hash recursive?))) outputs)) (inputs (map (match-lambda (((? derivation? drv)) @@ -909,7 +943,7 @@ they can refer to each other." (system (%current-system)) (inputs '()) (outputs '("out")) - hash hash-algo + hash hash-algo recursive? (env-vars '()) (modules '()) guile-for-build @@ -1056,6 +1090,7 @@ LOCAL-BUILD?." env-vars) #:hash hash #:hash-algo hash-algo + #:recursive? recursive? #:outputs outputs #:references-graphs references-graphs #:local-build? local-build?))) diff --git a/tests/derivations.scm b/tests/derivations.scm index f7cedde505..f31b00b8a2 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -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. ;;; @@ -23,7 +23,8 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix base32) - #:use-module ((guix packages) #:select (package-derivation)) + #:use-module ((guix packages) #:select (package-derivation base32)) + #:use-module ((guix build utils) #:select (executable-file?)) #:use-module ((gnu packages) #:select (search-bootstrap-binary)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages guile) #:select (guile-1.8)) @@ -190,6 +191,23 @@ (equal? (derivation->output-path drv1) (derivation->output-path drv2))))) +(test-assert "fixed-output derivation, recursive" + (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" + "echo -n hello > $out" '())) + (hash (sha256 (string->utf8 "hello"))) + (drv (derivation %store "fixed-rec" + %bash `(,builder) + #:inputs `((,builder)) + #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa") + #:hash-algo 'sha256 + #:recursive? #t)) + (succeeded? (build-derivations %store (list drv)))) + (and succeeded? + (let ((p (derivation->output-path drv))) + (and (equal? (string->utf8 "hello") + (call-with-input-file p get-bytevector-all)) + (bytevector? (query-path-hash %store p))))))) + (test-assert "derivation with a fixed-output input" ;; A derivation D using a fixed-output derivation F doesn't has the same ;; output path when passed F or F', as long as F and F' have the same output @@ -637,6 +655,54 @@ Deriver: ~a~%" (derivation-file-name final1))) (build-derivations %store (list final1 final2))))) +(test-assert "build-expression->derivation produces recursive fixed-output" + (let* ((builder '(begin + (use-modules (srfi srfi-26)) + (mkdir %output) + (chdir %output) + (call-with-output-file "exe" + (cut display "executable" <>)) + (chmod "exe" #o777) + (symlink "exe" "symlink") + (mkdir "subdir"))) + (drv (build-expression->derivation %store "fixed-rec" builder + #:hash-algo 'sha256 + #:hash (base32 + "10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p") + #:recursive? #t))) + (and (build-derivations %store (list drv)) + (let* ((dir (derivation->output-path drv)) + (exe (string-append dir "/exe")) + (link (string-append dir "/symlink")) + (subdir (string-append dir "/subdir"))) + (and (executable-file? exe) + (string=? "executable" + (call-with-input-file exe get-string-all)) + (string=? "exe" (readlink link)) + (file-is-directory? subdir)))))) + +(test-assert "build-expression->derivation uses recursive fixed-output" + (let* ((builder '(call-with-output-file %output + (lambda (port) + (display "hello" port)))) + (fixed (build-expression->derivation %store "small-fixed-rec" + builder + #:hash-algo 'sha256 + #:hash (base32 + "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa") + #:recursive? #t)) + (in (derivation->output-path fixed)) + (builder `(begin + (mkdir %output) + (chdir %output) + (symlink ,in "symlink"))) + (drv (build-expression->derivation %store "fixed-rec-user" + builder + #:inputs `(("fixed" ,fixed))))) + (and (build-derivations %store (list drv)) + (let ((out (derivation->output-path drv))) + (string=? (readlink (string-append out "/symlink")) in))))) + (test-assert "build-expression->derivation with #:references-graphs" (let* ((input (add-text-to-store %store "foo" "hello" (list %bash %mkdir))) -- cgit v1.2.3 From 96c7448f370227c9777a6acdac4ac65f1884fb43 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Feb 2014 20:17:29 +0100 Subject: nar: Produce archives with files sorted in C collation order. * guix/nar.scm (write-file) : Pass 'string '("." "..")) - (scandir f)))) + (let* ((select? (negate (cut member <> '("." "..")))) + + ;; 'scandir' defaults to 'string-locale Date: Fri, 21 Feb 2014 23:41:11 +0100 Subject: Add (guix git-download). * guix/git-download.scm, guix/build/git.scm: New files. * Makefile.am (MODULES): Add them. * guix/packages.scm (): Fix comment for 'method' field. --- Makefile.am | 2 ++ guix/build/git.scm | 45 ++++++++++++++++++++++++++ guix/git-download.scm | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++ guix/packages.scm | 4 +-- 4 files changed, 138 insertions(+), 2 deletions(-) create mode 100644 guix/build/git.scm create mode 100644 guix/git-download.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 6ad8eb9914..56cb6d2354 100644 --- a/Makefile.am +++ b/Makefile.am @@ -34,6 +34,7 @@ MODULES = \ guix/pki.scm \ guix/utils.scm \ guix/download.scm \ + guix/git-download.scm \ guix/monads.scm \ guix/profiles.scm \ guix/serialization.scm \ @@ -54,6 +55,7 @@ MODULES = \ guix/ui.scm \ 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 \ diff --git a/guix/build/git.scm b/guix/build/git.scm new file mode 100644 index 0000000000..4245594c38 --- /dev/null +++ b/guix/build/git.scm @@ -0,0 +1,45 @@ +;;; 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 git) + #:use-module (guix build utils) + #:export (git-fetch)) + +;;; Commentary: +;;; +;;; This is the build-side support code of (guix git-download). It allows a +;;; Git repository to be cloned and checked out at a specific commit. +;;; +;;; Code: + +(define* (git-fetch url commit directory + #:key (git-command "git")) + "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit +identifier. Return #t on success, #f otherwise." + (and (zero? (system* git-command "clone" url directory)) + (with-directory-excursion directory + (system* git-command "tag" "-l") + (and (zero? (system* git-command "checkout" commit)) + (begin + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, this + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t))))) + +;;; git.scm ends here diff --git a/guix/git-download.scm b/guix/git-download.scm new file mode 100644 index 0000000000..472bf756ce --- /dev/null +++ b/guix/git-download.scm @@ -0,0 +1,89 @@ +;;; 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 git-download) + #:use-module (guix records) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (git-reference + git-reference? + git-reference-url + git-reference-commit + + git-fetch)) + +;;; Commentary: +;;; +;;; An method that fetches a specific commit from a Git repository. +;;; The repository URL and commit hash are specified with a +;;; object. +;;; +;;; Code: + +(define-record-type* + git-reference make-git-reference + git-reference? + (url git-reference-url) + (commit git-reference-commit)) + +(define* (git-fetch store ref hash-algo hash + #:optional name + #:key (system (%current-system)) guile git) + "Return a fixed-output derivation in STORE that fetches REF, a + object. The output is expected to have recursive hash HASH of +type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if +#f." + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages base))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system))))) + + (define git-for-build + (match git + ((? package?) + (package-derivation store git system)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages version-control))) + (git (module-ref distro 'git))) + (package-derivation store git system))))) + + (let* ((command (string-append (derivation->output-path git-for-build) + "/bin/git")) + (builder `(begin + (use-modules (guix build git)) + (git-fetch ',(git-reference-url ref) + ',(git-reference-commit ref) + %output + #:git-command ',command)))) + (build-expression->derivation store (or name "git-checkout") builder + #:system system + #:local-build? #t + #:inputs `(("git" ,git-for-build)) + #:hash-algo hash-algo + #:hash hash + #:recursive? #t + #:modules '((guix build git) + (guix build utils)) + #:guile-for-build guile-for-build))) + +;;; git-download.scm ends here diff --git a/guix/packages.scm b/guix/packages.scm index daf431f5e4..d345900f79 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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. ;;; @@ -106,7 +106,7 @@ origin make-origin origin? (uri origin-uri) ; string - (method origin-method) ; symbol + (method origin-method) ; procedure (sha256 origin-sha256) ; bytevector (file-name origin-file-name (default #f)) ; optional file name (patches origin-patches (default '())) ; list of file names -- cgit v1.2.3 From 2096ef47aad57a9988c8fdfaa46a70770a0e0b12 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Feb 2014 23:48:56 +0100 Subject: derivations: Remove unused 'derivation' parameter. * guix/derivations.scm (derivation): Remove unused #:hash-mode parameter. * doc/guix.texi (Derivations): Adjust accordingly. --- doc/guix.texi | 4 ++-- guix/derivations.scm | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 36e68668ef..78736fadf2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1486,13 +1486,13 @@ a derivation is the @code{derivation} procedure: @deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @ @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ - [#:recursive? #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] @ + [#:recursive? #f] [#:inputs '()] [#:env-vars '()] @ [#:system (%current-system)] [#:references-graphs #f] @ [#:local-build? #f] Build a derivation with the given arguments, and return the resulting @code{} object. -When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a +When @var{hash} and @var{hash-algo} are given, a @dfn{fixed-output derivation} is created---i.e., one whose result is known in advance, such as a file download. If, in addition, @var{recursive?} is true, then that fixed output may be an executable diff --git a/guix/derivations.scm b/guix/derivations.scm index 4f060a6aa2..82a0173232 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -558,11 +558,11 @@ HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for #:key (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) - hash hash-algo hash-mode recursive? + hash hash-algo recursive? references-graphs local-build?) "Build a derivation with the given arguments, and return the resulting - object. When HASH, HASH-ALGO, and HASH-MODE are given, a + object. When HASH and HASH-ALGO are given, a fixed-output derivation is created---i.e., one whose result is known in advance, such as a file download. If, in addition, RECURSIVE? is true, then that fixed output may be an executable file or a directory and HASH must be -- cgit v1.2.3