diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/cmake.scm | 6 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 20 | ||||
| -rw-r--r-- | guix/build-system/perl.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 66 | ||||
| -rw-r--r-- | guix/build/linux-initrd.scm | 4 | ||||
| -rw-r--r-- | guix/build/python-build-system.scm | 71 | ||||
| -rw-r--r-- | guix/derivations.scm | 129 | ||||
| -rw-r--r-- | guix/download.scm | 32 | ||||
| -rw-r--r-- | guix/nar.scm | 9 | ||||
| -rw-r--r-- | guix/packages.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 172 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 11 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 30 | ||||
| -rw-r--r-- | guix/store.scm | 2 | ||||
| -rw-r--r-- | guix/ui.scm | 102 |
16 files changed, 513 insertions, 179 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 76a9a3befe..9461b19a2e 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -72,9 +72,9 @@ provides a 'CMakeLists.txt' file as its build system." (define builder `(begin (use-modules ,@modules) - (cmake-build #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) - source) + (cmake-build #:source ,(if (derivation? source) + (derivation->output-path source) + source) #:system ,system #:outputs %outputs #:inputs %build-inputs diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 03d56edadf..5f13f8ee29 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -291,8 +291,8 @@ which could lead to gratuitous input divergence." (define builder `(begin (use-modules ,@modules) - (gnu-build #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + (gnu-build #:source ,(if (derivation? source) + (derivation->output-path source) source) #:system ,system #:outputs %outputs @@ -319,8 +319,8 @@ which could lead to gratuitous input divergence." (match guile ((? package?) (package-derivation store guile system)) - ((and (? string?) (? derivation-path?)) - guile) + ;; ((and (? string?) (? derivation-path?)) + ;; guile) (#f ; the default (let* ((distro (resolve-interface '(gnu packages base))) (guile (module-ref distro 'guile-final))) @@ -438,6 +438,8 @@ platform." (let () (define %build-host-inputs ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) ((name (? derivation-path? drv-path) sub ...) `(,name . ,(apply derivation-path->output-path drv-path sub))) @@ -447,6 +449,8 @@ platform." (define %build-target-inputs ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) ((name (? derivation-path? drv-path) sub ...) `(,name . ,(apply derivation-path->output-path drv-path sub))) @@ -454,8 +458,8 @@ platform." `(,name . ,path))) (append (or implicit-target-inputs '()) inputs))) - (gnu-build #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + (gnu-build #:source ,(if (derivation? source) + (derivation->output-path source) source) #:system ,system #:target ,target @@ -488,8 +492,8 @@ platform." (match guile ((? package?) (package-derivation store guile system)) - ((and (? string?) (? derivation-path?)) - guile) + ;; ((and (? string?) (? derivation-path?)) + ;; guile) (#f ; the default (let* ((distro (resolve-interface '(gnu packages base))) (guile (module-ref distro 'guile-final))) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 1ff9fd2674..6661689efb 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -62,8 +62,8 @@ provides a `Makefile.PL' file as its build system." `(begin (use-modules ,@modules) (perl-build #:name ,name - #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + #:source ,(if (derivation? source) + (derivation->output-path source) source) #:search-paths ',(map search-path-specification->sexp (append perl-search-paths diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index b60adb182f..cf7ca7d3e1 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -25,7 +26,9 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:export (python-build + #:use-module (srfi srfi-26) + #:export (package-with-python2 + python-build python-build-system)) ;; Commentary: @@ -39,13 +42,60 @@ "Return the default Python package." ;; Lazily resolve the binding to avoid a circular dependency. (let ((python (resolve-interface '(gnu packages python)))) - (module-ref python 'python))) + (module-ref python 'python-wrapper))) + +(define (default-python2) + "Return the default Python 2 package." + (let ((python (resolve-interface '(gnu packages python)))) + (module-ref python 'python-2))) + +(define (package-with-explicit-python p python old-prefix new-prefix) + "Create a package with the same fields as P, which is assumed to use +PYTHON-BUILD-SYSTEM, such that it is compiled with PYTHON instead. The +inputs are changed recursively accordingly. If the name of P starts with +OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is +prepended to the name." + (let* ((build-system (package-build-system p)) + (rewrite-if-package + (lambda (content) + ;; CONTENT may be a string (e.g., for patches), in which case it + ;; is returned, or a package, which is rewritten with the new + ;; PYTHON and NEW-PREFIX. + (if (package? content) + (package-with-explicit-python content python + old-prefix new-prefix) + content))) + (rewrite + (match-lambda + ((name content . rest) + (append (list name (rewrite-if-package content)) rest))))) + (package (inherit p) + (name + (let ((name (package-name p))) + (if (eq? build-system python-build-system) + (string-append new-prefix + (if (string-prefix? old-prefix name) + (substring name (string-length old-prefix)) + name)) + name))) + (arguments + (let ((arguments (package-arguments p))) + (if (eq? build-system python-build-system) + (if (member #:python arguments) + (substitute-keyword-arguments arguments ((#:python p) python)) + (append arguments `(#:python ,python))) + arguments))) + (inputs + (map rewrite (package-inputs p))) + (native-inputs + (map rewrite (package-native-inputs p)))))) + +(define package-with-python2 + (cut package-with-explicit-python <> (default-python2) "python-" "python2-")) (define* (python-build store name source inputs #:key (python (default-python)) - (python-version - (string-take (package-version (default-python)) 3)) (tests? #t) (configure-flags ''()) (phases '(@ (guix build python-build-system) @@ -58,10 +108,10 @@ (guix build gnu-build-system) (guix build utils))) (modules '((guix build python-build-system) - (guix build gnu-build-system) (guix build utils)))) "Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE provides a 'setup.py' file as its build system." + (define python-search-paths (append (package-native-search-paths python) (standard-search-paths))) @@ -70,15 +120,15 @@ provides a 'setup.py' file as its build system." `(begin (use-modules ,@modules) (python-build #:name ,name - #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + #:source ,(if (derivation? source) + (derivation->output-path source) source) #:configure-flags ,configure-flags #:system ,system #:test-target "test" #:tests? ,tests? + #:phases ,phases #:outputs %outputs - #:python-version ,python-version #:search-paths ',(map search-path-specification->sexp (append python-search-paths search-paths)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b5404da7f0..cbdb363b4e 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -89,6 +89,10 @@ (device-number 4 n)) (loop (+ 1 n))))) + ;; Rendez-vous point for syslogd. + (mknod (scope "dev/log") 'socket #o666 0) + (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11)) + ;; 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))) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 84299798b0..0bb8c4d49d 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -34,26 +35,49 @@ ;; ;; Code: -(define* (install #:key outputs (configure-flags '()) - #:allow-other-keys) - "Install a given Python package." - (let ((out (assoc-ref outputs "out"))) - (if (file-exists? "setup.py") - (let ((args `("setup.py" "install" ,(string-append "--prefix=" out) - ,@configure-flags))) - (format #t "running 'python' with arguments ~s~%" args) - (zero? (apply system* "python" args))) - (error "no setup.py found")))) -(define* (check #:key outputs #:allow-other-keys) - "Run the test suite of a given Python package." +(define (call-setuppy command params) (if (file-exists? "setup.py") - (let ((args `("setup.py" "check"))) - (format #t "running 'python' with arguments ~s~%" args) - (zero? (apply system* "python" args))) + (begin + (format #t "running \"python setup.py\" with command ~s and parameters ~s~%" + command params) + (zero? (apply system* "python" "setup.py" command params))) (error "no setup.py found"))) -(define* (wrap #:key outputs python-version #:allow-other-keys) +(define* (build #:rest empty) + "Build a given Python package." + (call-setuppy "build" '())) + +(define* (check #:key tests? test-target #:allow-other-keys) + "Run the test suite of a given Python package." + (if tests? + (call-setuppy test-target '()) + #t)) + +(define (get-python-version python) + (string-take (string-take-right python 5) 3)) + +(define* (install #:key outputs inputs (configure-flags '()) + #:allow-other-keys) + "Install a given Python package." + (let* ((out (assoc-ref outputs "out")) + (params (append (list (string-append "--prefix=" out)) + configure-flags)) + (python-version (get-python-version (assoc-ref inputs "python"))) + (old-path (getenv "PYTHONPATH")) + (add-path (string-append out "/lib/python" python-version + "/site-packages/"))) + ;; create the module installation directory and add it to PYTHONPATH + ;; to make setuptools happy + (mkdir-p add-path) + (setenv "PYTHONPATH" + (string-append (if old-path + (string-append old-path ":") + "") + add-path)) + (call-setuppy "install" params))) + +(define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) (map (cut string-append dir "/" <>) (or (scandir dir (lambda (f) @@ -69,9 +93,11 @@ outputs)) (let* ((out (assoc-ref outputs "out")) + (python (assoc-ref inputs "python")) (var `("PYTHONPATH" prefix ,(cons (string-append out "/lib/python" - python-version "/site-packages") + (get-python-version python) + "/site-packages") (search-path-as-string->list (or (getenv "PYTHONPATH") "")))))) (for-each (lambda (dir) @@ -87,11 +113,12 @@ 'install 'wrap wrap (alist-replace - 'check check - (alist-replace 'install install - (alist-delete 'configure - (alist-delete 'build - gnu:%standard-phases)))))) + 'build build + (alist-replace + 'check check + (alist-replace 'install install + (alist-delete 'configure + gnu:%standard-phases)))))) (define* (python-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/derivations.scm b/guix/derivations.scm index c05644add2..433a8f145e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -19,6 +19,7 @@ (define-module (guix derivations) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) @@ -36,6 +37,7 @@ derivation-system derivation-builder-arguments derivation-builder-environment-vars + derivation-file-name derivation-prerequisites derivation-prerequisites-to-build @@ -56,6 +58,8 @@ read-derivation write-derivation + derivation->output-path + derivation->output-paths derivation-path->output-path derivation-path->output-paths derivation @@ -64,14 +68,16 @@ imported-modules compiled-modules build-expression->derivation - imported-files)) + imported-files) + #:replace (build-derivations)) ;;; ;;; Nix derivations, as implemented in Nix's `derivations.cc'. ;;; (define-record-type <derivation> - (make-derivation outputs inputs sources system builder args env-vars) + (make-derivation outputs inputs sources system builder args env-vars + file-name) derivation? (outputs derivation-outputs) ; list of name/<derivation-output> pairs (inputs derivation-inputs) ; list of <derivation-input> @@ -79,7 +85,8 @@ (system derivation-system) ; string (builder derivation-builder) ; store path (args derivation-builder-arguments) ; list of strings - (env-vars derivation-builder-environment-vars)) ; list of name/value pairs + (env-vars derivation-builder-environment-vars) ; list of name/value pairs + (file-name derivation-file-name)) ; the .drv file name (define-record-type <derivation-output> (make-derivation-output path hash-algo hash) @@ -94,6 +101,17 @@ (path derivation-input-path) ; store path (sub-derivations derivation-input-sub-derivations)) ; list of strings +(set-record-type-printer! <derivation> + (lambda (drv port) + (format port "#<derivation ~a => ~a ~a>" + (derivation-file-name drv) + (string-join + (map (match-lambda + ((_ . output) + (derivation-output-path output))) + (derivation-outputs drv))) + (number->string (object-address drv) 16)))) + (define (fixed-output-derivation? drv) "Return #t if DRV is a fixed-output derivation, such as the result of a download with a fixed hash (aka. `fetchurl')." @@ -262,7 +280,8 @@ that second value is the empty list." (make-input-drvs input-drvs) input-srcs system builder args - (fold-right alist-cons '() var value))) + (fold-right alist-cons '() var value) + (port-filename drv-port))) (_ (error "failed to parse derivation" drv-port result))))) ((? (cut eq? <> comma)) @@ -404,25 +423,30 @@ that form." port) (display ")" port)))) +(define* (derivation->output-path drv #:optional (output "out")) + "Return the store path of its output OUTPUT." + (let ((outputs (derivation-outputs drv))) + (and=> (assoc-ref outputs output) derivation-output-path))) + +(define (derivation->output-paths drv) + "Return the list of name/path pairs of the outputs of DRV." + (map (match-lambda + ((name . output) + (cons name (derivation-output-path output)))) + (derivation-outputs drv))) + (define derivation-path->output-path ;; This procedure is called frequently, so memoize it. (memoize (lambda* (path #:optional (output "out")) "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store path of its output OUTPUT." - (let* ((drv (call-with-input-file path read-derivation)) - (outputs (derivation-outputs drv))) - (and=> (assoc-ref outputs output) derivation-output-path))))) + (derivation->output-path (call-with-input-file path read-derivation))))) (define (derivation-path->output-paths path) "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the list of name/path pairs of its outputs." - (let* ((drv (call-with-input-file path read-derivation)) - (outputs (derivation-outputs drv))) - (map (match-lambda - ((name . output) - (cons name (derivation-output-path output)))) - outputs))) + (derivation->output-paths (call-with-input-file path read-derivation))) ;;; @@ -470,7 +494,8 @@ in SIZE bytes." (make-derivation-input hash sub-drvs)))) inputs)) (drv (make-derivation outputs inputs sources - system builder args env-vars))) + system builder args env-vars + #f))) ;; XXX: At this point this remains faster than `port-sha256', because ;; the SHA256 port's `write' method gets called for every single @@ -505,10 +530,10 @@ the derivation called NAME with hash HASH." (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. + "Build a derivation with the given arguments, and return the resulting +<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. 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 @@ -545,7 +570,8 @@ the build environment in the corresponding file, in a simple text format." (or (and=> (assoc-ref outputs name) derivation-output-path) value)))) - env-vars)))))) + env-vars) + #f))))) (define (user+system-env-vars) ;; Some options are passed to the build daemon via the env. vars of @@ -578,12 +604,26 @@ the build environment in the corresponding file, in a simple text format." e outputs))) + (define (set-file-name drv file) + ;; Set FILE as the 'file-name' field of DRV. + (match drv + (($ <derivation> outputs inputs sources system builder + args env-vars) + (make-derivation outputs inputs sources system builder + args env-vars file)))) + (let* ((outputs (map (lambda (name) ;; Return outputs with an empty path. (cons name (make-derivation-output "" hash-algo hash))) outputs)) (inputs (map (match-lambda + (((? derivation? drv)) + (make-derivation-input (derivation-file-name drv) + '("out"))) + (((? derivation? drv) sub-drvs ...) + (make-derivation-input (derivation-file-name drv) + sub-drvs)) (((? direct-store-path? input)) (make-derivation-input input '("out"))) (((? direct-store-path? input) sub-drvs ...) @@ -604,17 +644,29 @@ the build environment in the corresponding file, in a simple text format." (and (not (derivation-path? p)) p))) inputs) - system builder args env-vars)) + system builder args env-vars #f)) (drv (add-output-paths drv-masked))) - ;; (write-derivation drv-masked (current-error-port)) - ;; (newline (current-error-port)) - (values (add-text-to-store store (string-append name ".drv") - (call-with-output-string - (cut write-derivation drv <>)) - (map derivation-input-path - inputs)) - drv))) + (let ((file (add-text-to-store store (string-append name ".drv") + (call-with-output-string + (cut write-derivation drv <>)) + (map derivation-input-path + inputs)))) + (set-file-name drv file)))) + + +;;; +;;; Store compatibility layer. +;;; + +(define (build-derivations store derivations) + "Build DERIVATIONS, a list of <derivation> objects or .drv file names." + (let ((build (@ (guix store) build-derivations))) + (build store (map (match-lambda + ((? string? file) file) + ((and drv ($ <derivation>)) + (derivation-file-name drv))) + derivations)))) ;;; @@ -706,7 +758,7 @@ they can refer to each other." #:system system #:guile guile #:module-path module-path)) - (module-dir (derivation-path->output-path module-drv)) + (module-dir (derivation->output-path module-drv)) (files (map (lambda (m) (let ((f (string-join (map symbol->string m) "/"))) @@ -770,7 +822,7 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." (or guile-for-build (%guile-for-build))) (define guile - (string-append (derivation-path->output-path guile-drv) + (string-append (derivation->output-path guile-drv) "/bin/guile")) (define module-form? @@ -782,6 +834,8 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." ;; When passed an input that is a source, return its path; otherwise ;; return #f. (match-lambda + ((_ (? derivation?) _ ...) + #f) ((_ path _ ...) (and (not (derivation-path? path)) path)))) @@ -806,10 +860,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." (() "out") ((x) x)))) (cons name - (if (derivation-path? drv) - (derivation-path->output-path drv - sub) - drv))))) + (cond + ((derivation? drv) + (derivation->output-path drv sub)) + ((derivation-path? drv) + (derivation-path->output-path drv + sub)) + (else drv)))))) inputs)) ,@(if (null? modules) @@ -854,13 +911,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." #:guile guile-drv #:system system))) (mod-dir (and mod-drv - (derivation-path->output-path mod-drv))) + (derivation->output-path mod-drv))) (go-drv (and (pair? modules) (compiled-modules store modules #:guile guile-drv #:system system))) (go-dir (and go-drv - (derivation-path->output-path go-drv)))) + (derivation->output-path go-drv)))) (derivation store name guile `("--no-auto-compile" ,@(if mod-dir `("-L" ,mod-dir) '()) diff --git a/guix/download.scm b/guix/download.scm index fa76615ef2..8b1d15f273 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -25,7 +25,6 @@ #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:)) #:use-module (guix utils) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:export (%mirrors url-fetch @@ -212,27 +211,22 @@ must be a list of symbol/URL-list pairs." ((url ...) (any https? url))))) - (let*-values (((gnutls-drv-path gnutls-drv) - (if need-gnutls? - (gnutls-derivation store system) - (values #f #f))) - ((gnutls) - (and gnutls-drv - (derivation-output-path - (assoc-ref (derivation-outputs gnutls-drv) - "out")))) - ((env-vars) - (if gnutls - (let ((dir (string-append gnutls "/share/guile/site"))) - ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden - ;; by `build-expression->derivation', so we can't - ;; set it here. - `(("GUILE_LOAD_PATH" . ,dir))) - '()))) + (let* ((gnutls-drv (if need-gnutls? + (gnutls-derivation store system) + (values #f #f))) + (gnutls (and gnutls-drv + (derivation->output-path gnutls-drv "out"))) + (env-vars (if gnutls + (let ((dir (string-append gnutls "/share/guile/site"))) + ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden + ;; by `build-expression->derivation', so we can't + ;; set it here. + `(("GUILE_LOAD_PATH" . ,dir))) + '()))) (build-expression->derivation store (or name file-name) system builder (if gnutls-drv - `(("gnutls" ,gnutls-drv-path)) + `(("gnutls" ,gnutls-drv)) '()) #:hash-algo hash-algo #:hash hash diff --git a/guix/nar.scm b/guix/nar.scm index 29b57dc989..ea119a25fe 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -76,10 +76,11 @@ ;; avoid stat'ing like crazy. (with-fluids ((%file-port-name-canonicalization #f)) (let ((port (open-file file "rb"))) - (catch #t (cut proc port) - (lambda args - (close-port port) - (apply throw args)))))) + (dynamic-wind + (const #t) + (cut proc port) + (lambda () + (close-port port)))))) (write-string "contents" p) (write-long-long size p) diff --git a/guix/packages.scm b/guix/packages.scm index f63727dd32..efec414675 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,7 +26,6 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -370,8 +369,8 @@ information in exceptions." (define* (package-derivation store package #:optional (system (%current-system))) - "Return the derivation path and corresponding <derivation> object of -PACKAGE for SYSTEM." + "Return the <derivation> object of PACKAGE for SYSTEM." + ;; Compute the derivation and cache the result. Caching is important ;; because some derivations, such as the implicit inputs of the GNU build ;; system, will be queried many, many times in a row. @@ -468,7 +467,5 @@ system identifying string)." "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the symbolic output name, such as \"out\". Note that this procedure calls `package-derivation', which is costly." - (let-values (((_ drv) - (package-derivation store package system))) - (derivation-output-path - (assoc-ref (derivation-outputs drv) output)))) + (let ((drv (package-derivation store package system))) + (derivation->output-path drv output))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 26cd28215e..a06755dc7a 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -250,7 +250,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (derivations-from-package-expressions str package->derivation sys src?)) (('argument . (? derivation-path? drv)) - drv) + (call-with-input-file drv read-derivation)) (('argument . (? string? x)) (let ((p (find-package x))) (if src? @@ -280,24 +280,23 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (if (assoc-ref opts 'derivations-only?) (begin - (format #t "~{~a~%~}" drv) + (format #t "~{~a~%~}" (map derivation-file-name drv)) (for-each (cut register-root <> <>) - (map list drv) roots)) + (map (compose list derivation-file-name) drv) + roots)) (or (assoc-ref opts 'dry-run?) (and (build-derivations (%store) drv) (for-each (lambda (d) - (let ((drv (call-with-input-file d - read-derivation))) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation-path->output-path - d out-name))) - (derivation-outputs drv))))) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) drv) (for-each (cut register-root <> <>) (map (lambda (drv) (map cdr - (derivation-path->output-paths drv))) + (derivation->output-paths drv))) drv) roots))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5c3947dd63..1d00e39540 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -34,6 +34,7 @@ #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) @@ -95,8 +96,8 @@ (make-regexp (string-append "^" (regexp-quote (basename profile)) "-([0-9]+)"))) -(define (profile-numbers profile) - "Return the list of generation numbers of PROFILE, or '(0) if no +(define (generation-numbers profile) + "Return the sorted list of generation numbers of PROFILE, or '(0) if no former profiles were found." (define* (scandir name #:optional (select? (const #t)) (entry<? (@ (ice-9 i18n) string-locale<?))) @@ -139,12 +140,13 @@ former profiles were found." (() ; no profiles '(0)) ((profiles ...) ; former profiles around - (map (compose string->number - (cut match:substring <> 1) - (cute regexp-exec (profile-regexp profile) <>)) - profiles)))) + (sort (map (compose string->number + (cut match:substring <> 1) + (cute regexp-exec (profile-regexp profile) <>)) + profiles) + <)))) -(define (previous-profile-number profile number) +(define (previous-generation-number profile number) "Return the number of the generation before generation NUMBER of PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the case when generations have been deleted (there are \"holes\")." @@ -153,7 +155,7 @@ case when generations have been deleted (there are \"holes\")." candidate highest)) 0 - (profile-numbers profile))) + (generation-numbers profile))) (define (profile-derivation store packages) "Return a derivation that builds a profile (a user environment) with @@ -205,7 +207,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." packages) #:modules '((guix build union)))) -(define (profile-number profile) +(define (generation-number profile) "Return PROFILE's number or 0. An absolute file name must be used." (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) (basename (readlink profile)))) @@ -214,17 +216,17 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (define (roll-back profile) "Roll back to the previous generation of PROFILE." - (let* ((number (profile-number profile)) - (previous-number (previous-profile-number profile number)) - (previous-profile (format #f "~a-~a-link" - profile previous-number)) - (manifest (string-append previous-profile "/manifest"))) + (let* ((number (generation-number profile)) + (previous-number (previous-generation-number profile number)) + (previous-generation (format #f "~a-~a-link" + profile previous-number)) + (manifest (string-append previous-generation "/manifest"))) (define (switch-link) - ;; Atomically switch PROFILE to the previous profile. + ;; Atomically switch PROFILE to the previous generation. (format #t (_ "switching from generation ~a to ~a~%") number previous-number) - (switch-symlinks profile previous-profile)) + (switch-symlinks profile previous-generation)) (cond ((not (file-exists? profile)) ; invalid profile (leave (_ "profile `~a' does not exist~%") @@ -233,19 +235,84 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (format (current-error-port) (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-profile))) - (let*-values (((drv-path drv) - (profile-derivation (%store) '())) - ((prof) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) - (when (not (build-derivations (%store) (list drv-path))) + (not (file-exists? previous-generation))) + (let* ((drv (profile-derivation (%store) '())) + (prof (derivation->output-path drv "out"))) + (when (not (build-derivations (%store) (list drv))) (leave (_ "failed to build the empty profile~%"))) - (switch-symlinks previous-profile prof) + (switch-symlinks previous-generation prof) (switch-link))) (else (switch-link))))) ; anything else +(define (generation-time profile number) + "Return the creation time of a generation in the UTC format." + (make-time time-utc 0 + (stat:ctime (stat (format #f "~a-~a-link" profile number))))) + +(define* (matching-generations str #:optional (profile %current-profile)) + "Return the list of available generations matching a pattern in STR. See +'string->generations' and 'string->duration' for the list of valid patterns." + (define (valid-generations lst) + (define (valid-generation? n) + (any (cut = n <>) (generation-numbers profile))) + + (fold-right (lambda (x acc) + (if (valid-generation? x) + (cons x acc) + acc)) + '() + lst)) + + (define (filter-generations generations) + (match generations + (() '()) + (('>= n) + (drop-while (cut > n <>) + (generation-numbers profile))) + (('<= n) + (valid-generations (iota n 1))) + ((lst ..1) + (valid-generations lst)) + (_ #f))) + + (define (filter-by-duration duration) + (define (time-at-midnight time) + ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and + ;; hours to zeros. + (let ((d (time-utc->date time))) + (date->time-utc + (make-date 0 0 0 0 + (date-day d) (date-month d) + (date-year d) (date-zone-offset d))))) + + (define generation-ctime-alist + (map (lambda (number) + (cons number + (time-second + (time-at-midnight + (generation-time profile number))))) + (generation-numbers profile))) + + (match duration + (#f #f) + (res + (let ((s (time-second + (subtract-duration (time-at-midnight (current-time)) + duration)))) + (delete #f (map (lambda (x) + (and (<= s (cdr x)) + (first x))) + generation-ctime-alist)))))) + + (cond ((string->generations str) + => + filter-generations) + ((string->duration str) + => + filter-by-duration) + (else #f))) + (define (find-packages-by-description rx) "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of matching packages." @@ -441,6 +508,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) --roll-back roll back to the previous generation")) (display (_ " --search-paths display needed environment variable definitions")) + (display (_ " + -l, --list-generations[=PATTERN] + list generations matching PATTERN")) (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) @@ -500,6 +570,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result) + (cons `(query list-generations ,(or arg "")) + result))) (option '("search-paths") #f #f (lambda (opt name arg result) (cons `(query search-paths) result))) @@ -558,7 +632,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define (guile-missing?) ;; Return #t if %GUILE-FOR-BUILD is not available yet. - (let ((out (derivation-path->output-path (%guile-for-build)))) + (let ((out (derivation->output-path (%guile-for-build)))) (not (valid-path? (%store) out)))) (define newest-available-packages @@ -617,7 +691,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (case (version-compare candidate-version current-version) ((>) #t) ((<) #f) - ((=) (let ((candidate-path (derivation-path->output-path + ((=) (let ((candidate-path (derivation->output-path (package-derivation (%store) pkg)))) (not (string=? current-path candidate-path)))))) (#f #f))) @@ -808,7 +882,7 @@ more information.~%")) (match tuple ((name version sub-drv _ (deps ...)) (let ((output-path - (derivation-path->output-path + (derivation->output-path drv sub-drv))) `(,name ,version ,sub-drv ,output-path ,(canonicalize-deps deps)))))) @@ -841,12 +915,12 @@ more information.~%")) (or dry-run? (and (build-derivations (%store) drv) (let* ((prof-drv (profile-derivation (%store) packages)) - (prof (derivation-path->output-path prof-drv)) + (prof (derivation->output-path prof-drv)) (old-drv (profile-derivation (%store) (manifest-packages (profile-manifest profile)))) - (old-prof (derivation-path->output-path old-drv)) - (number (profile-number profile)) + (old-prof (derivation->output-path old-drv)) + (number (generation-number profile)) ;; Always use NUMBER + 1 for the new profile, ;; possibly overwriting a "previous future @@ -879,6 +953,40 @@ more information.~%")) ;; actually processed, #f otherwise. (let ((profile (assoc-ref opts 'profile))) (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation number) + (begin + (format #t (_ "Generation ~a\t~a~%") number + (date->string + (time-utc->date + (generation-time profile number)) + "~b ~d ~Y ~T")) + (for-each (match-lambda + ((name version output location _) + (format #t " ~a\t~a\t~a\t~a~%" + name version output location))) + + ;; Show most recently installed packages last. + (reverse + (manifest-packages + (profile-manifest + (format #f "~a-~a-link" profile number))))) + (newline))) + + (cond ((not (file-exists? profile)) ; XXX: race condition + (leave (_ "profile '~a' does not exist~%") + profile)) + ((string-null? pattern) + (for-each list-generation + (generation-numbers profile))) + ((matching-generations pattern profile) + => + (cut for-each list-generation <>)) + (else + (leave (_ "invalid syntax: ~a~%") + pattern))) + #t) + (('list-installed regexp) (let* ((regexp (and regexp (make-regexp regexp))) (manifest (profile-manifest profile)) @@ -889,7 +997,9 @@ more information.~%")) (regexp-exec regexp name)) (format #t "~a\t~a\t~a\t~a~%" name (or version "?") output path)))) - installed) + + ;; Show most recently installed packages last. + (reverse installed)) #t)) (('list-available regexp) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index adcaa49721..023b83e6a3 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -29,7 +29,6 @@ #:use-module (gnu packages compression) #:use-module (gnu packages gnupg) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) #:export (guix-pull)) @@ -198,13 +197,9 @@ Download and deploy the latest version of Guix.\n")) (if (assoc-ref opts 'verbose?) (current-error-port) (%make-void-port "w")))) - (let*-values (((config-dir) - (config-directory)) - ((source drv) - (unpack store tarball)) - ((source-dir) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) + (let* ((config-dir (config-directory)) + (source (unpack store tarball)) + (source-dir (derivation->output-path source))) (if (show-what-to-build store (list source)) (if (build-derivations store (list source)) (let ((latest (string-append config-dir "/latest"))) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 63f0c4f8d2..1afc93bbc9 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -446,6 +446,30 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;;; +;;; Help. +;;; + +(define (show-help) + (display (_ "Usage: guix substitute-binary [OPTION]... +Internal tool to substitute a pre-built binary to a local build.\n")) + (display (_ " + --query report on the availability of substitutes for the + store file names passed on the standard input")) + (display (_ " + --substitute STORE-FILE DESTINATION + download STORE-FILE and store it as a Nar in file + DESTINATION")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + + +;;; ;;; Entry point. ;;; @@ -536,7 +560,11 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (restore-file input destination) (every (compose zero? cdr waitpid) pids)))) (("--version") - (show-version-and-exit "guix substitute-binary"))))) + (show-version-and-exit "guix substitute-binary")) + (("--help") + (show-help)) + (opts + (leave (_ "~a: unrecognized options~%") opts))))) ;;; Local Variables: diff --git a/guix/store.scm b/guix/store.scm index 541c7c848f..0f1e2f9466 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -452,7 +452,7 @@ encoding conversion errors." (string-list references)) #f store-path))) - (lambda (server name text references) + (lambda* (server name text #:optional (references '())) "Add TEXT under file NAME in the store, and return its store path. REFERENCES is the list of store paths referred to by the resulting store path." diff --git a/guix/ui.scm b/guix/ui.scm index 720d01be02..4415997252 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -28,12 +28,14 @@ #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 regex) #:export (_ N_ leave @@ -50,6 +52,8 @@ fill-paragraph string->recutils package->recutils + string->generations + string->duration args-fold* run-guix-command program-name @@ -210,27 +214,27 @@ derivations listed in DRV. Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are available for download." (let*-values (((build download) - (fold2 (lambda (drv-path build download) - (let ((drv (call-with-input-file drv-path - read-derivation))) - (let-values (((b d) - (derivation-prerequisites-to-build - store drv - #:use-substitutes? - use-substitutes?))) - (values (append b build) - (append d download))))) + (fold2 (lambda (drv build download) + (let-values (((b d) + (derivation-prerequisites-to-build + store drv + #:use-substitutes? + use-substitutes?))) + (values (append b build) + (append d download)))) '() '() drv)) ((build) ; add the DRV themselves (delete-duplicates - (append (remove (compose (lambda (out) - (or (valid-path? store out) - (and use-substitutes? - (has-substitutes? store - out)))) - derivation-path->output-path) - drv) + (append (map derivation-file-name + (remove (lambda (drv) + (let ((out (derivation->output-path + drv))) + (or (valid-path? store out) + (and use-substitutes? + (has-substitutes? store + out))))) + drv)) (map derivation-input-path build)))) ((download) ; add the references of DOWNLOAD (if use-substitutes? @@ -404,6 +408,70 @@ WIDTH columns." (and=> (package-description p) description->recutils)) (newline port)) +(define (string->generations str) + "Return the list of generations matching a pattern in STR. This function +accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"." + (define (maybe-integer) + (let ((x (string->number str))) + (and (integer? x) + x))) + + (define (maybe-comma-separated-integers) + (let ((lst (delete-duplicates + (map string->number + (string-split str #\,))))) + (and (every integer? lst) + lst))) + + (cond ((maybe-integer) + => + list) + ((maybe-comma-separated-integers) + => + identity) + ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str) + => + (lambda (match) + (let ((s (string->number (match:substring match 1))) + (e (string->number (match:substring match 2)))) + (and (every integer? (list s e)) + (<= s e) + (iota (1+ (- e s)) s))))) + ((string-match "^([0-9]+)\\.\\.$" str) + => + (lambda (match) + (let ((s (string->number (match:substring match 1)))) + (and (integer? s) + `(>= ,s))))) + ((string-match "^\\.\\.([0-9]+)$" str) + => + (lambda (match) + (let ((e (string->number (match:substring match 1)))) + (and (integer? e) + `(<= ,e))))) + (else #f))) + +(define (string->duration str) + "Return the duration matching a pattern in STR. This function accepts the +following patterns: \"1d\", \"1w\", \"1m\"." + (define (hours->duration hours match) + (make-time time-duration 0 + (* 3600 hours (string->number (match:substring match 1))))) + + (cond ((string-match "^([0-9]+)d$" str) + => + (lambda (match) + (hours->duration 24 match))) + ((string-match "^([0-9]+)w$" str) + => + (lambda (match) + (hours->duration (* 24 7) match))) + ((string-match "^([0-9]+)m$" str) + => + (lambda (match) + (hours->duration (* 24 30) match))) + (else #f))) + (define (args-fold* options unrecognized-option-proc operand-proc . seeds) "A wrapper on top of `args-fold' that does proper user-facing error reporting." |