From 3df47231e6c632aadcd7b103bb5b399a8d29772d Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 4 Sep 2013 18:04:15 +0200 Subject: guix: python: Switch to python-wrapper as the default version for the python build system (switches to Python 3) and compute python-version instead of passing it as a parameter. * guix/build-system/python.scm (default-python): Switch to python-wrapper. * guix/build-system/python.scm (python-build): Drop parameter #:python-version. * guix/build/python-build-system.scm (wrap): Compute python version from input. --- guix/build-system/python.scm | 6 ++---- guix/build/python-build-system.scm | 4 +++- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index b60adb182f..7ac93b296b 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -39,13 +39,11 @@ (define (default-python) "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* (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) @@ -62,6 +60,7 @@ (define* (python-build store name source inputs (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))) @@ -78,7 +77,6 @@ (define builder #:test-target "test" #:tests? ,tests? #:outputs %outputs - #:python-version ,python-version #:search-paths ',(map search-path-specification->sexp (append python-search-paths search-paths)) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 84299798b0..04c223bb85 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -53,7 +53,7 @@ (define* (check #:key outputs #:allow-other-keys) (zero? (apply system* "python" args))) (error "no setup.py found"))) -(define* (wrap #:key outputs python-version #:allow-other-keys) +(define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) (map (cut string-append dir "/" <>) (or (scandir dir (lambda (f) @@ -69,6 +69,8 @@ (define bindirs outputs)) (let* ((out (assoc-ref outputs "out")) + (python (assoc-ref inputs "python")) + (python-version (string-take (string-take-right python 5) 3)) (var `("PYTHONPATH" prefix ,(cons (string-append out "/lib/python" python-version "/site-packages") -- cgit v1.2.3 From 7b96bf82daf25699ce6b4f4cb2ced1e5318b576f Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 5 Sep 2013 18:43:18 +0200 Subject: gnu: python: Honour #:tests? and #:test-target in build system. * guix/build/python-build-system.scm (check): Use named parameters tests? and test-target (default now: "test" instead of "check"). --- guix/build/python-build-system.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 04c223bb85..27818526fa 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 +;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -45,13 +46,15 @@ (define* (install #:key outputs (configure-flags '()) (zero? (apply system* "python" args))) (error "no setup.py found")))) -(define* (check #:key outputs #:allow-other-keys) +(define* (check #:key outputs tests? test-target #:allow-other-keys) "Run the test suite of a given Python package." - (if (file-exists? "setup.py") - (let ((args `("setup.py" "check"))) - (format #t "running 'python' with arguments ~s~%" args) - (zero? (apply system* "python" args))) - (error "no setup.py found"))) + (if tests? + (if (file-exists? "setup.py") + (let ((args `("setup.py" ,test-target))) + (format #t "running 'python' with arguments ~s~%" args) + (zero? (apply system* "python" args))) + (error "no setup.py found")) + #t)) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) -- cgit v1.2.3 From b191f88ee34576a6908b9b5e94cb7664e88c7e79 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 5 Sep 2013 20:25:08 +0200 Subject: guix: python: Add build phase and factor out calls to setup.py. * guix/build/python-build-system.scm (call-setuppy): New procedure. * guix/build/python-build-system.scm (build): New procedure. * guix/build/python-build-system.scm (check, install): Use call-setuppy. * guix/build/python-build-system.scm (%standard-phases): Add call to build. --- guix/build/python-build-system.scm | 49 ++++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 27818526fa..f213a97f01 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -35,27 +35,33 @@ (define-module (guix build python-build-system) ;; ;; 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 tests? test-target #:allow-other-keys) +(define (call-setuppy command params) + (if (file-exists? "setup.py") + (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* (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? - (if (file-exists? "setup.py") - (let ((args `("setup.py" ,test-target))) - (format #t "running 'python' with arguments ~s~%" args) - (zero? (apply system* "python" args))) - (error "no setup.py found")) + (call-setuppy test-target '()) #t)) +(define* (install #:key outputs (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))) + (call-setuppy "install" params))) + (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) (map (cut string-append dir "/" <>) @@ -92,11 +98,12 @@ (define %standard-phases '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) -- cgit v1.2.3 From 11bb85a10d4a84dab7fdfaaaf7012b743ce7a09f Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sun, 8 Sep 2013 16:57:37 +0200 Subject: guix: python: Add package-with-python2, a procedure rewriting a package to compile with Python 2 instead of the default Python 3. * guix/build-system/python.scm (default-python2, package-with-explicit-python, package-with-python2): New procedures. * guix/build-system/python.scm (python2-pytz, python2-babel): Use package-with-python2. --- gnu/packages/python.scm | 11 +++------ guix/build-system/python.scm | 54 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 56 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index ce89281e26..3ff4da2149 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -28,6 +28,7 @@ (define-module (gnu packages python) #:use-module (gnu packages patchelf) #:use-module (guix packages) #:use-module (guix download) + #:use-module (guix utils) #:use-module (guix build-system gnu) #:use-module (guix build-system python) #:use-module (guix build-system trivial)) @@ -215,9 +216,7 @@ (define-public python-pytz (license x11))) (define-public python2-pytz - (package (inherit python-pytz) - (name "python2-pytz") - (arguments (append (package-arguments python-pytz) `(#:python ,python-2))))) + (package-with-python2 python-pytz)) (define-public python-babel (package @@ -247,8 +246,4 @@ (define-public python-babel (license bsd-3))) (define-public python2-babel - (package (inherit python-babel) - (name "python2-babel") - (inputs - `(("python2-pytz" ,python2-pytz))) - (arguments (append (package-arguments python-babel) `(#:python ,python-2))))) + (package-with-python2 python-babel)) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 7ac93b296b..d120cc9cc3 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 +;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -25,7 +26,9 @@ (define-module (guix build-system python) #: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: @@ -41,6 +44,55 @@ (define (default-python) (let ((python (resolve-interface '(gnu packages 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)) -- cgit v1.2.3 From 1d1f939798d2649bbabc962e37f90efe5805e202 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 10 Sep 2013 11:42:07 +0200 Subject: guix: python: Add parameter #:phases to build system. * guix/build-system/python.scm (python-build): Use parameter #:phases. --- guix/build-system/python.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index d120cc9cc3..d018ee70f3 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -128,6 +128,7 @@ (define builder #:system ,system #:test-target "test" #:tests? ,tests? + #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp (append python-search-paths -- cgit v1.2.3 From e1a264f6fac2f517a2192e07eaae1db600eb8b1d Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 10 Sep 2013 20:32:50 +0200 Subject: guix: python: Do not import %standard-phases from gnu-build-system. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build-system/python.scm (python-build): Drop module gnu-build-system. Thanks to Ludovic Courtès . --- guix/build-system/python.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index d018ee70f3..03e587ba01 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -108,7 +108,6 @@ (define* (python-build store name source inputs (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." -- cgit v1.2.3 From cfbf916045c180c8f77f90e9c910012f18447dc9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Sep 2013 22:36:41 +0200 Subject: store: The 'references' parameter of 'add-text-to-store' is now optional. * guix/store.scm (add-text-to-store): Make 'references' optional. * tests/store.scm ("dead-paths", "references"): Use 'add-text-to-store' with no optional argument. * doc/guix.texi (The Store): Adjust accordingly. --- doc/guix.texi | 2 +- guix/store.scm | 2 +- tests/store.scm | 5 ++--- 3 files changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5b91bc2982..5d1b780144 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1061,7 +1061,7 @@ argument. Return @code{#t} when @var{path} is a valid store path. @end deffn -@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} @var{references} +@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} [@var{references}] Add @var{text} under file @var{name} in the store, and return its store path. @var{references} is the list of store paths referred to by the resulting store path. 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 @@ (define add-text-to-store (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/tests/store.scm b/tests/store.scm index 9625a6b308..0280713191 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -68,8 +68,7 @@ (define (random-text) (test-skip (if %store 0 10)) (test-assert "dead-paths" - (let ((p (add-text-to-store %store "random-text" - (random-text) '()))) + (let ((p (add-text-to-store %store "random-text" (random-text)))) (member p (dead-paths %store)))) ;; FIXME: Find a test for `live-paths'. @@ -99,7 +98,7 @@ (define (random-text) (test-assert "references" (let* ((t1 (add-text-to-store %store "random1" - (random-text) '())) + (random-text))) (t2 (add-text-to-store %store "random2" (random-text) (list t1)))) (and (equal? (list t1) (references %store t2)) -- cgit v1.2.3 From 37c825eb79e18ac61080e626db6cff6552fd5cf4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Sep 2013 00:52:36 +0200 Subject: linux-initrd: Create /dev/klog and /dev/kmsg. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/klog and /dev/kmsg. --- guix/build/linux-initrd.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix') diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b5404da7f0..cbdb363b4e 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -89,6 +89,10 @@ (define (scope dir) (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))) -- cgit v1.2.3 From 824af8cadc1b4f1ac7a859f3d18cbe69b195a844 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 11 Sep 2013 15:47:34 +0200 Subject: guix: python: Create module installation path and add it to PYTHONPATH during the installation phase. * guix/build/python-build-system.scm (get-python-version): New procedure. * guix/build/python-build-system.scm (install): Create and add path. * gnu/packages/python.scm (python-setuptools): Drop path creation code. --- gnu/packages/python.scm | 16 +--------------- guix/build/python-build-system.scm | 23 +++++++++++++++++++---- 2 files changed, 20 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 8f65852630..55d23e45e8 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -262,25 +262,11 @@ (define-public python-setuptools "0hl9sa5xr9bi2ifq51wy1bawsjv5nzvpbac7m9z1ciz778874csf")))) (build-system python-build-system) (arguments - `(#:tests? #f + `(#:tests? #f)) ;;FIXME: test_sdist_with_utf8_encoded_filename fails in ;; /tmp/nix-build-python2-setuptools-1.1.4.drv-0/setuptools-1.1.4/setuptools/tests/test_sdist.py" ;; line 354 ;; The tests pass with Python 2.7.5. - #:phases - (alist-replace - 'install - (lambda* (#:key outputs #:allow-other-keys #:rest args) - (let* ((install (assoc-ref %standard-phases 'install)) - (out (assoc-ref outputs "out")) - (python (assoc-ref %build-inputs "python")) - (python-version (string-take (string-take-right python 5) 3)) - (path (string-append out "/lib/python" python-version - "/site-packages/"))) - (mkdir-p path) - (setenv "PYTHONPATH" path) - (apply install args))) - %standard-phases))) (home-page "https://pypi.python.org/pypi/setuptools") (synopsis "Library designed to facilitate packaging Python projects") diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index f213a97f01..0bb8c4d49d 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -54,12 +54,27 @@ (define* (check #:key tests? test-target #:allow-other-keys) (call-setuppy test-target '()) #t)) -(define* (install #:key outputs (configure-flags '()) +(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))) + 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) @@ -79,10 +94,10 @@ (define bindirs (let* ((out (assoc-ref outputs "out")) (python (assoc-ref inputs "python")) - (python-version (string-take (string-take-right python 5) 3)) (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) -- cgit v1.2.3 From 1b0a8212d1dc736610c1e87bfeb0ae8bf39ed23d Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Thu, 12 Sep 2013 17:31:53 +0000 Subject: guix package: Rename generation-related procedures. * guix/scripts/package.scm (profile-numbers): Rename to 'generation-numbers'. (previous-profile-number): Rename to 'previous-generation-number'. (profile-number): Rename to 'generation-number'. (roll-back): Rename 'previous-profile' to 'previous-generation'. --- guix/scripts/package.scm | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5c3947dd63..1393ca3180 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -95,7 +95,7 @@ (define (profile-regexp profile) (make-regexp (string-append "^" (regexp-quote (basename profile)) "-([0-9]+)"))) -(define (profile-numbers profile) +(define (generation-numbers profile) "Return the list of generation numbers of PROFILE, or '(0) if no former profiles were found." (define* (scandir name #:optional (select? (const #t)) @@ -144,7 +144,7 @@ (define (error name* stat errno result) (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 +153,7 @@ (define (previous-profile-number profile number) 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 +205,7 @@ (define ensure-valid-input 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 +214,17 @@ (define (profile-number profile) (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,7 +233,7 @@ (define (switch-link) (format (current-error-port) (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-profile))) + (not (file-exists? previous-generation))) (let*-values (((drv-path drv) (profile-derivation (%store) '())) ((prof) @@ -242,7 +242,7 @@ (define (switch-link) (when (not (build-derivations (%store) (list drv-path))) (leave (_ "failed to build the empty profile~%"))) - (switch-symlinks previous-profile prof) + (switch-symlinks previous-generation prof) (switch-link))) (else (switch-link))))) ; anything else @@ -846,7 +846,7 @@ (define (show-what-to-remove/install remove install dry-run?) (%store) (manifest-packages (profile-manifest profile)))) (old-prof (derivation-path->output-path old-drv)) - (number (profile-number profile)) + (number (generation-number profile)) ;; Always use NUMBER + 1 for the new profile, ;; possibly overwriting a "previous future -- cgit v1.2.3 From 29479de5659ba912b486c74078403bbb9a4df104 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Sep 2013 23:42:36 +0200 Subject: substitute-binary: Add '--help'. Reported by Nikita Karetnikov . * guix/scripts/substitute-binary.scm (show-help): New procedure. (guix-substitute-binary): Add '--help'. --- guix/scripts/substitute-binary.scm | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) (limited to 'guix') 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 @@ -444,6 +444,30 @@ (define-syntax with-networking (leave (_ "host name lookup error: ~a~%") (gai-strerror error))))))) + +;;; +;;; 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 @@ (define (guix-substitute-binary . args) (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: -- cgit v1.2.3 From 6a446d56801bfb197b1561bbe660675caa31c96c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 17 Sep 2013 23:00:55 +0200 Subject: derivations: Keep the .drv file name in objects. * guix/derivations.scm (): Add 'file-name' field. (%read-derivation): Use (port-filename DRV-PORT) as the file name for the result. (derivation): Set the 'file-name' field in the result. * tests/derivations.scm ("build derivation with 1 source"): Assert that 'derivation-file-name' returns the right thing. --- guix/derivations.scm | 40 ++++++++++++++++++++++++++-------------- tests/derivations.scm | 1 + 2 files changed, 27 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index c05644add2..f0f9ec7c21 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -36,6 +36,7 @@ (define-module (guix derivations) derivation-system derivation-builder-arguments derivation-builder-environment-vars + derivation-file-name derivation-prerequisites derivation-prerequisites-to-build @@ -71,7 +72,8 @@ (define-module (guix derivations) ;;; (define-record-type - (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/ pairs (inputs derivation-inputs) ; list of @@ -79,7 +81,8 @@ (define-record-type (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 (make-derivation-output path hash-algo hash) @@ -262,7 +265,8 @@ (define (make-input-drvs x) (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)) @@ -470,7 +474,8 @@ (define derivation-hash ; `hashDerivationModulo' in derivations.cc (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 @@ -545,7 +550,8 @@ (define (add-output-paths drv) (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,6 +584,14 @@ (define (env-vars-with-empty-outputs env-vars) e outputs))) + (define (set-file-name drv file) + ;; Set FILE as the 'file-name' field of DRV. + (match drv + (($ 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 @@ -604,17 +618,15 @@ (define (env-vars-with-empty-outputs env-vars) (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)))) + (values file (set-file-name drv file))))) ;;; diff --git a/tests/derivations.scm b/tests/derivations.scm index 9092e3acd6..e69dd0db31 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -134,6 +134,7 @@ (define prefix-len (string-length dir)) (let ((path (derivation-output-path (assoc-ref (derivation-outputs drv) "out")))) (and (valid-path? %store path) + (string=? (derivation-file-name drv) drv-path) (string=? (call-with-input-file path read-line) "hello, world")))))) -- cgit v1.2.3 From 07c86312ca96d095ff5ebeae37940fd7c726c3e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Sep 2013 11:10:02 +0200 Subject: derivations: Add a nicer printer. * guix/derivations.scm (): Add a printer. --- guix/derivations.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index f0f9ec7c21..43ea328b0e 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) @@ -97,6 +98,17 @@ (define-record-type (path derivation-input-path) ; store path (sub-derivations derivation-input-sub-derivations)) ; list of strings +(set-record-type-printer! + (lambda (drv port) + (format port "# ~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')." -- cgit v1.2.3 From 59688fc4b5cfac3e05610195a47795f5cc15f338 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Sep 2013 17:01:40 +0200 Subject: derivations: 'derivation' and related procedures return a single value. * guix/derivations.scm (derivation->output-path, derivation->output-paths): New procedures. (derivation-path->output-path): Use 'derivation->output-path'. (derivation-path->output-paths): Use 'derivation->output-paths'. (derivation): Accept 'derivation?' objects as inputs. Return a single value. (build-derivations): New procedure. (compiled-modules): Use 'derivation->output-paths'. (build-expression->derivation)[source-path]: Add case for when the input matches 'derivation?'. [prologue]: Accept 'derivation?' objects in INPUTS. [mod-dir, go-dir]: Use 'derivation->output-path'. * guix/download.scm (url-fetch): Adjust to the single-value return. * guix/packages.scm (package-output): Use 'derivation->output-path'. * guix/scripts/build.scm (guix-build): When the argument is 'derivation-path?', pass it through 'read-derivation'. Use 'derivation-file-name' to print out the .drv file names, and to register them. Use 'derivation->output-path' instead of 'derivation-path->output-path'. * guix/scripts/package.scm (roll-back): Adjust to the single-value return. (guix-package): Use 'derivation->output-path'. * guix/ui.scm (show-what-to-build): Adjust to deal with 'derivation?' objects instead of .drv file names. * gnu/system/grub.scm (grub-configuration-file): Use 'derivation->output-path' instead of 'derivation-path->output-path'. * gnu/system/vm.scm (qemu-image, system-qemu-image): Likewise. * tests/builders.scm, tests/derivations.scm, tests/packages.scm, tests/store.scm, tests/union.scm: Adjust to the new calling convention. * doc/guix.texi (Defining Packages, The Store, Derivations): Adjust accordingly. --- doc/guix.texi | 37 ++++---- gnu/system/grub.scm | 6 +- gnu/system/vm.scm | 12 +-- guix/build-system/cmake.scm | 6 +- guix/build-system/gnu.scm | 20 ++-- guix/build-system/perl.scm | 4 +- guix/build-system/python.scm | 4 +- guix/derivations.scm | 79 +++++++++++----- guix/download.scm | 32 +++---- guix/packages.scm | 11 +-- guix/scripts/build.scm | 23 +++-- guix/scripts/package.scm | 19 ++-- guix/ui.scm | 34 +++---- tests/builders.scm | 8 +- tests/derivations.scm | 219 ++++++++++++++++++++----------------------- tests/packages.scm | 38 ++++---- tests/store.scm | 31 +++--- tests/union.scm | 2 +- 18 files changed, 295 insertions(+), 290 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5d1b780144..92c163c608 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -987,8 +987,8 @@ The build actions it prescribes may then be realized by using the @code{build-derivations} procedure (@pxref{The Store}). @deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}] -Return the derivation path and corresponding @code{} object -of @var{package} for @var{system} (@pxref{Derivations}). +Return the @code{} object of @var{package} for @var{system} +(@pxref{Derivations}). @var{package} must be a valid @code{} object, and @var{system} must be a string denoting the target system type---e.g., @@ -1004,8 +1004,8 @@ package for some other system: @deffn {Scheme Procedure} package-cross-derivation @var{store} @ @var{package} @var{target} [@var{system}] -Return the derivation path and corresponding @code{} object -of @var{package} cross-built from @var{system} to @var{target}. +Return the @code{} object of @var{package} cross-built from +@var{system} to @var{target}. @var{target} must be a valid GNU triplet denoting the target hardware and operating system, such as @code{"mips64el-linux-gnu"} @@ -1068,8 +1068,9 @@ resulting store path. @end deffn @deffn {Scheme Procedure} build-derivations @var{server} @var{derivations} -Build @var{derivations} (a list of derivation paths), and return when -the worker is done building them. Return @code{#t} on success. +Build @var{derivations} (a list of @code{} objects or +derivation paths), and return when the worker is done building them. +Return @code{#t} on success. @end deffn @c FIXME @@ -1119,8 +1120,8 @@ otherwise manipulate derivations. The lowest-level primitive to create a derivation is the @code{derivation} procedure: @deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:references-graphs #f] -Build a derivation with the given arguments. Return the resulting store -path and @code{} object. +Build a derivation with the given arguments, and return the resulting +@code{} object. When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a @dfn{fixed-output derivation} is created---i.e., one whose result is @@ -1142,16 +1143,13 @@ to a Bash executable in the store: (guix store) (guix derivations)) -(call-with-values - (lambda () - (let ((builder ; add the Bash script to the store - (add-text-to-store store "my-builder.sh" - "echo hello world > $out\n" '()))) - (derivation store "foo" - bash `("-e" ,builder) - #:env-vars '(("HOME" . "/homeless"))))) - list) -@result{} ("/nix/store/@dots{}-foo.drv" #< @dots{}>) +(let ((builder ; add the Bash script to the store + (add-text-to-store store "my-builder.sh" + "echo hello world > $out\n" '()))) + (derivation store "foo" + bash `("-e" ,builder) + #:env-vars '(("HOME" . "/homeless")))) +@result{} # /nix/store/@dots{}-foo> @end lisp As can be guessed, this primitive is cumbersome to use directly. An @@ -1196,8 +1194,7 @@ containing one file: (build-expression->derivation store "goo" (%current-system) builder '())) -@result{} "/nix/store/@dots{}-goo.drv" -@result{} #< @dots{}> +@result{} # @dots{}> @end lisp @cindex strata of code diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 695a044bfa..b2438b9c5b 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -56,7 +56,7 @@ (define prologue (any (match-lambda (($ _ linux) (let* ((drv (package-derivation store linux system)) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (string-append out "/bzImage")))) entries))) @@ -71,9 +71,9 @@ (define entry->text initrd ~a/initrd }~%" label - (derivation-path->output-path linux-drv) + (derivation->output-path linux-drv) (string-join arguments) - (derivation-path->output-path initrd-drv)))))) + (derivation->output-path initrd-drv)))))) (add-text-to-store store "grub.cfg" (string-append prologue diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 192ed1d5a3..68d205d82a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -206,10 +206,10 @@ (define* (qemu-image store #:key (define input->name+derivation (match-lambda ((name (? package? package)) - `(,name . ,(derivation-path->output-path + `(,name . ,(derivation->output-path (package-derivation store package system)))) ((name (? package? package) sub-drv) - `(,name . ,(derivation-path->output-path + `(,name . ,(derivation->output-path (package-derivation store package system) sub-drv))) ((input (and (? string?) (? store-path?) file)) @@ -361,14 +361,14 @@ (define %pam-services (parameterize ((%guile-for-build (package-derivation store guile-final))) (let* ((bash-drv (package-derivation store bash)) - (bash-file (string-append (derivation-path->output-path bash-drv) + (bash-file (string-append (derivation->output-path bash-drv) "/bin/bash")) (accounts (list (vector "root" "" 0 0 "System administrator" "/" bash-file))) (passwd (passwd-file store accounts)) (shadow (passwd-file store accounts #:shadow? #t)) (pam.d-drv (pam-services->directory store %pam-services)) - (pam.d (derivation-path->output-path pam.d-drv)) + (pam.d (derivation->output-path pam.d-drv)) (populate (add-text-to-store store "populate-qemu-image" (object->string @@ -381,11 +381,11 @@ (define %pam-services (symlink ,pam.d "etc/pam.d") (mkdir-p "var/run"))) (list passwd))) - (out (derivation-path->output-path + (out (derivation->output-path (package-derivation store mingetty))) (getty (string-append out "/sbin/mingetty")) (iu-drv (package-derivation store inetutils)) - (syslogd (string-append (derivation-path->output-path iu-drv) + (syslogd (string-append (derivation->output-path iu-drv) "/libexec/syslogd")) (boot (add-text-to-store store "boot" (object->string 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 @@ (define* (cmake-build store name source inputs (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 @@ (define implicit-search-paths (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 @@ (define guile-for-build (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 @@ (define builder (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 @@ (define %build-host-inputs (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 @@ (define %build-target-inputs `(,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 @@ (define guile-for-build (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 @@ (define builder `(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 03e587ba01..cf7ca7d3e1 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -120,8 +120,8 @@ (define builder `(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 diff --git a/guix/derivations.scm b/guix/derivations.scm index 43ea328b0e..433a8f145e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -58,6 +58,8 @@ (define-module (guix derivations) read-derivation write-derivation + derivation->output-path + derivation->output-paths derivation-path->output-path derivation-path->output-paths derivation @@ -66,7 +68,8 @@ (define-module (guix derivations) imported-modules compiled-modules build-expression->derivation - imported-files)) + imported-files) + #:replace (build-derivations)) ;;; ;;; Nix derivations, as implemented in Nix's `derivations.cc'. @@ -420,25 +423,30 @@ (define (write-env-var env-var port) 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))) ;;; @@ -522,10 +530,10 @@ (define* (derivation store name builder args (inputs '()) (outputs '("out")) hash hash-algo hash-mode references-graphs) - "Build a derivation with the given arguments. Return the resulting -store path and 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 + 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 @@ -610,6 +618,12 @@ (define (set-file-name drv file) (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 ...) @@ -638,7 +652,21 @@ (define (set-file-name drv file) (cut write-derivation drv <>)) (map derivation-input-path inputs)))) - (values file (set-file-name drv file))))) + (set-file-name drv file)))) + + +;;; +;;; Store compatibility layer. +;;; + +(define (build-derivations store derivations) + "Build DERIVATIONS, a list of objects or .drv file names." + (let ((build (@ (guix store) build-derivations))) + (build store (map (match-lambda + ((? string? file) file) + ((and drv ($ )) + (derivation-file-name drv))) + derivations)))) ;;; @@ -730,7 +758,7 @@ (define* (compiled-modules store modules #: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) "/"))) @@ -794,7 +822,7 @@ (define guile-drv (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? @@ -806,6 +834,8 @@ (define source-path ;; 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)))) @@ -830,10 +860,13 @@ (define %build-inputs (() "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) @@ -878,13 +911,13 @@ (define %build-inputs #: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 @@ (define-module (guix download) #: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 @@ (define need-gnutls? ((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/packages.scm b/guix/packages.scm index f63727dd32..efec414675 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,7 +26,6 @@ (define-module (guix packages) #: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 @@ (define derivation (define* (package-derivation store package #:optional (system (%current-system))) - "Return the derivation path and corresponding object of -PACKAGE for SYSTEM." + "Return the 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 @@ (define* (package-output store package output "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 @@ (define package->derivation (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 @@ (define package->derivation (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 1393ca3180..862b82612a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -234,12 +234,9 @@ (define (switch-link) (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-generation))) - (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))) + (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-generation prof) @@ -558,7 +555,7 @@ (define (parse-options) (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 +614,7 @@ (define (upgradeable? name current-version current-path) (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 +805,7 @@ (define (show-what-to-remove/install remove install dry-run?) (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,11 +838,11 @@ (define (show-what-to-remove/install remove install dry-run?) (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)) + (old-prof (derivation->output-path old-drv)) (number (generation-number profile)) ;; Always use NUMBER + 1 for the new profile, diff --git a/guix/ui.scm b/guix/ui.scm index 720d01be02..293730308e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -210,27 +210,27 @@ (define* (show-what-to-build store drv 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? diff --git a/tests/builders.scm b/tests/builders.scm index 1e6b62ee6a..0ed5d74a22 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -70,10 +70,10 @@ (define network-reachable? "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")) (hash (nix-base32-string->bytevector "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) - (drv-path (url-fetch %store url 'sha256 hash + (drv (url-fetch %store url 'sha256 hash #:guile %bootstrap-guile)) - (out-path (derivation-path->output-path drv-path))) - (and (build-derivations %store (list drv-path)) + (out-path (derivation->output-path drv))) + (and (build-derivations %store (list drv)) (file-exists? out-path) (valid-path? %store out-path)))) @@ -93,7 +93,7 @@ (define network-reachable? #:implicit-inputs? #f #:guile %bootstrap-guile #:search-paths %bootstrap-search-paths)) - (out (derivation-path->output-path build))) + (out (derivation->output-path build))) (and (build-derivations %store (list (pk 'hello-drv build))) (valid-path? %store out) (file-exists? (string-append out "/bin/hello"))))) diff --git a/tests/derivations.scm b/tests/derivations.scm index e69dd0db31..4756fb9cba 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -110,31 +110,27 @@ (define prefix-len (string-length dir)) (let* ((builder (add-text-to-store %store "my-builder.sh" "echo hello, world\n" '())) - (drv-path (derivation %store "foo" + (drv (derivation %store "foo" %bash `("-e" ,builder) #:env-vars '(("HOME" . "/homeless"))))) - (and (store-path? drv-path) - (valid-path? %store drv-path)))) + (and (store-path? (derivation-file-name drv)) + (valid-path? %store (derivation-file-name drv))))) (test-assert "build derivation with 1 source" - (let*-values (((builder) - (add-text-to-store %store "my-builder.sh" - "echo hello, world > \"$out\"\n" - '())) - ((drv-path drv) - (derivation %store "foo" - %bash `(,builder) - #:env-vars '(("HOME" . "/homeless") - ("zzz" . "Z!") - ("AAA" . "A!")) - #:inputs `((,builder)))) - ((succeeded?) - (build-derivations %store (list drv-path)))) + (let* ((builder (add-text-to-store %store "my-builder.sh" + "echo hello, world > \"$out\"\n" + '())) + (drv (derivation %store "foo" + %bash `(,builder) + #:env-vars '(("HOME" . "/homeless") + ("zzz" . "Z!") + ("AAA" . "A!")) + #:inputs `((,builder)))) + (succeeded? + (build-derivations %store (list drv)))) (and succeeded? - (let ((path (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) + (let ((path (derivation->output-path drv))) (and (valid-path? %store path) - (string=? (derivation-file-name drv) drv-path) (string=? (call-with-input-file path read-line) "hello, world")))))) @@ -146,7 +142,7 @@ (define prefix-len (string-length dir)) (input (search-path %load-path "ice-9/boot-9.scm")) (input* (add-to-store %store (basename input) #t "sha256" input)) - (drv-path (derivation %store "derivation-with-input-file" + (drv (derivation %store "derivation-with-input-file" %bash `(,builder) ;; Cheat to pass the actual file name to the @@ -155,22 +151,22 @@ (define prefix-len (string-length dir)) #:inputs `((,builder) (,input))))) ; ← local file name - (and (build-derivations %store (list drv-path)) + (and (build-derivations %store (list drv)) ;; Note: we can't compare the files because the above trick alters ;; the contents. - (valid-path? %store (derivation-path->output-path drv-path))))) + (valid-path? %store (derivation->output-path drv))))) (test-assert "fixed-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo -n hello > $out" '())) (hash (sha256 (string->utf8 "hello"))) - (drv-path (derivation %store "fixed" + (drv (derivation %store "fixed" %bash `(,builder) #:inputs `((,builder)) ; optional #:hash hash #:hash-algo 'sha256)) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (and (equal? (string->utf8 "hello") (call-with-input-file p get-bytevector-all)) (bytevector? (query-path-hash %store p))))))) @@ -181,17 +177,16 @@ (define prefix-len (string-length dir)) (builder2 (add-text-to-store %store "fixed-builder2.sh" "echo hey; echo -n hello > $out" '())) (hash (sha256 (string->utf8 "hello"))) - (drv-path1 (derivation %store "fixed" + (drv1 (derivation %store "fixed" %bash `(,builder1) #:hash hash #:hash-algo 'sha256)) - (drv-path2 (derivation %store "fixed" + (drv2 (derivation %store "fixed" %bash `(,builder2) #:hash hash #:hash-algo 'sha256)) - (succeeded? (build-derivations %store - (list drv-path1 drv-path2)))) + (succeeded? (build-derivations %store (list drv1 drv2)))) (and succeeded? - (equal? (derivation-path->output-path drv-path1) - (derivation-path->output-path drv-path2))))) + (equal? (derivation->output-path drv1) + (derivation->output-path drv2))))) (test-assert "derivation with a fixed-output input" ;; A derivation D using a fixed-output derivation F doesn't has the same @@ -208,7 +203,7 @@ (define prefix-len (string-length dir)) (fixed2 (derivation %store "fixed" %bash `(,builder2) #:hash hash #:hash-algo 'sha256)) - (fixed-out (derivation-path->output-path fixed1)) + (fixed-out (derivation->output-path fixed1)) (builder3 (add-text-to-store %store "final-builder.sh" ;; Use Bash hackery to avoid Coreutils. @@ -224,26 +219,26 @@ (define prefix-len (string-length dir)) (succeeded? (build-derivations %store (list final1 final2)))) (and succeeded? - (equal? (derivation-path->output-path final1) - (derivation-path->output-path final2))))) + (equal? (derivation->output-path final1) + (derivation->output-path final2))))) (test-assert "multiple-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo one > $out ; echo two > $second" '())) - (drv-path (derivation %store "fixed" + (drv (derivation %store "fixed" %bash `(,builder) #:env-vars '(("HOME" . "/homeless") ("zzz" . "Z!") ("AAA" . "A!")) #:inputs `((,builder)) #:outputs '("out" "second"))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((one (derivation-path->output-path drv-path "out")) - (two (derivation-path->output-path drv-path "second"))) + (let ((one (derivation->output-path drv "out")) + (two (derivation->output-path drv "second"))) (and (lset= equal? - (derivation-path->output-paths drv-path) + (derivation->output-paths drv) `(("out" . ,one) ("second" . ,two))) (eq? 'one (call-with-input-file one read)) (eq? 'two (call-with-input-file two read))))))) @@ -254,14 +249,14 @@ (define prefix-len (string-length dir)) (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo one > $out ; echo two > $AAA" '())) - (drv-path (derivation %store "fixed" + (drv (derivation %store "fixed" %bash `(,builder) #:inputs `((,builder)) #:outputs '("out" "AAA"))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((one (derivation-path->output-path drv-path "out")) - (two (derivation-path->output-path drv-path "AAA"))) + (let ((one (derivation->output-path drv "out")) + (two (derivation->output-path drv "AAA"))) (and (eq? 'one (call-with-input-file one read)) (eq? 'two (call-with-input-file two read))))))) @@ -283,17 +278,17 @@ (define prefix-len (string-length dir)) (udrv (derivation %store "multiple-output-user" %bash `(,builder2) #:env-vars `(("one" - . ,(derivation-path->output-path + . ,(derivation->output-path mdrv "out")) ("two" - . ,(derivation-path->output-path + . ,(derivation->output-path mdrv "two"))) #:inputs `((,builder2) ;; two occurrences of MDRV: (,mdrv) (,mdrv "two"))))) (and (build-derivations %store (list (pk 'udrv udrv))) - (let ((p (derivation-path->output-path udrv))) + (let ((p (derivation->output-path udrv))) (and (valid-path? %store p) (equal? '(one two) (call-with-input-file p read))))))) @@ -318,7 +313,7 @@ (define prefix-len (string-length dir)) ("input1" . ,input1) ("input2" . ,input2)) #:inputs `((,%bash) (,builder)))) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (define (deps path . deps) (let ((count (length deps))) (string-append path "\n\n" (number->string count) "\n" @@ -361,31 +356,30 @@ (define %coreutils (add-text-to-store %store "build-with-coreutils.sh" "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good" '())) - (drv-path + (drv (derivation %store "foo" %bash `(,builder) #:env-vars `(("PATH" . ,(string-append - (derivation-path->output-path %coreutils) + (derivation->output-path %coreutils) "/bin"))) #:inputs `((,builder) (,%coreutils)))) (succeeded? - (build-derivations %store (list drv-path)))) + (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (and (valid-path? %store p) (file-exists? (string-append p "/good"))))))) (test-skip (if (%guile-for-build) 0 8)) (test-assert "build-expression->derivation and derivation-prerequisites" - (let-values (((drv-path drv) - (build-expression->derivation %store "fail" (%current-system) - #f '()))) + (let ((drv (build-expression->derivation %store "fail" (%current-system) + #f '()))) (any (match-lambda (($ path) - (string=? path (%guile-for-build)))) + (string=? path (derivation-file-name (%guile-for-build))))) (derivation-prerequisites drv)))) (test-assert "build-expression->derivation without inputs" @@ -394,11 +388,11 @@ (define %coreutils (call-with-output-file (string-append %output "/test") (lambda (p) (display '(hello guix) p))))) - (drv-path (build-expression->derivation %store "goo" (%current-system) + (drv (build-expression->derivation %store "goo" (%current-system) builder '())) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (equal? '(hello guix) (call-with-input-file (string-append p "/test") read)))))) @@ -407,43 +401,35 @@ (define %coreutils (set-build-options s #:max-silent-time 1) s)) (builder '(sleep 100)) - (drv-path (build-expression->derivation %store "silent" + (drv (build-expression->derivation %store "silent" (%current-system) builder '())) - (out-path (derivation-path->output-path drv-path))) + (out-path (derivation->output-path drv))) (guard (c ((nix-protocol-error? c) (and (string-contains (nix-protocol-error-message c) "failed") (not (valid-path? store out-path))))) - (build-derivations %store (list drv-path))))) + (build-derivations %store (list drv))))) (test-assert "build-expression->derivation and derivation-prerequisites-to-build" - (let-values (((drv-path drv) - (build-expression->derivation %store "fail" (%current-system) - #f '()))) + (let ((drv (build-expression->derivation %store "fail" (%current-system) + #f '()))) ;; The only direct dependency is (%guile-for-build) and it's already ;; built. (null? (derivation-prerequisites-to-build %store drv)))) (test-assert "derivation-prerequisites-to-build when outputs already present" - (let*-values (((builder) - '(begin (mkdir %output) #t)) - ((input-drv-path input-drv) - (build-expression->derivation %store "input" - (%current-system) - builder '())) - ((input-path) - (derivation-output-path - (assoc-ref (derivation-outputs input-drv) - "out"))) - ((drv-path drv) - (build-expression->derivation %store "something" - (%current-system) - builder - `(("i" ,input-drv-path)))) - ((output) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) + (let* ((builder '(begin (mkdir %output) #t)) + (input-drv (build-expression->derivation %store "input" + (%current-system) + builder '())) + (input-path (derivation-output-path + (assoc-ref (derivation-outputs input-drv) + "out"))) + (drv (build-expression->derivation %store "something" + (%current-system) builder + `(("i" ,input-drv)))) + (output (derivation->output-path drv))) ;; Make sure these things are not already built. (when (valid-path? %store input-path) (delete-paths %store (list input-path))) @@ -452,10 +438,10 @@ (define %coreutils (and (equal? (map derivation-input-path (derivation-prerequisites-to-build %store drv)) - (list input-drv-path)) + (list (derivation-file-name input-drv))) ;; Build DRV and delete its input. - (build-derivations %store (list drv-path)) + (build-derivations %store (list drv)) (delete-paths %store (list input-path)) (not (valid-path? %store input-path)) @@ -465,17 +451,12 @@ (define %coreutils (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) (test-assert "derivation-prerequisites-to-build and substitutes" - (let*-values (((store) - (open-connection)) - ((drv-path drv) - (build-expression->derivation store "prereq-subst" + (let* ((store (open-connection)) + (drv (build-expression->derivation store "prereq-subst" (%current-system) (random 1000) '())) - ((output) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out"))) - ((dir) - (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") + (output (derivation->output-path drv)) + (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. (call-with-output-file (string-append dir "/nix-cache-info") @@ -495,7 +476,8 @@ (define %coreutils output ; StorePath (string-append dir "/example.nar") ; URL (%current-system) ; System - (basename drv-path)))) ; Deriver + (basename + (derivation-file-name drv))))) ; Deriver (let-values (((build download) (derivation-prerequisites-to-build store drv)) @@ -512,16 +494,16 @@ (define %coreutils (let* ((builder '(begin (mkdir %output) #f)) ; fail! - (drv-path (build-expression->derivation %store "fail" (%current-system) + (drv (build-expression->derivation %store "fail" (%current-system) builder '())) - (out-path (derivation-path->output-path drv-path))) + (out-path (derivation->output-path drv))) (guard (c ((nix-protocol-error? c) ;; Note that the output path may exist at this point, but it ;; is invalid. (and (string-match "build .* failed" (nix-protocol-error-message c)) (not (valid-path? %store out-path))))) - (build-derivations %store (list drv-path)) + (build-derivations %store (list drv)) #f))) (test-assert "build-expression->derivation with two outputs" @@ -532,15 +514,15 @@ (define %coreutils (call-with-output-file (assoc-ref %outputs "second") (lambda (p) (display '(world) p))))) - (drv-path (build-expression->derivation %store "double" + (drv (build-expression->derivation %store "double" (%current-system) builder '() #:outputs '("out" "second"))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((one (derivation-path->output-path drv-path)) - (two (derivation-path->output-path drv-path "second"))) + (let ((one (derivation->output-path drv)) + (two (derivation->output-path drv "second"))) (and (equal? '(hello) (call-with-input-file one read)) (equal? '(world) (call-with-input-file two read))))))) @@ -553,12 +535,12 @@ (define %coreutils (dup2 (port->fdes p) 1) (execl (string-append cu "/bin/uname") "uname" "-a"))))) - (drv-path (build-expression->derivation %store "uname" (%current-system) + (drv (build-expression->derivation %store "uname" (%current-system) builder `(("cu" ,%coreutils)))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (string-contains (call-with-input-file p read-line) "GNU"))))) (test-assert "imported-files" @@ -567,9 +549,9 @@ (define %coreutils "guix/derivations.scm")) ("p/q" . ,(search-path %load-path "guix.scm")) ("p/z" . ,(search-path %load-path "guix/store.scm")))) - (drv-path (imported-files %store files))) - (and (build-derivations %store (list drv-path)) - (let ((dir (derivation-path->output-path drv-path))) + (drv (imported-files %store files))) + (and (build-derivations %store (list drv)) + (let ((dir (derivation->output-path drv))) (every (match-lambda ((path . source) (equal? (call-with-input-file (string-append dir "/" path) @@ -584,14 +566,13 @@ (define %coreutils (let ((out (assoc-ref %outputs "out"))) (mkdir-p (string-append out "/guile/guix/nix")) #t))) - (drv-path (build-expression->derivation %store - "test-with-modules" + (drv (build-expression->derivation %store "test-with-modules" (%current-system) builder '() #:modules '((guix build utils))))) - (and (build-derivations %store (list drv-path)) - (let* ((p (derivation-path->output-path drv-path)) + (and (build-derivations %store (list drv)) + (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix")))) (eq? (stat:type s) 'directory))))) @@ -615,9 +596,10 @@ (define %coreutils #:hash-algo 'sha256)) (succeeded? (build-derivations %store (list input1 input2)))) (and succeeded? - (not (string=? input1 input2)) - (string=? (derivation-path->output-path input1) - (derivation-path->output-path input2))))) + (not (string=? (derivation-file-name input1) + (derivation-file-name input2))) + (string=? (derivation->output-path input1) + (derivation->output-path input2))))) (test-assert "build-expression->derivation with a fixed-output input" (let* ((builder1 '(call-with-output-file %output @@ -649,8 +631,11 @@ (define %coreutils (%current-system) builder3 `(("input" ,input2))))) - (and (string=? (derivation-path->output-path final1) - (derivation-path->output-path final2)) + (and (string=? (derivation->output-path final1) + (derivation->output-path final2)) + (string=? (derivation->output-path final1) + (derivation-path->output-path + (derivation-file-name final1))) (build-derivations %store (list final1 final2))))) (test-assert "build-expression->derivation with #:references-graphs" @@ -662,7 +647,7 @@ (define %coreutils builder '() #:references-graphs `(("input" . ,input)))) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (define (deps path . deps) (let ((count (length deps))) (string-append path "\n\n" (number->string count) "\n" diff --git a/tests/packages.scm b/tests/packages.scm index 8619011f59..706739fb70 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -121,17 +121,16 @@ (define read-at (package-source package)))) (string=? file source))) -(test-assert "return values" - (let-values (((drv-path drv) - (package-derivation %store (dummy-package "p")))) - (and (derivation-path? drv-path) - (derivation? drv)))) +(test-assert "return value" + (let ((drv (package-derivation %store (dummy-package "p")))) + (and (derivation? drv) + (file-exists? (derivation-file-name drv))))) (test-assert "package-output" (let* ((package (dummy-package "p")) - (drv-path (package-derivation %store package))) - (and (derivation-path? drv-path) - (string=? (derivation-path->output-path drv-path) + (drv (package-derivation %store package))) + (and (derivation? drv) + (string=? (derivation->output-path drv) (package-output %store package "out"))))) (test-assert "trivial" @@ -148,7 +147,7 @@ (define read-at (display '(hello guix) p)))))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) - (let ((p (pk 'drv d (derivation-path->output-path d)))) + (let ((p (pk 'drv d (derivation->output-path d)))) (equal? '(hello guix) (call-with-input-file (string-append p "/test") read)))))) @@ -164,7 +163,7 @@ (define read-at (inputs `(("input" ,i))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) - (let ((p (pk 'drv d (derivation-path->output-path d)))) + (let ((p (pk 'drv d (derivation->output-path d)))) (equal? (call-with-input-file p get-bytevector-all) (call-with-input-file i get-bytevector-all)))))) @@ -183,7 +182,7 @@ (define read-at (%current-system))))))) (d (package-derivation %store p))) (and (build-derivations %store (list d)) - (let ((p (pk 'drv d (derivation-path->output-path d)))) + (let ((p (pk 'drv d (derivation->output-path d)))) (eq? 'hello (call-with-input-file p read)))))) (test-assert "search paths" @@ -222,20 +221,17 @@ (define read-at (equal? x (collect (package-derivation %store c))))))) (test-assert "package-cross-derivation" - (let-values (((drv-path drv) - (package-cross-derivation %store (dummy-package "p") - "mips64el-linux-gnu"))) - (and (derivation-path? drv-path) - (derivation? drv)))) + (let ((drv (package-cross-derivation %store (dummy-package "p") + "mips64el-linux-gnu"))) + (and (derivation? drv) + (file-exists? (derivation-file-name drv))))) (test-assert "package-cross-derivation, trivial-build-system" (let ((p (package (inherit (dummy-package "p")) (build-system trivial-build-system) (arguments '(#:builder (exit 1)))))) - (let-values (((drv-path drv) - (package-cross-derivation %store p "mips64el-linux-gnu"))) - (and (derivation-path? drv-path) - (derivation? drv))))) + (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu"))) + (derivation? drv)))) (test-assert "package-cross-derivation, no cross builder" (let* ((b (build-system (inherit trivial-build-system) @@ -257,7 +253,7 @@ (define read-at (or (location? (package-location gnu-make)) (not (package-location gnu-make))) (let* ((drv (package-derivation %store gnu-make)) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (and (build-derivations %store (list drv)) (file-exists? (string-append out "/bin/make"))))))) diff --git a/tests/store.scm b/tests/store.scm index 0280713191..b5e0cb0eab 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -82,7 +82,7 @@ (define (random-text) ;; (d1 (derivation %store "link" ;; "/bin/sh" `("-e" ,b) ;; #:inputs `((,b) (,p1)))) -;; (p2 (derivation-path->output-path d1))) +;; (p2 (derivation->output-path d1))) ;; (and (add-temp-root %store p2) ;; (build-derivations %store (list d1)) ;; (valid-path? %store p1) @@ -133,21 +133,21 @@ (define (same? x y) s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s)))) - (o (derivation-path->output-path d))) + (o (derivation->output-path d))) (and (build-derivations %store (list d)) - (equal? (query-derivation-outputs %store d) + (equal? (query-derivation-outputs %store (derivation-file-name d)) (list o)) (equal? (valid-derivers %store o) - (list d))))) + (list (derivation-file-name d)))))) (test-assert "no substitutes" (let* ((s (open-connection)) (d1 (package-derivation s %bootstrap-guile (%current-system))) (d2 (package-derivation s %bootstrap-glibc (%current-system))) - (o (map derivation-path->output-path (list d1 d2)))) + (o (map derivation->output-path (list d1 d2)))) (set-build-options s #:use-substitutes? #f) - (and (not (has-substitutes? s d1)) - (not (has-substitutes? s d2)) + (and (not (has-substitutes? s (derivation-file-name d1))) + (not (has-substitutes? s (derivation-file-name d2))) (null? (substitutable-paths s o)) (null? (substitutable-path-info s o))))) @@ -156,7 +156,7 @@ (define (same? x y) (test-assert "substitute query" (let* ((s (open-connection)) (d (package-derivation s %bootstrap-guile (%current-system))) - (o (derivation-path->output-path d)) + (o (derivation->output-path d)) (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. @@ -177,7 +177,8 @@ (define (same? x y) o ; StorePath (string-append dir "/example.nar") ; URL (%current-system) ; System - (basename d)))) ; Deriver + (basename + (derivation-file-name d))))) ; Deriver ;; Remove entry from the local cache. (false-if-exception @@ -191,7 +192,7 @@ (define (same? x y) (equal? (list o) (substitutable-paths s (list o))) (match (pk 'spi (substitutable-path-info s (list o))) (((? substitutable? s)) - (and (equal? (substitutable-deriver s) d) + (and (string=? (substitutable-deriver s) (derivation-file-name d)) (null? (substitutable-references s)) (equal? (substitutable-nar-size s) 1234))))))) @@ -207,7 +208,7 @@ (define (same? x y) '() #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) - (o (derivation-path->output-path d)) + (o (derivation->output-path d)) (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. @@ -238,7 +239,8 @@ (define (same? x y) (compose bytevector->nix-base32-string sha256 get-bytevector-all)) (%current-system) ; System - (basename d)))) ; Deriver + (basename + (derivation-file-name d))))) ; Deriver ;; Make sure we use `substitute-binary'. (set-build-options s #:use-substitutes? #t) @@ -257,7 +259,7 @@ (define (same? x y) '() #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) - (o (derivation-path->output-path d)) + (o (derivation->output-path d)) (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. @@ -279,7 +281,8 @@ (define (same? x y) o ; StorePath "does-not-exist.nar" ; relative URL (%current-system) ; System - (basename d)))) ; Deriver + (basename + (derivation-file-name d))))) ; Deriver ;; Make sure we use `substitute-binary'. (set-build-options s #:use-substitutes? #t) diff --git a/tests/union.scm b/tests/union.scm index 6287cffc38..cb110c3b1e 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -108,7 +108,7 @@ (define %store builder inputs #:modules '((guix build union))))) (and (build-derivations %store (list (pk 'drv drv))) - (with-directory-excursion (derivation-path->output-path drv) + (with-directory-excursion (derivation->output-path drv) (and (file-exists? "bin/touch") (file-exists? "bin/gcc") (file-exists? "bin/ld") -- cgit v1.2.3 From 2cd09108c9b316c9c8aa1c1b87b85a1c32cef089 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Thu, 19 Sep 2013 11:07:39 +0000 Subject: guix package: Add '--list-generations'. * guix/scripts/package.scm: Import (srfi srfi-19). (generation-time, matching-generations): New functions. (show-help): Add '--list-generations'. (%options): Likewise. (guix-package)[process-query]: Add support for '--list-generations'. * guix/ui.scm: Import (srfi srfi-19) and (ice-9 regex). (string->generations, string->duration): New functions. * tests/guix-package.sh: Test '--list-generations'. * tests/ui.scm: Import (srfi srfi-19). Test 'string->generations' and 'string->duration'. * doc/guix.texi (Invoking guix-package): Document '--list-generations'. --- doc/guix.texi | 33 +++++++++++++++ guix/scripts/package.scm | 107 +++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 68 ++++++++++++++++++++++++++++++ tests/guix-package.sh | 4 ++ tests/ui.scm | 85 +++++++++++++++++++++++++++++++++++++ 5 files changed, 297 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 92c163c608..fdddcc52c3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -606,6 +606,39 @@ library are installed in the profile, then @code{--search-paths} will suggest setting these variables to @code{@var{profile}/include} and @code{@var{profile}/lib}, respectively. +@item --list-generations[=@var{pattern}] +@itemx -l [@var{pattern}] +Return a list of generations along with their creation dates. + +For each installed package, print the following items, separated by +tabs: the name of a package, its version string, the part of the package +that is installed (@pxref{Packages with Multiple Outputs}), and the +location of this package in the store. + +When @var{pattern} is used, the command returns only matching +generations. Valid patterns include: + +@itemize +@item @emph{Integers and comma-separated integers}. Both patterns denote +generation numbers. For instance, @code{--list-generations=1} returns +the first one. + +And @code{--list-generations=1,8,2} outputs three generations in the +specified order. Neither spaces nor trailing commas are allowed. + +@item @emph{Ranges}. @code{--list-generations=2..9} prints the +specified generations and everything in between. Note that the start of +a range must be lesser than its end. + +It is also possible to omit the endpoint. For example, +@code{--list-generations=2..}, returns all generations starting from the +second one. + +@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks, +or months by passing an integer along with the first letter of the +duration, e.g., @code{--list-generations=20d}. +@end itemize + @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 862b82612a..98b8aedfc9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -34,6 +34,7 @@ (define-module (guix scripts package) #: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) @@ -243,6 +244,74 @@ (define (switch-link) (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." @@ -438,6 +507,9 @@ (define (show-help) --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")) @@ -497,6 +569,10 @@ (define %options (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))) @@ -876,6 +952,37 @@ (define (process-query opts) ;; 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))) + (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)) diff --git a/guix/ui.scm b/guix/ui.scm index 293730308e..4415997252 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -28,12 +28,14 @@ (define-module (guix ui) #: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 @@ (define-module (guix ui) fill-paragraph string->recutils package->recutils + string->generations + string->duration args-fold* run-guix-command program-name @@ -404,6 +408,70 @@ (define (description->recutils str) (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." diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 60b42907a8..b09a9c0173 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -81,6 +81,10 @@ then "name: hello" test "`guix package -s "n0t4r341p4ck4g3"`" = "" + # List generations. + test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \ + = " guile-bootstrap" + # Remove a package. guix package --bootstrap -p "$profile" -r "guile-bootstrap" test -L "$profile-3-link" diff --git a/tests/ui.scm b/tests/ui.scm index 0b6f3c5815..3d5c3e7969 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -20,6 +20,7 @@ (define-module (test-ui) #:use-module (guix ui) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-64)) ;; Test the (guix ui) module. @@ -64,6 +65,90 @@ (define %paragraph 10) #\newline)) +(test-equal "integer" + '(1) + (string->generations "1")) + +(test-equal "comma-separated integers" + '(3 7 1 4 6) + (string->generations "3,7,1,4,6")) + +(test-equal "closed range" + '(4 5 6 7 8 9 10 11 12) + (string->generations "4..12")) + +(test-equal "closed range, equal endpoints" + '(3) + (string->generations "3..3")) + +(test-equal "indefinite end range" + '(>= 7) + (string->generations "7..")) + +(test-equal "indefinite start range" + '(<= 42) + (string->generations "..42")) + +(test-equal "integer, char" + #f + (string->generations "a")) + +(test-equal "comma-separated integers, consecutive comma" + #f + (string->generations "1,,2")) + +(test-equal "comma-separated integers, trailing comma" + #f + (string->generations "1,2,")) + +(test-equal "comma-separated integers, chars" + #f + (string->generations "a,b")) + +(test-equal "closed range, start > end" + #f + (string->generations "9..2")) + +(test-equal "closed range, chars" + #f + (string->generations "a..b")) + +(test-equal "indefinite end range, char" + #f + (string->generations "a..")) + +(test-equal "indefinite start range, char" + #f + (string->generations "..a")) + +(test-equal "duration, 1 day" + (make-time time-duration 0 (* 3600 24)) + (string->duration "1d")) + +(test-equal "duration, 1 week" + (make-time time-duration 0 (* 3600 24 7)) + (string->duration "1w")) + +(test-equal "duration, 1 month" + (make-time time-duration 0 (* 3600 24 30)) + (string->duration "1m")) + +(test-equal "duration, 1 week == 7 days" + (string->duration "1w") + (string->duration "7d")) + +(test-equal "duration, 1 month == 30 days" + (string->duration "1m") + (string->duration "30d")) + +(test-equal "duration, integer" + #f + (string->duration "1")) + +(test-equal "duration, char" + #f + (string->duration "d")) + (test-end "ui") -- cgit v1.2.3 From 3b627eac48de41b1dc3a1132be961855dd9d0321 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Sep 2013 22:12:20 +0200 Subject: pull: Adjust to 'derivation' API change. Fixes . Reported by Cyrill Schenkel . * guix/scripts/pull.scm (guix-pull): 'unpack' returns a single value. --- guix/scripts/pull.scm | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f3d87a63c0..a1b5cdc991 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -29,7 +29,6 @@ (define-module (guix scripts pull) #: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)) @@ -200,13 +199,9 @@ (define (parse-options) (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"))) -- cgit v1.2.3 From 4d497632ce56287cc56cfb73abad7e562129b43e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Sep 2013 22:32:20 +0200 Subject: guix package: Internationalize "Generation" string. * guix/scripts/package.scm (guix-package): Internationalize generation listing. --- guix/scripts/package.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 98b8aedfc9..dcc2bc74aa 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -955,7 +955,7 @@ (define (process-query opts) (('list-generations pattern) (define (list-generation number) (begin - (format #t "Generation ~a\t~a~%" number + (format #t (_ "Generation ~a\t~a~%") number (date->string (time-utc->date (generation-time profile number)) -- cgit v1.2.3 From 99882c613ca29d0020f507b76cc6da955dd70afa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Sep 2013 22:35:14 +0200 Subject: guix package: Sort the list of generation numbers in '--list-generations'. * guix/scripts/package.scm (generation-numbers): Sort the result. --- guix/scripts/package.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index dcc2bc74aa..c0cedcd4a8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -97,7 +97,7 @@ (define (profile-regexp profile) "-([0-9]+)"))) (define (generation-numbers profile) - "Return the list of generation numbers of PROFILE, or '(0) if no + "Return the sorted list of generation numbers of PROFILE, or '(0) if no former profiles were found." (define* (scandir name #:optional (select? (const #t)) (entrynumber - (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-generation-number profile number) "Return the number of the generation before generation NUMBER of -- cgit v1.2.3 From bd9bde1cba7190ed8b87aefbd09b1e25c5acbf31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Sep 2013 21:50:11 +0200 Subject: guix package: Show most recently installed packages last. Suggested by Andreas Enge . * guix/scripts/package.scm (guix-package)[list-generations, list-installed]: Reverse the result of 'manifest-packages'. * doc/guix.texi (Invoking guix package): Document the order of packages for '--list-generations' and '--list-installed'. --- doc/guix.texi | 10 ++++++---- guix/scripts/package.scm | 13 +++++++++---- 2 files changed, 15 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index fdddcc52c3..9eb67ecd01 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -608,7 +608,9 @@ suggest setting these variables to @code{@var{profile}/include} and @item --list-generations[=@var{pattern}] @itemx -l [@var{pattern}] -Return a list of generations along with their creation dates. +Return a list of generations along with their creation dates; for each +generation, show the installed packages, with the most recently +installed packages shown last. For each installed package, print the following items, separated by tabs: the name of a package, its version string, the part of the package @@ -692,9 +694,9 @@ version: 7.2alpha6 @item --list-installed[=@var{regexp}] @itemx -I [@var{regexp}] -List currently installed packages in the specified profile. When -@var{regexp} is specified, list only installed packages whose name -matches @var{regexp}. +List the currently installed packages in the specified profile, with the +most recently installed packages shown last. When @var{regexp} is +specified, list only installed packages whose name matches @var{regexp}. For each installed package, print the following items, separated by tabs: the package name, its version string, the part of the package that diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c0cedcd4a8..1d00e39540 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -965,9 +965,12 @@ (define (list-generation number) ((name version output location _) (format #t " ~a\t~a\t~a\t~a~%" name version output location))) - (manifest-packages - (profile-manifest - (format #f "~a-~a-link" profile number)))) + + ;; 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 @@ -994,7 +997,9 @@ (define (list-generation number) (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) -- cgit v1.2.3 From 48e488eb2c2870088369d2dd69012abaa2376083 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Sep 2013 22:13:51 +0200 Subject: nar: Fix file descriptor leak when writing a Nar. * guix/nar.scm (write-contents)[call-with-binary-input-file]: Always close PORT. --- guix/nar.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') 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 @@ (define (call-with-binary-input-file file proc) ;; 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) -- cgit v1.2.3