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?. --- guix/build/linux-initrd.scm | 121 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 120 insertions(+), 1 deletion(-) (limited to 'guix/build') 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/build') 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/build') 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/build') 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/build') 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/build') 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/build') 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 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/build') 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/build') 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/build') 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 9b5b5c17409ce0174d171903f03c1d53dfb455c5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès 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/build') 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