summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/download.scm17
-rw-r--r--guix/build/git.scm45
-rw-r--r--guix/build/linux-initrd.scm197
-rw-r--r--guix/build/union.scm37
-rw-r--r--guix/derivations.scm73
-rw-r--r--guix/download.scm7
-rw-r--r--guix/git-download.scm89
-rw-r--r--guix/monads.scm67
-rw-r--r--guix/nar.scm16
-rw-r--r--guix/packages.scm4
-rw-r--r--guix/scripts/archive.scm147
-rw-r--r--guix/scripts/build.scm198
-rw-r--r--guix/scripts/hash.scm33
-rw-r--r--guix/scripts/offload.scm51
-rw-r--r--guix/scripts/system.scm148
-rw-r--r--guix/store.scm10
-rw-r--r--guix/ui.scm6
17 files changed, 875 insertions, 270 deletions
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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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)
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 <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index ae18a16e11..80ce679496 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -19,14 +19,23 @@
(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 (ice-9 ftw)
+ #:use-module (guix build utils)
#:export (mount-essential-file-systems
linux-command-line
make-essential-device-nodes
configure-qemu-networking
mount-qemu-smb-share
+ mount-qemu-9p
bind-mount
load-linux-module*
- device-number))
+ device-number
+ boot-system))
;;; Commentary:
;;;
@@ -74,10 +83,26 @@
(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))
+
+ ;; 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))
+
+ ;; 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
@@ -133,6 +158,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 <sys/mount.h>
@@ -151,4 +187,155 @@ 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?
+ 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
+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.
+
+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.
+ (let ((st (lstat file)))
+ (if (eq? 'symlink (stat:type st))
+ (let ((target (readlink file)))
+ (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")
+
+ (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
+ (catch #t
+ (lambda ()
+ (if volatile-root?
+ (begin
+ ;; XXX: For lack of a union file system...
+ (mkdir-p "/real-root")
+ (mount root "/real-root" "ext3" MS_RDONLY)
+ (mount "none" "/root" "tmpfs")
+
+ ;; XXX: 'copy-recursively' cannot deal with device nodes, so
+ ;; explicitly avoid /dev.
+ (for-each (lambda (file)
+ (unless (string=? "dev" file)
+ (copy-recursively (string-append "/real-root/"
+ file)
+ (string-append "/root/"
+ file)
+ #:log (%make-void-port
+ "w"))))
+ (scandir "/real-root"
+ (lambda (file)
+ (not (member file '("." ".."))))))
+
+ ;; TODO: Unmount /real-root.
+ )
+ (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")
+ (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)))
+ (('9p source target)
+ (let ((target (string-append "/root/" target)))
+ (mkdir-p target)
+ (mount-qemu-9p source target))))
+ 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)
+ (chdir "/root")
+ (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
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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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)))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index ae68bb1194..b47ab93759 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>
derivation-input?
@@ -91,11 +92,12 @@
(file-name derivation-file-name)) ; the .drv file name
(define-record-type <derivation-output>
- (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 <derivation-input>
(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 . ($ <derivation-output> path hash-algo hash))
+ ((name . ($ <derivation-output> 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
(($ <derivation> ((_ . ($ <derivation-output> 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))))
(($ <derivation> 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 recursive?
references-graphs
local-build?)
"Build a derivation with the given arguments, and return the resulting
-<derivation> object. When HASH, HASH-ALGO, and HASH-MODE are given, a
+<derivation> 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.
+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 . ($ <derivation-output>
- _ 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))
@@ -911,7 +945,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
@@ -1058,6 +1092,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/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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;;
;;; 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
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 <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <origin> method that fetches a specific commit from a Git repository.
+;;; The repository URL and commit hash are specified with a <git-reference>
+;;; object.
+;;;
+;;; Code:
+
+(define-record-type* <git-reference>
+ 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
+<git-reference> 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/monads.scm b/guix/monads.scm
index 410fdbecb2..db8b645402 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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -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,11 +54,14 @@
store-lift
run-with-store
text-file
+ text-file*
package-file
package->derivation
built-derivations
derivation-expression
- lower-inputs))
+ lower-inputs)
+ #:replace (imported-modules
+ compiled-modules))
;;; Commentary:
;;;
@@ -303,14 +307,63 @@ 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"))
- "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 +395,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))
diff --git a/guix/nar.scm b/guix/nar.scm
index 4bc2deb229..5bf174554c 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))
@@ -176,8 +177,13 @@ sub-directories of FILE as needed."
((directory)
(write-string "type" p)
(write-string "directory" p)
- (let ((entries (remove (cut member <> '("." ".."))
- (scandir f))))
+ (let* ((select? (negate (cut member <> '("." ".."))))
+
+ ;; 'scandir' defaults to 'string-locale<?' to sort files, but
+ ;; this happens to be case-insensitive (at least in 'en_US'
+ ;; locale on libc 2.18.) Conversely, we want files to be
+ ;; sorted in a case-sensitive fashion.
+ (entries (scandir f select? string<?)))
(for-each (lambda (e)
(let ((f (string-append f "/" e)))
(write-string "entry" p)
@@ -194,8 +200,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/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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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
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 7cb3710853..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 (_ "
@@ -139,61 +127,28 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
--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,21 +314,12 @@ build."
(_ #f))
opts)))
+ (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?)
#:dry-run? (assoc-ref opts 'dry-run?)))
- ;; 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))
-
(cond ((assoc-ref opts 'log-file?)
(for-each (lambda (file)
(let ((log (log-file store file)))
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index ca3928b8e3..ea8c2ada6b 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
@@ -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
@@ -99,11 +106,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)
@@ -112,13 +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~%"
- (call-with-input-file file
- (compose fmt sha256 eof->null get-bytevector-all))))
+ (format #t "~a~%" (fmt (file-hash file))))
(lambda args
(leave (_ "~a~%")
(strerror (system-error-errno args))))))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index d919ede3c7..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
@@ -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"))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
new file mode 100644
index 0000000000..7799ccbc47
--- /dev/null
+++ b/guix/scripts/system.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 services)
+ (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 <operating-system> 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/guix/store.scm b/guix/store.scm
index eca0de7d97..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))
@@ -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/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: <http://www.gnu.org/gethelp/>"))
((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