From 868c923f13e6ed95e1e5ad2bd32d4166842254ea Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 14 Feb 2013 04:15:25 -0500 Subject: Replace individual scripts with master 'guix' script. * scripts/guix.in: New script. * Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. (MODULES): Add 'guix/scripts/build.scm', 'guix/scripts/download.scm', 'guix/scripts/import.scm', 'guix/scripts/package.scm', and 'guix/scripts/gc.scm'. * configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build', 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'. * guix-build.in, guix-download.in, guix-gc.in, guix-import.in, guix-package.in: Remove shell script boilerplate. Move to guix-COMMAND.in to guix/scripts/COMMAND.scm. Rename module from (guix-COMMAND) to (guix scripts COMMAND). Change "guix-COMMAND" to "guix COMMAND" in usage help string. * pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH. Export $GUIX_UNINSTALLED. * tests/guix-build.sh, tests/guix-daemon.sh, tests/guix-download.sh, tests/guix-gc.sh, tests/guix-package.sh: Use "guix COMMAND" instead of "guix-COMMAND". * doc/guix.texi: Replace all occurrences of "guix-COMMAND" with "guix COMMAND". * po/POTFILES.in: Update. --- guix/scripts/build.scm | 304 ++++++++++++++++++++ guix/scripts/download.scm | 151 ++++++++++ guix/scripts/gc.scm | 165 +++++++++++ guix/scripts/import.scm | 124 +++++++++ guix/scripts/package.scm | 693 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 1437 insertions(+) create mode 100644 guix/scripts/build.scm create mode 100644 guix/scripts/download.scm create mode 100644 guix/scripts/gc.scm create mode 100644 guix/scripts/import.scm create mode 100644 guix/scripts/package.scm (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm new file mode 100644 index 0000000000..bad04418f1 --- /dev/null +++ b/guix/scripts/build.scm @@ -0,0 +1,304 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Mark H Weaver +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts build) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) + #:autoload (gnu packages) (find-packages-by-name + find-newest-available-packages) + #:export (guix-build)) + +(define %store + (make-parameter #f)) + +(define (derivations-from-package-expressions exp system source?) + "Eval EXP and return the corresponding derivation path for SYSTEM. +When SOURCE? is true, return the derivations of the package sources." + (let ((p (eval exp (current-module)))) + (if (package? p) + (if source? + (let ((source (package-source p)) + (loc (package-location p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "~a: error: package `~a' has no source~%") + (location->string loc) (package-name p)))) + (package-derivation (%store) p system)) + (leave (_ "expression `~s' does not evaluate to a package~%") + exp)))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... +Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) + (display (_ " + -e, --expression=EXPR build the package EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -d, --derivations return the derivation paths of the given packages")) + (display (_ " + -K, --keep-failed keep build tree of failed builds")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + -c, --cores=N allow the use of up to N CPU cores for the build")) + (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " + --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-build"))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '(#\d "derivations") #f #f + (lambda (opt name arg result) + (alist-cons 'derivations-only? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression + (call-with-input-string arg read) + result))) + (option '(#\K "keep-failed") #f #f + (lambda (opt name arg result) + (alist-cons 'keep-failed? #t result))) + (option '(#\c "cores") #t #f + (lambda (opt name arg result) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-build . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (define (register-root paths root) + ;; Register ROOT as an indirect GC root for all of PATHS. + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (match paths + ((path) + (symlink path root) + (add-indirect-root (%store) root)) + ((paths ...) + (fold (lambda (path count) + (let ((root (string-append root "-" (number->string count)))) + (symlink path root) + (add-indirect-root (%store) root)) + (+ 1 count)) + 0 + paths)))) + (lambda args + (format (current-error-port) + (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))) + (exit 1))))) + + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + + (define (find-package request) + ;; Return a package matching REQUEST. REQUEST may be a package + ;; name, or a package name followed by a hyphen and a version + ;; number. If the version number is not present, return the + ;; preferred newest version. + (let-values (((name version) + (package-name->name+version request))) + (match (find-best-packages-by-name name version) + ((p) ; one match + p) + ((p x ...) ; several matches + (format (current-error-port) + (_ "warning: ambiguous package specification `~a'~%") + request) + (format (current-error-port) + (_ "warning: choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) + p) + (_ ; no matches + (if version + (leave (_ "~A: package not found for version ~a~%") + name version) + (leave (_ "~A: unknown package~%") name)))))) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (with-error-handling + (let ((opts (parse-options))) + (parameterize ((%store (open-connection))) + (let* ((src? (assoc-ref opts 'source?)) + (sys (assoc-ref opts 'system)) + (drv (filter-map (match-lambda + (('expression . exp) + (derivations-from-package-expressions exp sys + src?)) + (('argument . (? derivation-path? drv)) + drv) + (('argument . (? string? x)) + (let ((p (find-package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation + (%store) s)) + (package-derivation (%store) p sys)))) + (_ #f)) + opts)) + (req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build (%store) d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cut valid-path? (%store) <>) + derivation-path->output-path) + drv) + (map derivation-input-path req)))) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + (if (assoc-ref opts 'dry-run?) + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)) + + ;; TODO: Add more options. + (set-build-options (%store) + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity (assoc-ref opts 'verbosity)) + + (if (assoc-ref opts 'derivations-only?) + (begin + (format #t "~{~a~%~}" drv) + (for-each (cut register-root <> <>) + (map list 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))))) + drv) + (for-each (cut register-root <> <>) + (map (lambda (drv) + (map cdr + (derivation-path->output-paths drv))) + drv) + roots))))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm new file mode 100644 index 0000000000..1098e6714b --- /dev/null +++ b/guix/scripts/download.scm @@ -0,0 +1,151 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts download) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module ((guix download) #:select (%mirrors)) + #:use-module (guix build download) + #:use-module (web uri) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (guix-download)) + +(define (call-with-temporary-output-file proc) + (let* ((template (string-copy "guix-download.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (delete-file template)))))) + +(define (fetch-and-store store fetch name) + "Call FETCH for URI, and pass it the name of a file to write to; eventually, +copy data from that port to STORE, under NAME. Return the resulting +store path." + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port (current-error-port))) + (fetch temp)))) + (close port) + (and result + (add-to-store store name #f "sha256" temp)))))) + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((format . ,bytevector->nix-base32-string))) + +(define (show-help) + (display (_ "Usage: guix download [OPTION]... URL +Download the file at URL, add it to the store, and print its store path +and the hash of its contents.\n")) + (format #t (_ " + -f, --format=FMT write the hash in the given format (default: `nix-base32')")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (define fmt-proc + (match arg + ("nix-base32" + bytevector->nix-base32-string) + ("base32" + bytevector->base32-string) + ((or "base16" "hex" "hexadecimal") + bytevector->base16-string) + (x + (format (current-error-port) + "unsupported hash format: ~a~%" arg)))) + + (alist-cons 'format fmt-proc + (alist-delete 'format result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-download"))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-download . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (store (open-connection)) + (arg (assq-ref opts 'argument)) + (uri (or (string->uri arg) + (leave (_ "guix-download: ~a: failed to parse URI~%") + arg))) + (path (case (uri-scheme uri) + ((file) + (add-to-store store (basename (uri-path uri)) + #f "sha256" (uri-path uri))) + (else + (fetch-and-store store + (cut url-fetch arg <> + #:mirrors %mirrors) + (basename (uri-path uri)))))) + (hash (call-with-input-file + (or path + (leave (_ "guix-download: ~a: download failed~%") + arg)) + (compose sha256 get-bytevector-all))) + (fmt (assq-ref opts 'format))) + (format #t "~a~%~a~%" path (fmt hash)) + #t)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm new file mode 100644 index 0000000000..8e2587186e --- /dev/null +++ b/guix/scripts/gc.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts gc) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-gc)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((action . collect-garbage))) + +(define (show-help) + (display (_ "Usage: guix gc [OPTION]... PATHS... +Invoke the garbage collector.\n")) + (display (_ " + -C, --collect-garbage[=MIN] + collect at least MIN bytes of garbage")) + (display (_ " + -d, --delete attempt to delete PATHS")) + (display (_ " + --list-dead list dead paths")) + (display (_ " + --list-live list live paths")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (size->number str) + "Convert STR, a storage measurement representation such as \"1024\" or +\"1MiB\", to a number of bytes. Raise an error if STR could not be +interpreted." + (define unit-pos + (string-rindex str char-set:digit)) + + (define unit + (and unit-pos (substring str (+ 1 unit-pos)))) + + (let* ((numstr (if unit-pos + (substring str 0 (+ 1 unit-pos)) + str)) + (num (string->number numstr))) + (if num + (* num + (match unit + ("KiB" (expt 2 10)) + ("MiB" (expt 2 20)) + ("GiB" (expt 2 30)) + ("TiB" (expt 2 40)) + ("KB" (expt 10 3)) + ("MB" (expt 10 6)) + ("GB" (expt 10 9)) + ("TB" (expt 10 12)) + ("" 1) + (_ + (format (current-error-port) (_ "error: unknown unit: ~a~%") + unit) + (exit 1)))) + (begin + (format (current-error-port) + (_ "error: invalid number: ~a") numstr) + (exit 1))))) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-gc"))) + + (option '(#\C "collect-garbage") #f #t + (lambda (opt name arg result) + (let ((result (alist-cons 'action 'collect-garbage + (alist-delete 'action result)))) + (match arg + ((? string?) + (let ((amount (size->number arg))) + (if arg + (alist-cons 'min-freed amount result) + (begin + (format (current-error-port) + (_ "error: invalid amount of storage: ~a~%") + arg) + (exit 1))))) + (#f result))))) + (option '(#\d "delete") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'delete + (alist-delete 'action result)))) + (option '("list-dead") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-dead + (alist-delete 'action result)))) + (option '("list-live") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-live + (alist-delete 'action result)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-gc . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (with-error-handling + (let ((opts (parse-options)) + (store (open-connection))) + (case (assoc-ref opts 'action) + ((collect-garbage) + (let ((min-freed (assoc-ref opts 'min-freed))) + (if min-freed + (collect-garbage store min-freed) + (collect-garbage store)))) + ((delete) + (let ((paths (filter-map (match-lambda + (('argument . arg) arg) + (_ #f)) + opts))) + (delete-paths store paths))) + ((list-dead) + (for-each (cut simple-format #t "~a~%" <>) + (dead-paths store))) + ((list-live) + (for-each (cut simple-format #t "~a~%" <>) + (live-paths store))))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm new file mode 100644 index 0000000000..0bc6926c66 --- /dev/null +++ b/guix/scripts/import.scm @@ -0,0 +1,124 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts import) + #:use-module (guix ui) + #:use-module (guix snix) + #:use-module (guix utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:export (guix-import)) + + +;;; +;;; Helper. +;;; + +(define (newline-rewriting-port output) + "Return an output port that rewrites strings containing the \\n escape +to an actual newline. This works around the behavior of `pretty-print' +and `write', which output these as \\n instead of actual newlines, +whereas we want the `description' field to contain actual newlines +rather than \\n." + (define (write-string str) + (let loop ((chars (string->list str))) + (match chars + (() + #t) + ((#\\ #\n rest ...) + (newline output) + (loop rest)) + ((chr rest ...) + (write-char chr output) + (loop rest))))) + + (make-soft-port (vector (cut write-char <>) + write-string + (lambda _ #t) ; flush + #f + (lambda _ #t) ; close + #f) + "w")) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import NIXPKGS ATTRIBUTE +Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-import"))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-import . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((nixpkgs attribute) + (let-values (((expr loc) + (nixpkgs->guix-package nixpkgs attribute))) + (format #t ";; converted from ~a:~a~%~%" + (location-file loc) (location-line loc)) + (pretty-print expr (newline-rewriting-port (current-output-port))))) + (_ + (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm new file mode 100644 index 0000000000..4935837d33 --- /dev/null +++ b/guix/scripts/package.scm @@ -0,0 +1,693 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2013 Mark H Weaver +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts package) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix config) + #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-37) + #:use-module (gnu packages) + #:use-module ((gnu packages base) #:select (guile-final)) + #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:export (guix-package)) + +(define %store + (make-parameter #f)) + + +;;; +;;; User environment. +;;; + +(define %user-environment-directory + (and=> (getenv "HOME") + (cut string-append <> "/.guix-profile"))) + +(define %profile-directory + (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" + (or (and=> (getenv "USER") + (cut string-append "per-user/" <>)) + "default"))) + +(define %current-profile + ;; Call it `guix-profile', not `profile', to allow Guix profiles to + ;; coexist with Nix profiles. + (string-append %profile-directory "/guix-profile")) + +(define (profile-manifest profile) + "Return the PROFILE's manifest." + (let ((manifest (string-append profile "/manifest"))) + (if (file-exists? manifest) + (call-with-input-file manifest read) + '(manifest (version 1) (packages ()))))) + +(define (manifest-packages manifest) + "Return the packages listed in MANIFEST." + (match manifest + (('manifest ('version 0) + ('packages ((name version output path) ...))) + (zip name version output path + (make-list (length name) '()))) + + ;; Version 1 adds a list of propagated inputs to the + ;; name/version/output/path tuples. + (('manifest ('version 1) + ('packages (packages ...))) + packages) + + (_ + (error "unsupported manifest format" manifest)))) + +(define (profile-regexp profile) + "Return a regular expression that matches PROFILE's name and number." + (make-regexp (string-append "^" (regexp-quote (basename profile)) + "-([0-9]+)"))) + +(define (profile-numbers profile) + "Return the list of generation numbers of PROFILE, or '(0) if no +former profiles were found." + (define* (scandir name #:optional (select? (const #t)) + (entry (file-system-fold enter? leaf down up skip error #f name lstat) + (lambda (files) + (sort files entry)) + (#f ; no profile directory + '(0)) + (() ; no profiles + '(0)) + ((profiles ...) ; former profiles around + (map (compose string->number + (cut match:substring <> 1) + (cute regexp-exec (profile-regexp profile) <>)) + profiles)))) + +(define (previous-profile-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\")." + (fold (lambda (candidate highest) + (if (and (< candidate number) (> candidate highest)) + candidate + highest)) + 0 + (profile-numbers profile))) + +(define (profile-derivation store packages) + "Return a derivation that builds a profile (a user environment) with +all of PACKAGES, a list of name/version/output/path/deps tuples." + (define builder + `(begin + (use-modules (ice-9 pretty-print) + (guix build union)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((output (assoc-ref %outputs "out")) + (inputs (map cdr %build-inputs))) + (format #t "building user environment `~a' with ~a packages...~%" + output (length inputs)) + (union-build output inputs) + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print '(manifest (version 1) + (packages ,packages)) + p)))))) + + (build-expression->derivation store "user-environment" + (%current-system) + builder + (append-map (match-lambda + ((name version output path deps) + `((,name ,path) + ,@deps))) + packages) + #:modules '((guix build union)))) + +(define (profile-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)))) + (compose string->number (cut match:substring <> 1))) + 0)) + +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + +(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"))) + + (define (switch-link) + ;; Atomically switch PROFILE to the previous profile. + (format #t (_ "switching from generation ~a to ~a~%") + number previous-number) + (switch-symlinks profile previous-profile)) + + (cond ((not (file-exists? profile)) ; invalid profile + (format (current-error-port) + (_ "error: profile `~a' does not exist~%") + profile)) + ((zero? number) ; empty profile + (format (current-error-port) + (_ "nothing to do: already at the empty profile~%"))) + ((or (zero? previous-number) ; going to emptiness + (not (file-exists? previous-profile))) + (let*-values (((drv-path drv) + (profile-derivation (%store) '())) + ((prof) + (derivation-output-path + (assoc-ref (derivation-outputs drv) "out")))) + (when (not (build-derivations (%store) (list drv-path))) + (leave (_ "failed to build the empty profile~%"))) + + (switch-symlinks previous-profile prof) + (switch-link))) + (else (switch-link))))) ; anything else + +(define (find-packages-by-description rx) + "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of +matching packages." + (define (same-location? p1 p2) + ;; Compare locations of two packages. + (equal? (package-location p1) (package-location p2))) + + (delete-duplicates + (sort + (fold-packages (lambda (package result) + (define matches? + (cut regexp-exec rx <>)) + + (if (or (and=> (package-synopsis package) + (compose matches? gettext)) + (and=> (package-description package) + (compose matches? gettext))) + (cons package result) + result)) + '()) + (lambda (p1 p2) + (stringname+path input) + "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." + (let loop ((input input)) + (match input + ((name package) + (loop `(,name ,package "out"))) + ((name package sub-drv) + (let*-values (((_ drv) + (package-derivation (%store) package)) + ((out) + (derivation-output-path + (assoc-ref (derivation-outputs drv) sub-drv)))) + `(,name ,out)))))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((profile . ,%current-profile))) + +(define (show-help) + (display (_ "Usage: guix package [OPTION]... PACKAGES... +Install, remove, or upgrade PACKAGES in a single transaction.\n")) + (display (_ " + -i, --install=PACKAGE install PACKAGE")) + (display (_ " + -r, --remove=PACKAGE remove PACKAGE")) + (display (_ " + -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) + (display (_ " + --roll-back roll back to the previous generation")) + (newline) + (display (_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (_ " + -n, --dry-run show what would be done without actually doing it")) + (display (_ " + --bootstrap use the bootstrap Guile to build the profile")) + (display (_ " + --verbose produce verbose output")) + (newline) + (display (_ " + -s, --search=REGEXP search in synopsis and description using REGEXP")) + (display (_ " + -I, --list-installed[=REGEXP] + list installed packages matching REGEXP")) + (display (_ " + -A, --list-available[=REGEXP] + list available packages matching REGEXP")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-package"))) + + (option '(#\i "install") #t #f + (lambda (opt name arg result) + (alist-cons 'install arg result))) + (option '(#\r "remove") #t #f + (lambda (opt name arg result) + (alist-cons 'remove arg result))) + (option '(#\u "upgrade") #t #f + (lambda (opt name arg result) + (alist-cons 'upgrade arg result))) + (option '("roll-back") #f #f + (lambda (opt name arg result) + (alist-cons 'roll-back? #t result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile arg + (alist-delete 'profile result)))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) + (option '("verbose") #f #f + (lambda (opt name arg result) + (alist-cons 'verbose? #t result))) + (option '(#\s "search") #t #f + (lambda (opt name arg result) + (cons `(query search ,(or arg "")) + result))) + (option '(#\I "list-installed") #f #t + (lambda (opt name arg result) + (cons `(query list-installed ,(or arg "")) + result))) + (option '(#\A "list-available") #f #t + (lambda (opt name arg result) + (cons `(query list-available ,(or arg "")) + result))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-package . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneous argument~%") arg)) + %default-options)) + + (define (guile-missing?) + ;; Return #t if %GUILE-FOR-BUILD is not available yet. + (let ((out (derivation-path->output-path (%guile-for-build)))) + (not (valid-path? (%store) out)))) + + (define (show-what-to-build drv dry-run?) + ;; Show what will/would be built in realizing the derivations listed + ;; in DRV. + (let* ((req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build + (%store) d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cute valid-path? (%store) <>) + derivation-path->output-path) + drv) + (map derivation-input-path req))))) + (if dry-run? + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)))) + + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + + (define (find-package name) + ;; Find the package NAME; NAME may contain a version number and a + ;; sub-derivation name. If the version number is not present, + ;; return the preferred newest version. + (define request name) + + (define (ensure-output p sub-drv) + (if (member sub-drv (package-outputs p)) + p + (leave (_ "~a: error: package `~a' lacks output `~a'~%") + (location->string (package-location p)) + (package-full-name p) + sub-drv))) + + (let*-values (((name sub-drv) + (match (string-rindex name #\:) + (#f (values name "out")) + (colon (values (substring name 0 colon) + (substring name (+ 1 colon)))))) + ((name version) + (package-name->name+version name))) + (match (find-best-packages-by-name name version) + ((p) + (list name (package-version p) sub-drv (ensure-output p sub-drv) + (package-transitive-propagated-inputs p))) + ((p p* ...) + (format (current-error-port) + (_ "warning: ambiguous package specification `~a'~%") + request) + (format (current-error-port) + (_ "warning: choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) + (list name (package-version p) sub-drv (ensure-output p sub-drv) + (package-transitive-propagated-inputs p))) + (() + (leave (_ "~a: package not found~%") request))))) + + (define (upgradeable? name current-version current-path) + ;; Return #t if there's a version of package NAME newer than + ;; CURRENT-VERSION, or if the newest available version is equal to + ;; CURRENT-VERSION but would have an output path different than + ;; CURRENT-PATH. + (match (vhash-assoc name (newest-available-packages)) + ((_ candidate-version pkg . rest) + (case (version-compare candidate-version current-version) + ((>) #t) + ((<) #f) + ((=) (let ((candidate-path (derivation-path->output-path + (package-derivation (%store) pkg)))) + (not (string=? current-path candidate-path)))))) + (#f #f))) + + (define (ensure-default-profile) + ;; Ensure the default profile symlink and directory exist. + + ;; Create ~/.guix-profile if it doesn't exist yet. + (when (and %user-environment-directory + %current-profile + (not (false-if-exception + (lstat %user-environment-directory)))) + (symlink %current-profile %user-environment-directory)) + + ;; Attempt to create /…/profiles/per-user/$USER if needed. + (unless (directory-exists? %profile-directory) + (catch 'system-error + (lambda () + (mkdir-p %profile-directory)) + (lambda args + ;; Often, we cannot create %PROFILE-DIRECTORY because its + ;; parent directory is root-owned and we're running + ;; unprivileged. + (format (current-error-port) + (_ "error: while creating directory `~a': ~a~%") + %profile-directory + (strerror (system-error-errno args))) + (format (current-error-port) + (_ "Please create the `~a' directory, with you as the owner.~%") + %profile-directory) + (exit 1))))) + + (define (process-actions opts) + ;; Process any install/remove/upgrade action from OPTS. + + (define dry-run? (assoc-ref opts 'dry-run?)) + (define verbose? (assoc-ref opts 'verbose?)) + (define profile (assoc-ref opts 'profile)) + + (define (canonicalize-deps deps) + ;; Remove duplicate entries from DEPS, a list of propagated inputs, + ;; where each input is a name/path tuple. + (define (same? d1 d2) + (match d1 + ((_ path1) + (match d2 + ((_ path2) + (string=? path1 path2)))))) + + (delete-duplicates (map input->name+path deps) same?)) + + ;; First roll back if asked to. + (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) + (begin + (roll-back profile) + (process-actions (alist-delete 'roll-back? opts))) + (let* ((installed (manifest-packages (profile-manifest profile))) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp regexp)) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (find-newest-available-packages))) + (filter-map (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (find-package name))) + (_ #f)) + installed)))) + (install (append + upgrade + (filter-map (match-lambda + (('install . (? store-path?)) + #f) + (('install . package) + (find-package package)) + (_ #f)) + opts))) + (drv (filter-map (match-lambda + ((name version sub-drv + (? package? package) + (deps ...)) + (package-derivation (%store) package)) + (_ #f)) + install)) + (install* (append + (filter-map (match-lambda + (('install . (? store-path? path)) + (let-values (((name version) + (package-name->name+version + (store-path-package-name + path)))) + `(,name ,version #f ,path ()))) + (_ #f)) + opts) + (map (lambda (tuple drv) + (match tuple + ((name version sub-drv _ (deps ...)) + (let ((output-path + (derivation-path->output-path + drv sub-drv))) + `(,name ,version ,sub-drv ,output-path + ,(canonicalize-deps deps)))))) + install drv))) + (remove (filter-map (match-lambda + (('remove . package) + package) + (_ #f)) + opts)) + (packages (append install* + (fold (lambda (package result) + (match package + ((name _ ...) + (alist-delete name result)))) + (fold alist-delete installed remove) + install*)))) + + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (show-what-to-build drv dry-run?) + + (or dry-run? + (and (build-derivations (%store) drv) + (let* ((prof-drv (profile-derivation (%store) packages)) + (prof (derivation-path->output-path prof-drv)) + (old-drv (profile-derivation + (%store) (manifest-packages + (profile-manifest profile)))) + (old-prof (derivation-path->output-path old-drv)) + (number (profile-number profile)) + + ;; Always use NUMBER + 1 for the new profile, + ;; possibly overwriting a "previous future + ;; generation". + (name (format #f "~a-~a-link" + profile (+ 1 number)))) + (if (string=? old-prof prof) + (when (or (pair? install) (pair? remove)) + (format (current-error-port) + (_ "nothing to be done~%"))) + (and (parameterize ((current-build-output-port + ;; Output something when Guile + ;; needs to be built. + (if (or verbose? (guile-missing?)) + (current-error-port) + (%make-void-port "w")))) + (build-derivations (%store) (list prof-drv))) + (begin + (switch-symlinks name prof) + (switch-symlinks profile name)))))))))) + + (define (process-query opts) + ;; Process any query specified by OPTS. Return #t when a query was + ;; actually processed, #f otherwise. + (let ((profile (assoc-ref opts 'profile))) + (match (assoc-ref opts 'query) + (('list-installed regexp) + (let* ((regexp (and regexp (make-regexp regexp))) + (manifest (profile-manifest profile)) + (installed (manifest-packages manifest))) + (for-each (match-lambda + ((name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) + installed) + #t)) + + (('list-available regexp) + (let* ((regexp (and regexp (make-regexp regexp))) + (available (fold-packages + (lambda (p r) + (let ((n (package-name p))) + (if regexp + (if (regexp-exec regexp n) + (cons p r) + r) + (cons p r)))) + '()))) + (for-each (lambda (p) + (format #t "~a\t~a\t~a\t~a~%" + (package-name p) + (package-version p) + (string-join (package-outputs p) ",") + (location->string (package-location p)))) + (sort available + (lambda (p1 p2) + (stringrecutils <> (current-output-port)) + (find-packages-by-description regexp)) + #t)) + (_ #f)))) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((opts (parse-options))) + (or (process-query opts) + (parameterize ((%store (open-connection))) + (with-error-handling + (parameterize ((%guile-for-build + (package-derivation (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + guile-final)))) + (process-actions opts))))))) -- cgit v1.2.3 From c07512179ef50cc50067844ec7ab15a228c70ac9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Feb 2013 15:38:02 +0100 Subject: scripts: Remove initialization now redundant with `initialize-guix'. * guix/scripts/build.scm (guix-build): Remove calls to `install-locale', `textdomain', etc., now redundant with `initialize-guix'. * guix/scripts/download.scm (guix-download): Likewise. * guix/scripts/import.scm (guix-import): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/ui.scm: Remove export of `install-locale' and `initialize-guix'. (initialize-guix): Add docstring. --- guix/scripts/build.scm | 5 ----- guix/scripts/download.scm | 5 ----- guix/scripts/import.scm | 5 ----- guix/scripts/package.scm | 5 ----- guix/ui.scm | 3 +-- 5 files changed, 1 insertion(+), 22 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index bad04418f1..3e241ca9da 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -221,11 +221,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) name version) (leave (_ "~A: unknown package~%") name)))))) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (with-error-handling (let ((opts (parse-options))) (parameterize ((%store (open-connection))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1098e6714b..790cf9fc2f 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -121,11 +121,6 @@ and the hash of its contents.\n")) (alist-cons 'argument arg result)) %default-options)) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let* ((opts (parse-options)) (store (open-connection)) (arg (assq-ref opts 'argument)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0bc6926c66..f0aaa80aa0 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -102,11 +102,6 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (alist-cons 'argument arg result)) %default-options)) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4935837d33..559be50824 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -676,11 +676,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) #t)) (_ #f)))) - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - (let ((opts (parse-options))) (or (process-query opts) (parameterize ((%store (open-connection))) diff --git a/guix/ui.scm b/guix/ui.scm index 644a3070f6..af8b238ce1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -30,8 +30,6 @@ #:use-module (ice-9 match) #:export (_ N_ - install-locale - initialize-guix leave show-version-and-exit show-bug-report-information @@ -67,6 +65,7 @@ (strerror (system-error-errno args)))))) (define (initialize-guix) + "Perform the usual initialization for stand-alone Guix commands." (install-locale) (textdomain "guix") (setvbuf (current-output-port) _IOLBF) -- cgit v1.2.3 From dc3f1809cf4637fcf30d9c1789fa0eb96aefd0f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 Feb 2013 16:25:30 +0100 Subject: scripts: Remove hyphen in the command name shown by `--version'. * guix/scripts/build.scm (%options): Remove hyphen from the name passed to `show-version-and-exit'. * guix/scripts/download.scm (%options): Likewise. * guix/scripts/gc.scm (%options): Likewise. * guix/scripts/import.scm (%options): Likewise. * guix/scripts/package.scm (%options): Likewise. --- guix/scripts/build.scm | 2 +- guix/scripts/download.scm | 2 +- guix/scripts/gc.scm | 2 +- guix/scripts/import.scm | 2 +- guix/scripts/package.scm | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 3e241ca9da..7863fb881b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -105,7 +105,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-build"))) + (show-version-and-exit "guix build"))) (option '(#\S "source") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 790cf9fc2f..10370e59af 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -104,7 +104,7 @@ and the hash of its contents.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-download"))))) + (show-version-and-exit "guix download"))))) ;;; diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 8e2587186e..f2d2e17d4b 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -97,7 +97,7 @@ interpreted." (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-gc"))) + (show-version-and-exit "guix gc"))) (option '(#\C "collect-garbage") #f #t (lambda (opt name arg result) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index f0aaa80aa0..0b95afced1 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -85,7 +85,7 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-import"))))) + (show-version-and-exit "guix import"))))) ;;; diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 559be50824..23786fb7d8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -327,7 +327,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix-package"))) + (show-version-and-exit "guix package"))) (option '(#\i "install") #t #f (lambda (opt name arg result) -- cgit v1.2.3 From bdeee95a214eedfde979958f62cee466c28e638f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:03:24 +0100 Subject: ui: Add temporary file handling and atomic symlink switch. * guix/scripts/download.scm (call-with-temporary-output-file): Move to ui.scm. * guix/scripts/package.scm (switch-symlinks): Likewise. * guix/ui.scm (call-with-temporary-output-file, switch-symlinks): New procedures. --- guix/scripts/download.scm | 11 ----------- guix/scripts/package.scm | 7 ------- guix/ui.scm | 24 ++++++++++++++++++++++++ 3 files changed, 24 insertions(+), 18 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 10370e59af..3dc227fdcd 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -33,17 +33,6 @@ #:use-module (rnrs io ports) #:export (guix-download)) -(define (call-with-temporary-output-file proc) - (let* ((template (string-copy "guix-download.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (delete-file template)))))) - (define (fetch-and-store store fetch name) "Call FETCH for URI, and pass it the name of a file to write to; eventually, copy data from that port to STORE, under NAME. Return the resulting diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 23786fb7d8..38e8ae1150 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -192,13 +192,6 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (compose string->number (cut match:substring <> 1))) 0)) -(define (switch-symlinks link target) - "Atomically switch LINK, a symbolic link, to point to TARGET. Works -both when LINK already exists and when it does not." - (let ((pivot (string-append link ".new"))) - (symlink target pivot) - (rename-file pivot link))) - (define (roll-back profile) "Roll back to the previous generation of PROFILE." (let* ((number (profile-number profile)) diff --git a/guix/ui.scm b/guix/ui.scm index af8b238ce1..9c27dd8b3a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -36,6 +36,8 @@ call-with-error-handling with-error-handling location->string + call-with-temporary-output-file + switch-symlinks fill-paragraph string->recutils package->recutils @@ -125,6 +127,28 @@ General help using GNU software: ")) (($ file line column) (format #f "~a:~a:~a" file line column)))) +(define (call-with-temporary-output-file proc) + "Call PROC with a name of a temporary file and open output port to that +file; close the file and delete it when leaving the dynamic extent of this +call." + (let* ((template (string-copy "guix-file.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (close out)) + (false-if-exception (delete-file template)))))) + +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. -- cgit v1.2.3 From 7650e148f69832e6b89b93c549278b1bbf89946a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:41:24 +0100 Subject: ui: Factorize `show-what-to-build'. * guix/scripts/package.scm (guix-package)[show-what-to-build]: Move to.. * guix/ui.scm (show-what-to-build): ... here. Add a `store' parameter'. Adjust callers. * guix/scripts/build.scm (guix-build): Use it. Remove `req' and `req*' variables. --- guix/scripts/build.scm | 23 ++--------------------- guix/scripts/package.scm | 28 +--------------------------- guix/ui.scm | 29 +++++++++++++++++++++++++++++ 3 files changed, 32 insertions(+), 48 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7863fb881b..fbd22a9e29 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -241,31 +241,12 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (package-derivation (%store) p sys)))) (_ #f)) opts)) - (req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cut valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req)))) (roots (filter-map (match-lambda (('gc-root . root) root) (_ #f)) opts))) - (if (assoc-ref opts 'dry-run?) - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)) + + (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?)) ;; TODO: Add more options. (set-build-options (%store) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 38e8ae1150..1f9355ff22 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -380,32 +380,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (let ((out (derivation-path->output-path (%guile-for-build)))) (not (valid-path? (%store) out)))) - (define (show-what-to-build drv dry-run?) - ;; Show what will/would be built in realizing the derivations listed - ;; in DRV. - (let* ((req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build - (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cute valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req))))) - (if dry-run? - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)))) - (define newest-available-packages (memoize find-newest-available-packages)) @@ -589,7 +563,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (when (equal? profile %current-profile) (ensure-default-profile)) - (show-what-to-build drv dry-run?) + (show-what-to-build (%store) drv dry-run?) (or dry-run? (and (build-derivations (%store) drv) diff --git a/guix/ui.scm b/guix/ui.scm index 9c27dd8b3a..2b75504573 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -22,17 +22,20 @@ #:use-module (guix store) #:use-module (guix config) #:use-module (guix packages) + #:use-module (guix derivations) #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:export (_ N_ leave show-version-and-exit show-bug-report-information + show-what-to-build call-with-error-handling with-error-handling location->string @@ -112,6 +115,32 @@ General help using GNU software: ")) (nix-protocol-error-message c)))) (thunk))) +(define* (show-what-to-build store drv #:optional dry-run?) + "Show what will or would (depending on DRY-RUN?) be built in realizing the +derivations listed in DRV." + (let* ((req (append-map (lambda (drv-path) + (let ((d (call-with-input-file drv-path + read-derivation))) + (derivation-prerequisites-to-build + store d))) + drv)) + (req* (delete-duplicates + (append (remove (compose (cute valid-path? store <>) + derivation-path->output-path) + drv) + (map derivation-input-path req))))) + (if dry-run? + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*) + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length req*)) + (null? req*) req*)))) + (define-syntax with-error-handling (syntax-rules () "Run BODY within a user-friendly error condition handler." -- cgit v1.2.3 From 69ce1ffc7d5f12266e3a4cde605ca76a65c297b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Feb 2013 23:46:38 +0100 Subject: Add "guix pull". * guix/scripts/pull.scm: New file. * Makefile.am (MODULES): Add it. * doc/guix.texi (Invoking guix pull): New node. (Invoking guix package): Add cross-ref to it. * guix/ui.scm (config-directory): New procedure. * scripts/guix.in: When `GUIX_UNINSTALLED' is undefined, add $XDG_CONFIG_HOME/guix/latest to the search path. * po/POTFILES.in: Add guix/scripts/pull.scm. --- Makefile.am | 1 + doc/guix.texi | 33 ++++++++ guix/scripts/pull.scm | 222 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 21 +++++ po/POTFILES.in | 1 + scripts/guix.in | 12 ++- 6 files changed, 288 insertions(+), 2 deletions(-) create mode 100644 guix/scripts/pull.scm (limited to 'guix/scripts') diff --git a/Makefile.am b/Makefile.am index cabbe21cdd..bed4d06ec0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -30,6 +30,7 @@ MODULES = \ guix/scripts/import.scm \ guix/scripts/package.scm \ guix/scripts/gc.scm \ + guix/scripts/pull.scm \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 9245bd00f5..6a9ebab1f6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -393,6 +393,7 @@ management tools it provides. * Features:: How Guix will make your life brighter. * Invoking guix package:: Package installation, removal, etc. * Invoking guix gc:: Running the garbage collector. +* Invoking guix pull:: Fetching the latest Guix and distribution. @end menu @node Features @@ -521,6 +522,11 @@ Remove @var{package}. @itemx -u @var{regexp} Upgrade all the installed packages matching @var{regexp}. +Note that this upgrades package to the latest version of packages found +in the distribution currently installed. To update your distribution, +you should regularly run @command{guix pull} (@pxref{Invoking guix +pull}). + @item --roll-back Roll back to the previous @dfn{generation} of the profile---i.e., undo the last transaction. @@ -654,6 +660,33 @@ Show the list of live store files and directories. @end table +@node Invoking guix pull +@section Invoking @command{guix pull} + +Packages are installed or upgraded to the latest version available in +the distribution currently available on your local machine. To update +that distribution, along with the Guix tools, you must run @command{guix +pull}: the command downloads the latest Guix source code and package +descriptions, and deploys it. + +On completion, @command{guix package} will use packages and package +versions from this just-retrieved copy of Guix. Not only that, but all +the Guix commands and Scheme modules will also be taken from that latest +version. New @command{guix} sub-commands added by the update also +become available. + +The @command{guix pull} command is usually invoked with no arguments, +but it supports the following options: + +@table @code +@item --verbose +Produce verbose output, writing build logs to the standard error output. + +@item --bootstrap +Use the bootstrap Guile to build the latest Guix. This option is only +useful to Guix developers. +@end table + @c ********************************************************************* @node Programming Interface @chapter Programming Interface diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm new file mode 100644 index 0000000000..f12133fff7 --- /dev/null +++ b/guix/scripts/pull.scm @@ -0,0 +1,222 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts pull) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix config) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix build download) + #:use-module (gnu packages base) + #:use-module ((gnu packages bootstrap) + #:select (%bootstrap-guile)) + #: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)) + +(define %snapshot-url + "http://hydra.gnu.org/job/guix/master/tarball/latest/download" + ;;"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" + ) + +(define (download-and-store store) + "Download the latest Guix tarball, add it to STORE, and return its store +path." + ;; FIXME: Authenticate the downloaded file! + ;; FIXME: Optimize data transfers using rsync, Git, bsdiff, or GNUnet's DHT. + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port (current-error-port))) + (url-fetch %snapshot-url temp)))) + (close port) + (and result + (add-to-store store "guix-latest.tar.gz" #f "sha256" temp)))))) + +(define (unpack store tarball) + "Return a derivation that unpacks TARBALL into STORE and compiles Scheme +files." + (define builder + `(begin + (use-modules (guix build utils) + (system base compile) + (ice-9 ftw) + (ice-9 match)) + + (let ((out (assoc-ref %outputs "out")) + (tar (assoc-ref %build-inputs "tar")) + (gzip (assoc-ref %build-inputs "gzip")) + (gcrypt (assoc-ref %build-inputs "gcrypt")) + (tarball (assoc-ref %build-inputs "tarball"))) + (setenv "PATH" (string-append tar "/bin:" gzip "/bin")) + + (system* "tar" "xvf" tarball) + (match (scandir "." (lambda (name) + (and (not (member name '("." ".."))) + (file-is-directory? name)))) + ((dir) + (chdir dir)) + (x + (error "tarball did not produce a single source directory" x))) + + (format #t "copying and compiling Guix to `~a'...~%" out) + + ;; Copy everything under guix/ and gnu/ plus guix.scm. + (file-system-fold (lambda (dir stat result) ; enter? + (or (string-prefix? "./guix" dir) + (string-prefix? "./gnu" dir) + (string=? "." dir))) + (lambda (file stat result) ; leaf + (when (or (not (string=? (dirname file) ".")) + (string=? (basename file) "guix.scm")) + (let ((target (string-drop file 1))) + (copy-file file + (string-append out target))))) + (lambda (dir stat result) ; down + (mkdir (string-append out + (string-drop dir 1)))) + (const #t) ; up + (const #t) ; skip + (lambda (file stat errno result) + (error "cannot access file" + file (strerror errno))) + #f + "." + lstat) + + ;; Add a fake (guix config) module to allow the other modules to be + ;; compiled. The user's (guix config) is the one that will be used. + (copy-file "guix/config.scm.in" + (string-append out "/guix/config.scm")) + (substitute* (string-append out "/guix/config.scm") + (("@LIBGCRYPT@") + (string-append gcrypt "/lib/libgcrypt"))) + + ;; Augment the search path so Scheme code can be compiled. + (set! %load-path (cons out %load-path)) + (set! %load-compiled-path (cons out %load-compiled-path)) + + ;; Compile the .scm files. + (for-each (lambda (file) + (when (string-suffix? ".scm" file) + (let ((go (string-append (string-drop-right file 4) + ".go"))) + (compile-file file + #:output-file go + #:opts %auto-compilation-options)))) + (find-files out "\\.scm")) + + ;; Remove the "fake" (guix config). + (delete-file (string-append out "/guix/config.scm")) + (delete-file (string-append out "/guix/config.go"))))) + + (build-expression->derivation store "guix-latest" (%current-system) + builder + `(("tar" ,(package-derivation store tar)) + ("gzip" ,(package-derivation store gzip)) + ("gcrypt" ,(package-derivation store + libgcrypt)) + ("tarball" ,tarball)) + #:modules '((guix build utils)))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + '()) + +(define (show-help) + (display (_ "Usage: guix pull [OPTION]... +Download and deploy the latest version of Guix.\n")) + (display (_ " + --verbose produce verbose output")) + (display (_ " + --bootstrap use the bootstrap Guile to build the new Guix")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '("verbose") #f #f + (lambda (opt name arg result) + (alist-cons 'verbose? #t result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix pull"))))) + +(define (guix-pull . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: unexpected argument~%") arg)) + %default-options)) + + (let ((opts (parse-options)) + (store (open-connection))) + (with-error-handling + (let ((tarball (download-and-store store))) + (unless tarball + (leave (_ "failed to download up-to-date source, exiting\n"))) + (parameterize ((%guile-for-build + (package-derivation store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + guile-final))) + (current-build-output-port + (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")))) + (show-what-to-build store (list source)) + (if (build-derivations store (list source)) + (let ((latest (string-append config-dir "/latest"))) + (add-indirect-root store latest) + (switch-symlinks latest source-dir) + (format #t + (_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + #t)))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 2b75504573..7d1ea2bcbd 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -41,6 +41,7 @@ location->string call-with-temporary-output-file switch-symlinks + config-directory fill-paragraph string->recutils package->recutils @@ -178,6 +179,26 @@ both when LINK already exists and when it does not." (symlink target pivot) (rename-file pivot link))) +(define (config-directory) + "Return the name of the configuration directory, after making sure that it +exists. Honor the XDG specs, +." + (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME") + (and=> (getenv "HOME") + (cut string-append <> "/.config"))) + (cut string-append <> "/guix")))) + (catch 'system-error + (lambda () + (mkdir dir) + dir) + (lambda args + (match (system-error-errno args) + ((or EEXIST 0) + dir) + (err + (leave (_ "failed to create configuration directory `~a': ~a~%") + dir (strerror err)))))))) + (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. diff --git a/po/POTFILES.in b/po/POTFILES.in index 5c0f131c06..bdb894db20 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -8,4 +8,5 @@ guix/scripts/build.scm guix/scripts/download.scm guix/scripts/package.scm guix/scripts/gc.scm +guix/scripts/pull.scm guix/ui.scm diff --git a/scripts/guix.in b/scripts/guix.in index 2fdde7d13a..1315789a9c 100644 --- a/scripts/guix.in +++ b/scripts/guix.in @@ -22,7 +22,8 @@ ;; IMPORTANT: We must avoid loading any modules from Guix here, ;; because we need to adjust the guile load paths first. ;; It's okay to import modules from core Guile though. -(use-modules (ice-9 regex)) +(use-modules (ice-9 regex) + (srfi srfi-26)) (let () (define-syntax-rule (push! elt v) (set! v (cons elt v))) @@ -45,7 +46,14 @@ (unless (getenv "GUIX_UNINSTALLED") (let ((module-dir (config-lookup "guilemoduledir"))) (push! module-dir %load-path) - (push! module-dir %load-compiled-path)))) + (push! module-dir %load-compiled-path)) + (let ((updates-dir (and=> (or (getenv "XDG_CONFIG_HOME") + (and=> (getenv "HOME") + (cut string-append <> "/.config"))) + (cut string-append <> "/guix/latest")))) + (when (file-exists? updates-dir) + (push! updates-dir %load-path) + (push! updates-dir %load-compiled-path))))) (define (run-guix-main) (let ((guix-main (module-ref (resolve-interface '(guix ui)) -- cgit v1.2.3 From a1c14677564b90a67eec5865dd63345a35cafd42 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Feb 2013 20:01:29 +0100 Subject: pull: Build (guix build download) first, because of the (gnutls) autoload. * guix/scripts/pull.scm (unpack): Build (guix build download) first, as done in 855a8ad71def2ebc594ed32c57bda0ca4e13d91c. Reported by Andreas Enge . --- guix/scripts/pull.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f12133fff7..42ff525524 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -123,7 +123,12 @@ files." (compile-file file #:output-file go #:opts %auto-compilation-options)))) - (find-files out "\\.scm")) + + ;; XXX: Because of the autoload hack in (guix build + ;; download), we must build it first to avoid errors since + ;; (gnutls) is unavailable. + (cons (string-append out "/guix/build/download.scm") + (find-files out "\\.scm"))) ;; Remove the "fake" (guix config). (delete-file (string-append out "/guix/config.scm")) -- cgit v1.2.3 From da9bf2efc56266d8717496c303a6d4b16de94b63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Feb 2013 21:08:06 +0100 Subject: pull: Distinguish "already up to date" from "updated". * guix/ui.scm (show-what-to-build): Return (length req*). * guix/scripts/pull.scm (guix-pull): Print an "already up to date" message when there's nothing to build. --- guix/scripts/pull.scm | 20 ++++++++++++-------- guix/ui.scm | 6 ++++-- 2 files changed, 16 insertions(+), 10 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 42ff525524..942bf501c5 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -216,12 +216,16 @@ Download and deploy the latest version of Guix.\n")) ((source-dir) (derivation-output-path (assoc-ref (derivation-outputs drv) "out")))) - (show-what-to-build store (list source)) - (if (build-derivations store (list source)) - (let ((latest (string-append config-dir "/latest"))) - (add-indirect-root store latest) - (switch-symlinks latest source-dir) - (format #t - (_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) + (if (show-what-to-build store (list source)) + (if (build-derivations store (list source)) + (let ((latest (string-append config-dir "/latest"))) + (add-indirect-root store latest) + (switch-symlinks latest source-dir) + (format #t + (_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + #t) + (leave (_ "failed to update Guix, check the build log~%"))) + (begin + (display (_ "Guix already up to date\n")) #t)))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 7d1ea2bcbd..7e0c61b4f8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -118,7 +118,8 @@ General help using GNU software: ")) (define* (show-what-to-build store drv #:optional dry-run?) "Show what will or would (depending on DRY-RUN?) be built in realizing the -derivations listed in DRV." +derivations listed in DRV. Return #t if there's something to build, #f +otherwise." (let* ((req (append-map (lambda (drv-path) (let ((d (call-with-input-file drv-path read-derivation))) @@ -140,7 +141,8 @@ derivations listed in DRV." (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" (length req*)) - (null? req*) req*)))) + (null? req*) req*)) + (pair? req*))) (define-syntax with-error-handling (syntax-rules () -- cgit v1.2.3 From bdf06d8922e62f725f94560c1aa1f00e3392b624 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 Mar 2013 12:46:28 +0200 Subject: pull: Switch to the cgit URL. * guix/scripts/pull.scm (%snapshot-url): Switch to the cgit URL, given that the Hydra one is not currently available. --- guix/scripts/pull.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index bc72dc4088..c5facd84d5 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -34,8 +34,8 @@ #:export (guix-pull)) (define %snapshot-url - "http://hydra.gnu.org/job/guix/master/tarball/latest/download" - ;;"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" + ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download" + "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" ) (define (download-and-store store) -- cgit v1.2.3 From 419fffa2e84bdcfee13572e1b346a7487926113d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Apr 2013 10:44:20 +0200 Subject: Add preliminary binary substituter. * guix/scripts/substitute-binary.scm: New file. * Makefile.am (MODULES): Add it. * nix/scripts/substitute-binary.in: New file. * config-daemon.ac: Produce nix/scripts/substitute-binary. * daemon.am (nodist_pkglibexec_SCRIPTS): Add nix/scripts/substitute-binary. * guix/store.scm (substitutable-path-info): Use the `query-substitutable-path-infos' RPC. * nix/nix-daemon/guix-daemon.cc (main): Honor `NIX_SUBSTITUTERS'. * pre-inst-env.in: Set `NIX_SUBSTITUTERS'. * test-env.in: Leave `NIX_SUBSTITUTERS' unchanged. Set `GUIX_BINARY_SUBSTITUTE_URL, and create $NIX_STATE_DIR/substituter-data. Run `guix-daemon' within `./pre-inst-env'. * tests/store.scm ("substitute query"): New test. --- .gitignore | 1 + Makefile.am | 1 + config-daemon.ac | 5 +- daemon.am | 3 +- guix/scripts/substitute-binary.scm | 232 +++++++++++++++++++++++++++++++++++++ guix/store.scm | 2 +- nix/nix-daemon/guix-daemon.cc | 12 +- nix/scripts/substitute-binary.in | 11 ++ pre-inst-env.in | 3 +- test-env.in | 17 ++- tests/store.scm | 39 +++++++ 11 files changed, 313 insertions(+), 13 deletions(-) create mode 100755 guix/scripts/substitute-binary.scm create mode 100644 nix/scripts/substitute-binary.in (limited to 'guix/scripts') diff --git a/.gitignore b/.gitignore index 302e473fd8..f2b1f1cd39 100644 --- a/.gitignore +++ b/.gitignore @@ -72,3 +72,4 @@ stamp-h[0-9] /doc/guix.tp /doc/guix.vr /doc/guix.vrs +/nix/scripts/substitute-binary diff --git a/Makefile.am b/Makefile.am index 722b3b79fe..8b3057fd0b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -31,6 +31,7 @@ MODULES = \ guix/scripts/package.scm \ guix/scripts/gc.scm \ guix/scripts/pull.scm \ + guix/scripts/substitute-binary.scm \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ diff --git a/config-daemon.ac b/config-daemon.ac index f48741dfda..eed1e23f9e 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -93,8 +93,9 @@ if test "x$guix_build_daemon" = "xyes"; then AC_MSG_RESULT([$GUIX_TEST_ROOT]) AC_SUBST([GUIX_TEST_ROOT]) - AC_CONFIG_FILES([nix/scripts/list-runtime-roots], - [chmod +x nix/scripts/list-runtime-roots]) + AC_CONFIG_FILES([nix/scripts/list-runtime-roots + nix/scripts/substitute-binary], + [chmod +x nix/scripts/list-runtime-roots nix/scripts/substitute-binary]) fi AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"]) diff --git a/daemon.am b/daemon.am index 4f2314b773..069700b1b6 100644 --- a/daemon.am +++ b/daemon.am @@ -159,7 +159,8 @@ nix/libstore/schema.sql.hh: nix/libstore/schema.sql (write (get-string-all in) out)))))" nodist_pkglibexec_SCRIPTS = \ - nix/scripts/list-runtime-roots + nix/scripts/list-runtime-roots \ + nix/scripts/substitute-binary EXTRA_DIST += \ nix/sync-with-upstream \ diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm new file mode 100755 index 0000000000..6e886b6c96 --- /dev/null +++ b/guix/scripts/substitute-binary.scm @@ -0,0 +1,232 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts substitute-binary) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:export (guix-substitute-binary)) + +;;; Comment: +;;; +;;; This is the "binary substituter". It is invoked by the daemon do check +;;; for the existence of available "substitutes" (pre-built binaries), and to +;;; actually use them as a substitute to building things locally. +;;; +;;; If possible, substitute a binary for the requested store path, using a Nix +;;; "binary cache". This program implements the Nix "substituter" protocol. +;;; +;;; Code: + +(define (fields->alist port) + "Read recutils-style record from PORT and return them as a list of key/value +pairs." + (define field-rx + (make-regexp "^([[:graph:]]+): (.*)$")) + + (let loop ((line (read-line port)) + (result '())) + (cond ((eof-object? line) + (reverse result)) + ((regexp-exec field-rx line) + => + (lambda (match) + (loop (read-line port) + (alist-cons (match:substring match 1) + (match:substring match 2) + result)))) + (else + (error "unmatched line" line))))) + +(define (alist->record alist make keys) + "Apply MAKE to the values associated with KEYS in ALIST." + (let ((args (map (cut assoc-ref alist <>) keys))) + (apply make args))) + +(define (fetch uri) + (case (uri-scheme uri) + ((file) + (open-input-file (uri-path uri))) + ((http) + (let*-values (((resp port) + ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated + ;; in 2.0.8 (!). Assume it is available here. + (if (version>? "2.0.7" (version)) + (http-get* uri #:decode-body? #f) + (http-get uri #:streaming? #t))) + ((code) + (response-code resp)) + ((size) + (response-content-length resp))) + (case code + ((200) ; OK + port) + ((301 ; moved permanently + 302) ; found (redirection) + (let ((uri (response-location resp))) + (format #t "following redirection to `~a'...~%" + (uri->string uri)) + (fetch uri))) + (else + (error "download failed" (uri->string uri) + code (response-reason-phrase resp)))))))) + +(define-record-type + (%make-cache url store-directory wants-mass-query?) + cache? + (url cache-url) + (store-directory cache-store-directory) + (wants-mass-query? cache-wants-mass-query?)) + +(define (open-cache url) + "Open the binary cache at URL. Return a object on success, or #f on +failure." + (define (download-cache-info url) + ;; Download the `nix-cache-info' from URL, and return its contents as an + ;; list of key/value pairs. + (and=> (false-if-exception (fetch (string->uri url))) + fields->alist)) + + (and=> (download-cache-info (string-append url "/nix-cache-info")) + (lambda (properties) + (alist->record properties + (cut %make-cache url <...>) + '("StoreDir" "WantMassQuery"))))) + +(define-record-type + (%make-narinfo path url compression file-hash file-size nar-hash nar-size + references deriver system) + narinfo? + (path narinfo-path) + (url narinfo-url) + (compression narinfo-compression) + (file-hash narinfo-file-hash) + (file-size narinfo-file-size) + (nar-hash narinfo-hash) + (nar-size narinfo-size) + (references narinfo-references) + (deriver narinfo-deriver) + (system narinfo-system)) + +(define (make-narinfo path url compression file-hash file-size nar-hash nar-size + references deriver system) + "Return a new object." + (%make-narinfo path url compression file-hash + (and=> file-size string->number) + nar-hash + (and=> nar-size string->number) + (string-tokenize references) + (match deriver + ((or #f "") #f) + (_ deriver)) + system)) + +(define (fetch-narinfo cache path) + "Return the record for PATH, or #f if CACHE does not hold PATH." + (define (download url) + ;; Download the `nix-cache-info' from URL, and return its contents as an + ;; list of key/value pairs. + (and=> (false-if-exception (fetch (string->uri url))) + fields->alist)) + + (and=> (download (string-append (cache-url cache) "/" + (store-path-hash-part path) + ".narinfo")) + (lambda (properties) + (alist->record properties make-narinfo + '("StorePath" "URL" "Compression" + "FileHash" "FileSize" "NarHash" "NarSize" + "References" "Deriver" "System"))))) + +(define %cache-url + (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") + "http://hydra.gnu.org")) + + +;;; +;;; Entry point. +;;; + +(define (guix-substitute-binary . args) + "Implement the build daemon's substituter protocol." + (match args + (("--query") + (let ((cache (open-cache %cache-url))) + (let loop ((command (read-line))) + (or (eof-object? command) + (begin + (match (string-tokenize command) + (("have" paths ..1) + ;; Return the subset of PATHS available in CACHE. + (let ((substitutable + (if cache + (par-map (cut fetch-narinfo cache <>) + paths) + '()))) + (for-each (lambda (narinfo) + (when narinfo + (display (narinfo-path narinfo)) + (newline))) + substitutable))) + (("info" paths ..1) + ;; Reply info about PATHS if it's in CACHE. + (let ((substitutable + (if cache + (par-map (cut fetch-narinfo cache <>) + paths) + '()))) + (for-each (lambda (narinfo) + (format #t "~a\n~a\n~a\n" + (narinfo-path narinfo) + (or (and=> (narinfo-deriver narinfo) + (cute string-append + (%store-prefix) "/" + <>)) + "") + (length (narinfo-references narinfo))) + (for-each (cute format #t "~a/~a~%" + (%store-prefix) <>) + (narinfo-references narinfo)) + (format #t "~a\n~a\n" + (or (narinfo-file-size narinfo) 0) + (or (narinfo-size narinfo) 0)) + (newline)) + substitutable))) + (wtf + (error "unknown `--query' command" wtf))) + (loop (read-line))))))) + (("--substitute" store-path destination) + ;; Download PATH and add it to the store. + ;; TODO: Implement. + (format (current-error-port) "substitution not implemented yet~%") + #f) + (("--version") + (show-version-and-exit "guix substitute-binary")))) + +;;; substitute-binary.scm ends here diff --git a/guix/store.scm b/guix/store.scm index 3bb2656bb6..de9785c835 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -662,7 +662,7 @@ file name. Return #t on success." store-path-list)) (define substitutable-path-info - (operation (query-substitutable-paths (store-path-list paths)) + (operation (query-substitutable-path-infos (store-path-list paths)) "Return information about the subset of PATHS that is substitutable. For each substitutable path, a `substitutable?' object is returned." diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 1611840bd4..0e2f36150b 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -200,9 +200,17 @@ main (int argc, char *argv[]) { settings.processEnvironment (); - /* FIXME: Disable substitutes until we have something that works. */ - settings.useSubstitutes = false; + /* Use our substituter by default. */ settings.substituters.clear (); + string subs = getEnv ("NIX_SUBSTITUTERS", "default"); + if (subs == "default") + /* XXX: No substituters until we have something that works. */ + settings.substituters.clear (); + // settings.substituters.push_back (settings.nixLibexecDir + // + "/guix/substitute-binary"); + else + settings.substituters = tokenizeString (subs, ":"); + argp_parse (&argp, argc, argv, 0, 0, 0); diff --git a/nix/scripts/substitute-binary.in b/nix/scripts/substitute-binary.in new file mode 100644 index 0000000000..48d7bb8ff1 --- /dev/null +++ b/nix/scripts/substitute-binary.in @@ -0,0 +1,11 @@ +#!@SHELL@ +# A shorthand for "guix substitute-binary", for use by the daemon. + +if test "x$GUIX_UNINSTALLED" = "x" +then + prefix="@prefix@" + exec_prefix="@exec_prefix@" + exec "@bindir@/guix" substitute-binary "$@" +else + exec guix substitute-binary "$@" +fi diff --git a/pre-inst-env.in b/pre-inst-env.in index 4e079c8d41..5e7758cd7c 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -35,8 +35,9 @@ export PATH # Daemon helpers. NIX_ROOT_FINDER="@abs_top_builddir@/nix/scripts/list-runtime-roots" +NIX_SUBSTITUTERS="@abs_top_builddir@/nix/scripts/substitute-binary" NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper" -export NIX_ROOT_FINDER NIX_SETUID_HELPER +export NIX_ROOT_FINDER NIX_SETUID_HELPER NIX_SUBSTITUTERS # The following variables need only be defined when compiling Guix # modules, but we define them to be on the safe side in case of diff --git a/test-env.in b/test-env.in index 491a45c7b4..9a6257197c 100644 --- a/test-env.in +++ b/test-env.in @@ -1,7 +1,7 @@ #!/bin/sh # GNU Guix --- Functional package management for GNU -# Copyright © 2012 Ludovic Courtès +# Copyright © 2012, 2013 Ludovic Courtès # # This file is part of GNU Guix. # @@ -26,7 +26,6 @@ if [ -x "@abs_top_builddir@/guix-daemon" ] then - NIX_SUBSTITUTERS="" # don't resort to substituters NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper" # normally unused NIX_IGNORE_SYMLINK_STORE=1 # in case the store is a symlink NIX_STORE_DIR="@GUIX_TEST_ROOT@/store" @@ -39,18 +38,24 @@ then # that the directory name must be chosen so that the socket's file # name is less than 108-char long (the size of `sun_path' in glibc). # Currently, in Nix builds, we're at ~106 chars... - NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" # allow for parallel tests + NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" - export NIX_SUBSTITUTERS NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ + # A place to store data of the substituter. + GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data" + rm -rf "$NIX_STATE_DIR/substituter-data" + mkdir -p "$NIX_STATE_DIR/substituter-data" + + export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ - NIX_ROOT_FINDER NIX_SETUID_HELPER + NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL # Do that because store.scm calls `canonicalize-path' on it. mkdir -p "$NIX_STORE_DIR" # Launch the daemon without chroot support because is may be # unavailable, for instance if we're not running as root. - "@abs_top_builddir@/guix-daemon" --disable-chroot & + "@abs_top_builddir@/pre-inst-env" \ + "@abs_top_builddir@/guix-daemon" --disable-chroot & daemon_pid=$! trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT diff --git a/tests/store.scm b/tests/store.scm index d6e1aa54e3..c75b99c6a9 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -26,6 +26,7 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) @@ -128,6 +129,44 @@ (null? (substitutable-paths s o)) (null? (substitutable-path-info s o))))) +(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) + +(test-assert "substitute query" + (let* ((s (open-connection)) + (d (package-derivation s %bootstrap-guile (%current-system))) + (o (derivation-path->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'. + (call-with-output-file (string-append dir "/nix-cache-info") + (lambda (p) + (format p "StoreDir: ~a\nWantMassQuery: 0\n" + (getenv "NIX_STORE_DIR")))) + (call-with-output-file (string-append dir "/" (store-path-hash-part o) + ".narinfo") + (lambda (p) + (format p "StorePath: ~a +URL: ~a +Compression: none +NarSize: 1234 +References: +System: ~a +Deriver: ~a~%" + o ; StorePath + (string-append dir "/example.nar") ; URL + (%current-system) ; System + (basename d)))) ; Deriver + + ;; Make sure `substitute-binary' correctly communicates the above data. + (set-build-options s #:use-substitutes? #t) + (and (has-substitutes? s o) + (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) + (null? (substitutable-references s)) + (equal? (substitutable-nar-size s) 1234))))))) + (test-end "store") -- cgit v1.2.3 From 7ce1f2160fa783e9a43f8f8d8d5775d05a6b0638 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Apr 2013 21:47:55 +0200 Subject: substitute-binary: Fix communication of several store paths to the daemon. * guix/scripts/substitute-binary.scm (guix-substitute-binary)["--query"]: Emit blank lines only after the complete list of store paths has been returned. --- guix/scripts/substitute-binary.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 6e886b6c96..389acab094 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -191,9 +191,9 @@ failure." '()))) (for-each (lambda (narinfo) (when narinfo - (display (narinfo-path narinfo)) - (newline))) - substitutable))) + (format #t "~a~%" (narinfo-path narinfo)))) + substitutable) + (newline))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE. (let ((substitutable @@ -215,9 +215,9 @@ failure." (narinfo-references narinfo)) (format #t "~a\n~a\n" (or (narinfo-file-size narinfo) 0) - (or (narinfo-size narinfo) 0)) - (newline)) - substitutable))) + (or (narinfo-size narinfo) 0))) + substitutable) + (newline))) (wtf (error "unknown `--query' command" wtf))) (loop (read-line))))))) -- cgit v1.2.3 From 6f80c9d8f387f5b881a73cefdbbba91a40d8eec6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2013 22:30:06 +0200 Subject: ui: Add a `warning' macro. * guix/ui.scm (program-name, guix-warning-port): New variables. (warning): New macro. (guix-main): Parametrize PROGRAM-NAME. * guix/scripts/build.scm, guix/scripts/download.scm, guix/scripts/gc.scm, guix/scripts/package.scm: Adjust to use `leave' and `warning' consistently. --- guix/scripts/build.scm | 16 ++++++---------- guix/scripts/download.scm | 3 +-- guix/scripts/gc.scm | 15 ++++----------- guix/scripts/package.scm | 20 ++++++++----------- guix/ui.scm | 49 +++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 64 insertions(+), 39 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a49bfdbeb8..339ad0d06f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -176,9 +176,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) 0 paths)))) (lambda args - (format (current-error-port) - (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) + (leave (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))) (exit 1))))) (define newest-available-packages @@ -202,13 +201,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ((p) ; one match p) ((p x ...) ; several matches - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) + (warning (_ "ambiguous package specification `~a'~%") request) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) p) (_ ; no matches (if version diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 3f989a3494..7c00312c74 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -81,8 +81,7 @@ and the hash of its contents.\n")) ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (format (current-error-port) - "unsupported hash format: ~a~%" arg)))) + (leave (_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc (alist-delete 'format result)))) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 12d80fd171..3d918923f8 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -87,13 +87,9 @@ interpreted." ("TB" (expt 10 12)) ("" 1) (_ - (format (current-error-port) (_ "error: unknown unit: ~a~%") - unit) + (leave (_ "error: unknown unit: ~a~%") unit) (exit 1)))) - (begin - (format (current-error-port) - (_ "error: invalid number: ~a") numstr) - (exit 1))))) + (leave (_ "error: invalid number: ~a") numstr)))) (define %options ;; Specification of the command-line options. @@ -114,11 +110,8 @@ interpreted." (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (begin - (format (current-error-port) - (_ "error: invalid amount of storage: ~a~%") - arg) - (exit 1))))) + (leave (_ "error: invalid amount of storage: ~a~%") + arg)))) (#f result))))) (option '(#\d "delete") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6de2f1beb6..89708ccc49 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -208,12 +208,10 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (switch-symlinks profile previous-profile)) (cond ((not (file-exists? profile)) ; invalid profile - (format (current-error-port) - (_ "error: profile `~a' does not exist~%") - profile)) + (leave (_ "error: profile `~a' does not exist~%") + profile)) ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) + (leave (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-profile))) (let*-values (((drv-path drv) @@ -465,13 +463,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) ((p p* ...) - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) + (warning (_ "ambiguous package specification `~a'~%") + request) + (warning (_ "choosing ~a from ~a~%") + (package-full-name p) + (location->string (package-location p))) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) (() diff --git a/guix/ui.scm b/guix/ui.scm index 94f0825a0a..dfb6418a10 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -47,6 +47,9 @@ string->recutils package->recutils run-guix-command + program-name + guix-warning-port + warning guix-main)) ;;; Commentary: @@ -332,6 +335,43 @@ WIDTH columns." (symbol-append 'guix- command)))) (apply command-main args))) +(define program-name + ;; Name of the command-line program currently executing, or #f. + (make-parameter #f)) + +(define guix-warning-port + (make-parameter (current-warning-port))) + +(define-syntax warning + (lambda (s) + "Emit a warming. The macro assumes that `_' is bound to `gettext'." + ;; All this just to preserve `-Wformat' warnings. Too much? + + (define (augmented-format-string fmt) + (string-append "~:[~;guix ~a: ~]~a" (syntax->datum fmt))) + + (define prefix + #'(_ "warning: ")) + + (syntax-case s (N_ _) ; these are literals, yeah... + ((warning (_ fmt) args ...) + (string? (syntax->datum #'fmt)) + (with-syntax ((fmt* (augmented-format-string #'fmt)) + (prefix prefix)) + #'(format (guix-warning-port) (gettext fmt*) + (program-name) (program-name) prefix + args ...))) + ((warning (N_ singular plural n) args ...) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural))) + (with-syntax ((s (augmented-format-string #'singular)) + (p (augmented-format-string #'plural)) + (b prefix)) + #'(format (guix-warning-port) + (ngettext s p n %gettext-domain) + (program-name) (program-name) b + args ...)))))) + (define (guix-main arg0 . args) (initialize-guix) (let () @@ -340,10 +380,11 @@ WIDTH columns." (() (show-guix-usage) (exit 1)) (("--help") (show-guix-usage)) (("--version") (show-version-and-exit "guix")) - (((? option? arg1) args ...) (show-guix-usage) (exit 1)) + (((? option?) args ...) (show-guix-usage) (exit 1)) ((command args ...) - (apply run-guix-command - (string->symbol command) - args))))) + (parameterize ((program-name command)) + (apply run-guix-command + (string->symbol command) + args)))))) ;;; ui.scm ends here -- cgit v1.2.3 From f03f0c9a867e22dd999a8519f4bf03b182739c97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 15:52:27 +0200 Subject: substitute-binary: Correctly handle missing narinfos in `--query' mode. * guix/scripts/substitute-binary.scm (guix-substitute-binary)["--query"]("have", "info"): Filter SUBSTITUTABLE through `narinfo?'. --- guix/scripts/substitute-binary.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 389acab094..64df4f09d6 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -192,7 +192,7 @@ failure." (for-each (lambda (narinfo) (when narinfo (format #t "~a~%" (narinfo-path narinfo)))) - substitutable) + (filter narinfo? substitutable)) (newline))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE. @@ -216,7 +216,7 @@ failure." (format #t "~a\n~a\n" (or (narinfo-file-size narinfo) 0) (or (narinfo-size narinfo) 0))) - substitutable) + (filter narinfo? substitutable)) (newline))) (wtf (error "unknown `--query' command" wtf))) -- cgit v1.2.3 From cdf2022052268b9c517d486294ec34f0c18091aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 17:30:27 +0200 Subject: substitute-binary: Implement `--substitute'. This allows build outputs to be transparently downloaded from http://hydra.gnu.org, for example. * config-daemon.ac: Check for `gzip', `bzip2', and `xz'. * guix/config.scm.in (%gzip, %bzip2, %xz): New variable. * guix/scripts/substitute-binary.scm (fetch): Return SIZE as a second value. (): Change `url' to `uri'. (make-narinfo): Rename to... (narinfo-maker): ... this. Handle relative URLs. (fetch-narinfo): Adjust accordingly. (filtered-port, decompressed-port): New procedures. (guix-substitute-binary): Implement the `--substitute' case. * tests/store.scm ("substitute query"): Use (%store-prefix) instead of (getenv "NIX_STORE_DIR"). ("substitute"): New test. --- config-daemon.ac | 8 +++ guix/config.scm.in | 14 +++++- guix/scripts/substitute-binary.scm | 100 +++++++++++++++++++++++++++++-------- tests/store.scm | 55 +++++++++++++++++++- 4 files changed, 154 insertions(+), 23 deletions(-) (limited to 'guix/scripts') diff --git a/config-daemon.ac b/config-daemon.ac index eed1e23f9e..7c51f2b95c 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -11,6 +11,14 @@ if test "x$guix_build_daemon" = "xyes"; then AC_PROG_RANLIB AC_CONFIG_HEADER([nix/config.h]) + dnl Decompressors, for use by the substituter. + AC_PATH_PROG([GZIP], [gzip]) + AC_PATH_PROG([BZIP2], [bzip2]) + AC_PATH_PROG([XZ], [xz]) + AC_SUBST([GZIP]) + AC_SUBST([BZIP2]) + AC_SUBST([XZ]) + dnl Use 64-bit file system calls so that we can support files > 2 GiB. AC_SYS_LARGEFILE diff --git a/guix/config.scm.in b/guix/config.scm.in index ab7b0669b8..772ea8c289 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -26,7 +26,10 @@ %system %libgcrypt %nixpkgs - %nix-instantiate)) + %nix-instantiate + %gzip + %bzip2 + %xz)) ;;; Commentary: ;;; @@ -67,4 +70,13 @@ (define %nix-instantiate "@NIX_INSTANTIATE@") +(define %gzip + "@GZIP@") + +(define %bzip2 + "@BZIP2@") + +(define %xz + "@XZ@") + ;;; config.scm ends here diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 64df4f09d6..2b447ce7f2 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -20,10 +20,13 @@ #:use-module (guix ui) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix config) + #:use-module (guix nar) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 threads) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -70,9 +73,12 @@ pairs." (apply make args))) (define (fetch uri) + "Return a binary input port to URI and the number of bytes it's expected to +provide." (case (uri-scheme uri) ((file) - (open-input-file (uri-path uri))) + (let ((port (open-input-file (uri-path uri)))) + (values port (stat:size (stat port))))) ((http) (let*-values (((resp port) ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated @@ -86,7 +92,7 @@ pairs." (response-content-length resp))) (case code ((200) ; OK - port) + (values port size)) ((301 ; moved permanently 302) ; found (redirection) (let ((uri (response-location resp))) @@ -120,11 +126,11 @@ failure." '("StoreDir" "WantMassQuery"))))) (define-record-type - (%make-narinfo path url compression file-hash file-size nar-hash nar-size + (%make-narinfo path uri compression file-hash file-size nar-hash nar-size references deriver system) narinfo? (path narinfo-path) - (url narinfo-url) + (uri narinfo-uri) (compression narinfo-compression) (file-hash narinfo-file-hash) (file-size narinfo-file-size) @@ -134,18 +140,26 @@ failure." (deriver narinfo-deriver) (system narinfo-system)) -(define (make-narinfo path url compression file-hash file-size nar-hash nar-size - references deriver system) - "Return a new object." - (%make-narinfo path url compression file-hash - (and=> file-size string->number) - nar-hash - (and=> nar-size string->number) - (string-tokenize references) - (match deriver - ((or #f "") #f) - (_ deriver)) - system)) +(define (narinfo-maker cache-url) + "Return a narinfo constructor for narinfos originating from CACHE-URL." + (lambda (path url compression file-hash file-size nar-hash nar-size + references deriver system) + "Return a new object." + (%make-narinfo path + + ;; Handle the case where URL is a relative URL. + (or (string->uri url) + (string->uri (string-append cache-url "/" url))) + + compression file-hash + (and=> file-size string->number) + nar-hash + (and=> nar-size string->number) + (string-tokenize references) + (match deriver + ((or #f "") #f) + (_ deriver)) + system))) (define (fetch-narinfo cache path) "Return the record for PATH, or #f if CACHE does not hold PATH." @@ -159,11 +173,36 @@ failure." (store-path-hash-part path) ".narinfo")) (lambda (properties) - (alist->record properties make-narinfo + (alist->record properties (narinfo-maker (cache-url cache)) '("StorePath" "URL" "Compression" "FileHash" "FileSize" "NarHash" "NarSize" "References" "Deriver" "System"))))) +(define (filtered-port command input) + "Return an input port (and PID) where data drained from INPUT is filtered +through COMMAND. INPUT must be a file input port." + (let ((i+o (pipe))) + (match (primitive-fork) + (0 + (close-port (car i+o)) + (close-port (current-input-port)) + (dup2 (fileno input) 0) + (close-port (current-output-port)) + (dup2 (fileno (cdr i+o)) 1) + (apply execl (car command) command)) + (child + (close-port (cdr i+o)) + (values (car i+o) child))))) + +(define (decompressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION." + (match compression + ("none" (values input #f)) + ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) + ("xz" (filtered-port `(,%xz "-dc") input)) + ("gzip" (filtered-port `(,%gzip "-dc") input)) + (else (error "unsupported compression scheme" compression)))) + (define %cache-url (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") "http://hydra.gnu.org")) @@ -222,10 +261,29 @@ failure." (error "unknown `--query' command" wtf))) (loop (read-line))))))) (("--substitute" store-path destination) - ;; Download PATH and add it to the store. - ;; TODO: Implement. - (format (current-error-port) "substitution not implemented yet~%") - #f) + ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. + (let* ((cache (open-cache %cache-url)) + (narinfo (fetch-narinfo cache store-path)) + (uri (narinfo-uri narinfo))) + ;; Tell the daemon what the expected hash of the Nar itself is. + (format #t "~a~%" (narinfo-hash narinfo)) + + (let*-values (((raw download-size) + (fetch uri)) + ((input pid) + (decompressed-port (narinfo-compression narinfo) + raw))) + ;; Note that Hydra currently generates Nars on the fly and doesn't + ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice. + (format (current-error-port) + (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%") + store-path (uri->string uri) + download-size + (and=> download-size (cut / <> 1024.0))) + + ;; Unpack the Nar at INPUT into DESTINATION. + (restore-file input destination) + (or (not pid) (zero? (cdr (waitpid pid))))))) (("--version") (show-version-and-exit "guix substitute-binary")))) diff --git a/tests/store.scm b/tests/store.scm index c75b99c6a9..4ee20a9352 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -23,9 +23,11 @@ #:use-module (guix base32) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix nar) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -141,7 +143,7 @@ (call-with-output-file (string-append dir "/nix-cache-info") (lambda (p) (format p "StoreDir: ~a\nWantMassQuery: 0\n" - (getenv "NIX_STORE_DIR")))) + (%store-prefix)))) (call-with-output-file (string-append dir "/" (store-path-hash-part o) ".narinfo") (lambda (p) @@ -167,6 +169,57 @@ Deriver: ~a~%" (null? (substitutable-references s)) (equal? (substitutable-nar-size s) 1234))))))) +(test-assert "substitute" + (let* ((s (open-connection)) + (c (random-text)) ; contents of the output + (d (build-expression->derivation + s "substitute-me" (%current-system) + `(call-with-output-file %output + (lambda (p) + (exit 1) ; would actually fail + (display ,c p))) + '() + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation-path->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'. + (call-with-output-file (string-append dir "/nix-cache-info") + (lambda (p) + (format p "StoreDir: ~a\nWantMassQuery: 0\n" + (%store-prefix)))) + (call-with-output-file (string-append dir "/example.out") + (lambda (p) + (display c p))) + (call-with-output-file (string-append dir "/example.nar") + (lambda (p) + (write-file (string-append dir "/example.out") p))) + (call-with-output-file (string-append dir "/" (store-path-hash-part o) + ".narinfo") + (lambda (p) + (format p "StorePath: ~a +URL: ~a +Compression: none +NarSize: 1234 +NarHash: sha256:~a +References: +System: ~a +Deriver: ~a~%" + o ; StorePath + "example.nar" ; relative URL + (call-with-input-file (string-append dir "/example.nar") + (compose bytevector->nix-base32-string sha256 + get-bytevector-all)) + (%current-system) ; System + (basename d)))) ; Deriver + + ;; Make sure we use `substitute-binary'. + (set-build-options s #:use-substitutes? #t) + (and (has-substitutes? s o) + (build-derivations s (list d)) + (equal? c (call-with-input-file o get-string-all))))) + (test-end "store") -- cgit v1.2.3 From 581f9eb84532b5682f48926e868456e2457fe54c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 15:43:55 +0200 Subject: guix package: Add `--no-substitutes'. * guix/scripts/package.scm (%default-options): Add `substitutes?'. (show-help, %options): Add and document `--no-substitutes'. (guix-package): Call `set-build-options' to honor `substitutes?'. --- doc/guix.texi | 3 +++ guix/scripts/package.scm | 13 ++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 1be172c3f6..c91bc2021d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -570,6 +570,9 @@ Use @var{profile} instead of the user's default profile. @itemx -n Show what would be done without actually doing it. +@item --no-substitutes +Build instead of resorting to pre-built substitutes. + @item --verbose Produce verbose output. In particular, emit the environment's build log on the standard error port. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 89708ccc49..ba75cd778c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -313,7 +313,8 @@ but ~a is available upstream~%") (define %default-options ;; Alist of default option values. - `((profile . ,%current-profile))) + `((profile . ,%current-profile) + (substitutes? . #t))) (define (show-help) (display (_ "Usage: guix package [OPTION]... PACKAGES... @@ -334,6 +335,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (display (_ " -n, --dry-run show what would be done without actually doing it")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " @@ -388,6 +391,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -750,6 +757,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (or (process-query opts) (with-error-handling (parameterize ((%store (open-connection))) + (set-build-options (%store) + #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%guile-for-build (package-derivation (%store) (if (assoc-ref opts 'bootstrap?) -- cgit v1.2.3 From d5d6db8918fb8cd66132f5ad5d4c03d6ed2db815 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 18:07:17 +0200 Subject: package: Being at the empty profile is not an error. * guix/scripts/package.scm (roll-back): Use `format', not `leave' when indicating "already at the empty profile". Fixes a regression introduced in a2011be5dfaf2b94a1d0e3dfbcf4b512389b4711. Reported by Nikita Karetnikov . --- guix/scripts/package.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ba75cd778c..ac99d16497 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -211,7 +211,8 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (leave (_ "error: profile `~a' does not exist~%") profile)) ((zero? number) ; empty profile - (leave (_ "nothing to do: already at the empty profile~%"))) + (format (current-error-port) + (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-profile))) (let*-values (((drv-path drv) -- cgit v1.2.3 From 5924080dccae93fa725bf77df5f7a1e9a8756101 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Apr 2013 23:05:57 +0200 Subject: guix package: Add `--search-paths' & co. * guix/scripts/package.scm (search-path-environment-variables, display-search-paths): New procedures. (show-help, %options): Add `--search-paths'. (guix-package)[process-actions]: Call `display-search-paths' once the profile is ready. [process-query]: Honor `search-paths'. --- doc/guix.texi | 22 +++++++++++++++- guix/scripts/package.scm | 66 +++++++++++++++++++++++++++++++++++++++++++++++- tests/guix-package.sh | 8 ++++++ 3 files changed, 94 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index e23eab0f81..d571de95a0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -517,8 +517,13 @@ Thus, when installing MPC, the MPFR and GMP libraries also get installed in the profile; removing MPC also removes MPFR and GMP---unless they had also been explicitly installed independently. +Besides, packages sometime rely on the definition of environment +variables for their search paths (see explanation of +@code{--search-paths} below.) Any missing or possibly incorrect +environment variable definitions are reported here. + @c XXX: keep me up-to-date -Besides, when installing a GNU package, the tool reports the +Finally, when installing a GNU package, the tool reports the availability of a newer upstream version. In the future, it may provide the option of installing directly from the upstream version, even if that version is not yet in the distribution. @@ -566,6 +571,21 @@ Installing, removing, or upgrading packages from a generation that has been rolled back to overwrites previous future generations. Thus, the history of a profile's generations is always linear. +@item --search-paths +@cindex search paths +Report environment variable definitions, in Bash syntax, that may be +needed in order to use the set of installed packages. These environment +variables are used to specify @dfn{search paths} for files used by some +of the installed packages. + +For example, GCC needs the @code{CPATH} and @code{LIBRARY_PATH} +environment variables to be defined so it can look for headers and +libraries in the user's profile (@pxref{Environment Variables,,, gcc, +Using the GNU Compiler Collection (GCC)}). If GCC and, say, the C +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 --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 c5656efc14..560b673618 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -330,6 +330,53 @@ but ~a is available upstream~%") ((getaddrinfo-error ftp-error) #f) (else (apply throw key args)))))) +(define* (search-path-environment-variables packages profile + #:optional (getenv getenv)) + "Return environment variable definitions that may be needed for the use of +PACKAGES in PROFILE. Use GETENV to determine the current settings and report +only settings not already effective." + + ;; The search path info is not stored in the manifest. Thus, we infer the + ;; search paths from same-named packages found in the distro. + + (define package-in-manifest->package + (match-lambda + ((name version _ ...) + (match (append (find-packages-by-name name version) + (find-packages-by-name name)) + ((p _ ...) p) + (_ #f))))) + + (define search-path-definition + (match-lambda + (($ variable directories separator) + (let ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + (directories (filter file-exists? + (map (cut string-append profile + "/" <>) + directories)))) + (if (every (cut member <> values) directories) + #f + (format #f "export ~a=\"~a\"" + variable + (string-join directories separator))))))) + + (let* ((packages (filter-map package-in-manifest->package packages)) + (search-paths (delete-duplicates + (append-map package-native-search-paths + packages)))) + (filter-map search-path-definition search-paths))) + +(define (display-search-paths packages profile) + "Display the search path environment variables that may need to be set for +PACKAGES, in the context of PROFILE." + (let ((settings (search-path-environment-variables packages profile))) + (unless (null? settings) + (format #t (_ "The following environment variable definitions may be needed:~%")) + (format #t "~{ ~a~%~}" settings)))) + ;;; ;;; Command-line options. @@ -354,6 +401,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " --roll-back roll back to the previous generation")) + (display (_ " + --search-paths display needed environment variable definitions")) (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) @@ -408,6 +457,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) + (option '("search-paths") #f #f + (lambda (opt name arg result) + (cons `(query search-paths) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile arg @@ -728,7 +780,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (build-derivations (%store) (list prof-drv))) (begin (switch-symlinks name prof) - (switch-symlinks profile name)))))))))) + (switch-symlinks profile name) + (display-search-paths packages + profile)))))))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -776,6 +830,16 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (for-each (cute package->recutils <> (current-output-port)) (find-packages-by-description regexp)) #t)) + + (('search-paths) + (let* ((manifest (profile-manifest profile)) + (packages (manifest-packages manifest)) + (settings (search-path-environment-variables packages + profile + (const #f)))) + (format #t "~{~a~%~}" settings) + #t)) + (_ #f)))) (let ((opts (parse-options))) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7b101aa501..5a514a0dc0 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -47,6 +47,10 @@ test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" +# No search path env. var. here. +guix package --search-paths -p "$profile" +test "`guix package --search-paths -p "$profile" | wc -l`" = 0 + # Check whether we have network access. if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then @@ -119,6 +123,10 @@ then rm "$profile-1-link" guix package --bootstrap -p "$profile" --roll-back test "`readlink_base "$profile"`" = "$profile-0-link" + + # Make sure LIBRARY_PATH gets listed by `--search-paths'. + guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap + guix package --search-paths -p "$profile" | grep LIBRARY_PATH fi # Make sure the `:' syntax works. -- cgit v1.2.3