diff options
author | Ludovic Courtès <ludo@gnu.org> | 2013-09-08 12:11:32 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2013-09-08 12:11:32 +0200 |
commit | 8ce3104e0e290b603599ec2e1b86bb82497c2665 (patch) | |
tree | 9b099435ac4d3aa05439be277a32e19337c07c7a /guix | |
parent | 3409bc0188feb4b00cdd5ec7acc357faa6cad698 (diff) | |
parent | 6bf25b7b0554e8b569bc4938c4833491aedc742f (diff) | |
download | guix-patches-8ce3104e0e290b603599ec2e1b86bb82497c2665.tar guix-patches-8ce3104e0e290b603599ec2e1b86bb82497c2665.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/cmake.scm | 9 | ||||
-rw-r--r-- | guix/build/linux-initrd.scm | 148 | ||||
-rw-r--r-- | guix/build/union.scm | 29 | ||||
-rw-r--r-- | guix/derivations.scm | 74 | ||||
-rw-r--r-- | guix/download.scm | 4 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 6 | ||||
-rwxr-xr-x | guix/scripts/substitute-binary.scm | 9 | ||||
-rw-r--r-- | guix/store.scm | 9 | ||||
-rw-r--r-- | guix/ui.scm | 1 |
9 files changed, 259 insertions, 30 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 3347dc502c..76a9a3befe 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -35,13 +35,20 @@ ;; ;; Code: +(define (default-cmake) + "Return the default CMake package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages cmake)))) + (module-ref module 'cmake))) + (define* (cmake-build store name source inputs #:key (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) (patches ''()) (patch-flags ''("--batch" "-p1")) - (cmake (@ (gnu packages cmake) cmake)) + (cmake (default-cmake)) (out-of-source? #f) (tests? #t) (test-target "test") diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm new file mode 100644 index 0000000000..b5404da7f0 --- /dev/null +++ b/guix/build/linux-initrd.scm @@ -0,0 +1,148 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 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 linux-initrd) + #:use-module (rnrs io ports) + #:use-module (system foreign) + #:export (mount-essential-file-systems + linux-command-line + make-essential-device-nodes + configure-qemu-networking + mount-qemu-smb-share + bind-mount + load-linux-module* + device-number)) + +;;; Commentary: +;;; +;;; Utility procedures useful in a Linux initial RAM disk (initrd). Note that +;;; many of these use procedures not yet available in vanilla Guile (`mount', +;;; `load-linux-module', etc.); these are provided by a Guile patch used in +;;; the GNU distribution. +;;; +;;; Code: + +(define* (mount-essential-file-systems #:key (root "/")) + "Mount /proc and /sys under ROOT." + (define (scope dir) + (string-append root + (if (string-suffix? "/" root) + "" + "/") + dir)) + + (unless (file-exists? (scope "proc")) + (mkdir (scope "proc"))) + (mount "none" (scope "proc") "proc") + + (unless (file-exists? (scope "sys")) + (mkdir (scope "sys"))) + (mount "none" (scope "sys") "sysfs")) + +(define (linux-command-line) + "Return the Linux kernel command line as a list of strings." + (string-tokenize + (call-with-input-file "/proc/cmdline" + get-string-all))) + +(define* (make-essential-device-nodes #:key (root "/")) + "Make essential device nodes under ROOT/dev." + ;; The hand-made udev! + + (define (scope dir) + (string-append root + (if (string-suffix? "/" root) + "" + "/") + dir)) + + (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)) + + ;; TTYs. + (mknod (scope "dev/tty") 'char-special #o600 + (device-number 5 0)) + (let loop ((n 0)) + (and (< n 50) + (let ((name (format #f "dev/tty~a" n))) + (mknod (scope name) 'char-special #o600 + (device-number 4 n)) + (loop (+ 1 n))))) + + ;; Other useful nodes. + (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3)) + (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5))) + +(define %host-qemu-ipv4-address + (inet-pton AF_INET "10.0.2.10")) + +(define* (configure-qemu-networking #:optional (interface "eth0")) + "Setup the INTERFACE network interface and /etc/resolv.conf according to +QEMU's default networking settings (see net/slirp.c in QEMU for default +networking values.) Return #t if INTERFACE is up, #f otherwise." + (display "configuring QEMU networking...\n") + (let* ((sock (socket AF_INET SOCK_STREAM 0)) + (address (make-socket-address AF_INET %host-qemu-ipv4-address 0)) + (flags (network-interface-flags sock interface))) + (set-network-interface-address sock interface address) + (set-network-interface-flags sock interface (logior flags IFF_UP)) + + (unless (file-exists? "/etc") + (mkdir "/etc")) + (call-with-output-file "/etc/resolv.conf" + (lambda (p) + (display "nameserver 10.0.2.3\n" p))) + + (logand (network-interface-flags sock interface) IFF_UP))) + +(define (mount-qemu-smb-share share mount-point) + "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT. + +Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our +`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares + (the latter allows the store to be shared between the host and guest.)" + + (format #t "mounting QEMU's SMB share `~a'...\n" share) + (let ((server "10.0.2.4")) + (mount (string-append "//" server share) mount-point "cifs" 0 + (string->pointer "guest,sec=none")))) + +(define (bind-mount source target) + "Bind-mount SOURCE at TARGET." + (define MS_BIND 4096) ; from libc's <sys/mount.h> + + (mount source target "" MS_BIND)) + +(define (load-linux-module* file) + "Load Linux module from FILE, the name of a `.ko' file." + (define (slurp module) + (call-with-input-file file get-bytevector-all)) + + (load-linux-module (slurp file))) + +(define (device-number major minor) + "Return the device number for the device with MAJOR and MINOR, for use as +the last argument of `mknod'." + (+ (* major 256) minor)) + +;;; linux-initrd.scm ends here diff --git a/guix/build/union.scm b/guix/build/union.scm index 275746d83e..077b7fe530 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -105,7 +105,22 @@ single leaf." the DIRECTORIES." (define (file-tree dir) ;; Return the contents of DIR as a tree. - (match (file-system-fold (const #t) + + (define (others-have-it? subdir) + ;; Return #t if other elements of DIRECTORIES have SUBDIR. + (let ((subdir (substring subdir (string-length dir)))) + (any (lambda (other) + (and (not (string=? other dir)) + (file-exists? (string-append other "/" subdir)))) + directories))) + + (match (file-system-fold (lambda (subdir stat result) ; enter? + ;; No need to traverse DIR since there's + ;; nothing to union it with. Thus, we avoid + ;; creating a gazillon symlinks (think + ;; share/emacs/24.3, share/texmf, etc.) + (or (string=? subdir dir) + (others-have-it? subdir))) (lambda (file stat result) ; leaf (match result (((siblings ...) rest ...) @@ -117,7 +132,12 @@ the DIRECTORIES." (((leaves ...) (siblings ...) rest ...) `(((,(basename dir) ,@leaves) ,@siblings) ,@rest)))) - (const #f) ; skip + (lambda (dir stat result) ; skip + ;; DIR is not available elsewhere, so treat it + ;; as a leaf. + (match result + (((siblings ...) rest ...) + `((,dir ,@siblings) ,@rest)))) (lambda (file stat errno result) (format (current-error-port) "union-build: ~a: ~a~%" file (strerror errno))) @@ -158,8 +178,9 @@ the DIRECTORIES." (mkdir output) (let loop ((tree (delete-duplicate-leaves (cons "." - (tree-union (append-map (compose tree-leaves file-tree) - directories))) + (tree-union + (append-map (compose tree-leaves file-tree) + (delete-duplicates directories)))) leaf=? resolve-collision)) (dir '())) diff --git a/guix/derivations.scm b/guix/derivations.scm index 8ddef117d4..c05644add2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -61,6 +61,8 @@ derivation %guile-for-build + imported-modules + compiled-modules build-expression->derivation imported-files)) @@ -497,12 +499,20 @@ the derivation called NAME with hash HASH." name (string-append name "-" output)))) -(define* (derivation store name system builder args env-vars inputs - #:key (outputs '("out")) hash hash-algo hash-mode) +(define* (derivation store name builder args + #:key + (system (%current-system)) (env-vars '()) + (inputs '()) (outputs '("out")) + hash hash-algo hash-mode + references-graphs) "Build a derivation with the given arguments. Return the resulting store path and <derivation> 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." +known in advance, such as a file download. + +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 +the build environment in the corresponding file, in a simple text format." (define direct-store-path? (let ((len (+ 1 (string-length (%store-prefix))))) (lambda (p) @@ -537,7 +547,22 @@ known in advance, such as a file download." value)))) env-vars)))))) - (define (env-vars-with-empty-outputs) + (define (user+system-env-vars) + ;; Some options are passed to the build daemon via the env. vars of + ;; derivations (urgh!). We hide that from our API, but here is the place + ;; where we kludgify those options. + (match references-graphs + (((file . path) ...) + (let ((value (map (cut string-append <> " " <>) + file path))) + ;; XXX: This all breaks down if an element of FILE or PATH contains + ;; white space. + `(("exportReferencesGraph" . ,(string-join value " ")) + ,@env-vars))) + (#f + env-vars))) + + (define (env-vars-with-empty-outputs env-vars) ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an ;; empty string, even outputs that do not appear in ENV-VARS. (let ((e (map (match-lambda @@ -569,7 +594,7 @@ known in advance, such as a file download." #t "sha256" input))) (make-derivation-input path '())))) (delete-duplicates inputs))) - (env-vars (env-vars-with-empty-outputs)) + (env-vars (env-vars-with-empty-outputs (user+system-env-vars))) (drv-masked (make-derivation outputs (filter (compose derivation-path? derivation-input-path) @@ -720,7 +745,8 @@ they can refer to each other." hash hash-algo (env-vars '()) (modules '()) - guile-for-build) + guile-for-build + references-graphs) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list @@ -737,7 +763,9 @@ builder terminates by passing the result of EXP to `exit'; thus, when EXP returns #f, the build is considered to have failed. EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is -omitted or is #f, the value of the `%guile-for-build' fluid is used instead." +omitted or is #f, the value of the `%guile-for-build' fluid is used instead. + +See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -747,8 +775,8 @@ omitted or is #f, the value of the `%guile-for-build' fluid is used instead." (define module-form? (match-lambda - (((or 'define-module 'use-modules) _ ...) #t) - (_ #f))) + (((or 'define-module 'use-modules) _ ...) #t) + (_ #f))) (define source-path ;; When passed an input that is a source, return its path; otherwise @@ -833,22 +861,26 @@ omitted or is #f, the value of the `%guile-for-build' fluid is used instead." #:system system))) (go-dir (and go-drv (derivation-path->output-path go-drv)))) - (derivation store name system guile + (derivation store name guile `("--no-auto-compile" ,@(if mod-dir `("-L" ,mod-dir) '()) ,builder) + #:system system + + #:inputs `((,(or guile-for-build (%guile-for-build))) + (,builder) + ,@(map cdr inputs) + ,@(if mod-drv `((,mod-drv) (,go-drv)) '())) + ;; When MODULES is non-empty, shamelessly clobber ;; $GUILE_LOAD_COMPILED_PATH. - (if go-dir - `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir) - ,@(alist-delete "GUILE_LOAD_COMPILED_PATH" - env-vars)) - env-vars) - - `((,(or guile-for-build (%guile-for-build))) - (,builder) - ,@(map cdr inputs) - ,@(if mod-drv `((,mod-drv) (,go-drv)) '())) + #:env-vars (if go-dir + `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir) + ,@(alist-delete "GUILE_LOAD_COMPILED_PATH" + env-vars)) + env-vars) + #:hash hash #:hash-algo hash-algo - #:outputs outputs))) + #:outputs outputs + #:references-graphs references-graphs))) diff --git a/guix/download.scm b/guix/download.scm index b12659f683..fa76615ef2 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -99,7 +99,9 @@ "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/" "http://linux-kernel.uio.no/pub/" "http://kernel.osuosl.org/pub/" - "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/") + "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/" + "http://ftp.be.debian.org/pub/" + "http://mirror.linux.org.au/") (apache ; from http://www.apache.org/mirrors/dist.html "http://www.eu.apache.org/dist/" "http://www.us.apache.org/dist/" diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f4135efc99..f3d87a63c0 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -106,6 +106,8 @@ files." (when (string-suffix? ".scm" file) (let ((go (string-append (string-drop-right file 4) ".go"))) + (format (current-error-port) + "compiling '~a'...~%" file) (compile-file file #:output-file go #:opts %auto-compilation-options)))) @@ -114,7 +116,9 @@ files." ;; download), we must build it first to avoid errors since ;; (gnutls) is unavailable. (cons (string-append out "/guix/build/download.scm") - (find-files out "\\.scm"))) + + ;; Sort the file names to get deterministic results. + (sort (find-files out "\\.scm") string<?))) ;; Remove the "fake" (guix config). (delete-file (string-append out "/guix/config.scm")) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 97bbfcbce8..63f0c4f8d2 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -508,8 +508,13 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) - (format (current-error-port) "downloading `~a' from `~a'...~%" - store-path (uri->string uri)) + (format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%" + store-path (uri->string uri) + + ;; Use the Nar size as an estimate of the installed size. + (narinfo-size narinfo) + (and=> (narinfo-size narinfo) + (cute / <> (expt 2. 20)))) (let*-values (((raw download-size) ;; Note that Hydra currently generates Nars on the fly ;; and doesn't specify a Content-Length, so diff --git a/guix/store.scm b/guix/store.scm index 343da91506..541c7c848f 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -25,6 +25,7 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -242,6 +243,14 @@ (ats-cache nix-server-add-to-store-cache) (atts-cache nix-server-add-text-to-store-cache)) +(set-record-type-printer! <nix-server> + (lambda (obj port) + (format port "#<build-daemon ~a.~a ~a>" + (nix-server-major-version obj) + (nix-server-minor-version obj) + (number->string (object-address obj) + 16)))) + (define-condition-type &nix-error &error nix-error?) diff --git a/guix/ui.scm b/guix/ui.scm index 9251d73f18..720d01be02 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -242,6 +242,7 @@ available for download." (substitutable-path-info store download))))) download))) + ;; TODO: Show the installed size of DOWNLOAD. (if dry-run? (begin (format (current-error-port) |