diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 337 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 101 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 293 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 86 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 16 |
5 files changed, 631 insertions, 202 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm new file mode 100644 index 0000000000..32690c6b45 --- /dev/null +++ b/guix/scripts/archive.scm @@ -0,0 +1,337 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts archive) + #:use-module (guix config) + #:use-module (guix utils) + #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix ui) + #:use-module (guix pki) + #:use-module (guix pk-crypto) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (guix scripts build) + #:use-module (guix scripts package) + #:use-module (rnrs io ports) + #:export (guix-archive)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix archive [OPTION]... PACKAGE... +Export/import one or more packages from/to the store.\n")) + (display (_ " + --export export the specified files/packages to stdout")) + (display (_ " + --import import from the archive passed on stdin")) + (display (_ " + --missing print the files from stdin that are missing")) + (newline) + (display (_ " + --generate-key[=PARAMETERS] + generate a key pair with the given parameters")) + (display (_ " + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + --fallback fall back to building when the substituter fails")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + --max-silent-time=SECONDS + mark the build as failed after SECONDS of silence")) + (display (_ " + -c, --cores=N allow the use of up to N CPU cores for the build")) + (newline) + (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 '("export") #f #f + (lambda (opt name arg result) + (alist-cons 'export #t result))) + (option '("import") #f #f + (lambda (opt name arg result) + (alist-cons 'import #t result))) + (option '("missing") #f #f + (lambda (opt name arg result) + (alist-cons 'missing #t result))) + (option '("generate-key") #f #t + (lambda (opt name arg result) + (catch 'gcry-error + (lambda () + (let ((params + (string->canonical-sexp + (or arg "(genkey (rsa (nbits 4:4096)))")))) + (alist-cons 'generate-key params result))) + (lambda args + (leave (_ "invalid key generation parameters: ~s~%") + arg))))) + (option '("authorize") #f #f + (lambda (opt name arg result) + (alist-cons 'authorize #t result))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\c "cores") #t #f + (lambda (opt name arg result) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("fallback") #f #f + (lambda (opt name arg result) + (alist-cons 'fallback? #t + (alist-delete 'fallback? result)))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) + (option '("max-silent-time") #t #f + (lambda (opt name arg result) + (alist-cons 'max-silent-time (string->number* arg) + result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))))) + +(define (options->derivations+files store opts) + "Given OPTS, the result of 'args-fold', return a list of derivations to +build and a list of store files to transfer." + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) + + (define src? (assoc-ref opts 'source?)) + (define sys (assoc-ref opts 'system)) + + (fold2 (lambda (arg derivations files) + (match arg + (('expression . str) + (let ((drv (derivation-from-expression store str + package->derivation + sys src?))) + (values (cons drv derivations) + (cons (derivation->output-path drv) files)))) + (('argument . (? store-path? file)) + (values derivations (cons file files))) + (('argument . (? string? spec)) + (let-values (((p output) + (specification->package+output spec))) + (if src? + (let* ((s (package-source p)) + (drv (package-source-derivation store s))) + (values (cons drv derivations) + (cons (derivation->output-path drv) + files))) + (let ((drv (package->derivation store p sys))) + (values (cons drv derivations) + (cons (derivation->output-path drv output) + files)))))) + (_ + (values derivations files)))) + '() + '() + opts)) + + +;;; +;;; Entry point. +;;; + +(define (export-from-store store opts) + "Export the packages or derivations specified in OPTS from STORE. Write the +resulting archive to the standard output port." + (let-values (((drv files) + (options->derivations+files store opts))) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) + + (set-build-options store + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:max-silent-time (assoc-ref opts 'max-silent-time)) + + (if (or (assoc-ref opts 'dry-run?) + (build-derivations store drv)) + (export-paths store files (current-output-port)) + (leave (_ "unable to export the given packages~%"))))) + +(define (generate-key-pair parameters) + "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the +right place." + (when (or (file-exists? %public-key-file) + (file-exists? %private-key-file)) + (leave (_ "key pair exists under '~a'; remove it first~%") + (dirname %public-key-file))) + + (format (current-error-port) + (_ "Please wait while gathering entropy to generate the key pair; +this may take time...~%")) + + (let* ((pair (catch 'gcry-error + (lambda () + (generate-key parameters)) + (lambda (key err) + (leave (_ "key generation failed: ~a: ~a~%") + (error-source err) + (error-string err))))) + (public (find-sexp-token pair 'public-key)) + (secret (find-sexp-token pair 'private-key))) + ;; Create the following files as #o400. + (umask #o266) + + (mkdir-p (dirname %public-key-file)) + (with-atomic-file-output %public-key-file + (lambda (port) + (display (canonical-sexp->string public) port))) + (with-atomic-file-output %private-key-file + (lambda (port) + (display (canonical-sexp->string secret) port))) + + ;; Make the public key readable by everyone. + (chmod %public-key-file #o444))) + +(define (authorize-key) + "Authorize imports signed by the public key passed as an advanced sexp on +the input port." + (define (read-key) + (catch 'gcry-error + (lambda () + (string->canonical-sexp (get-string-all (current-input-port)))) + (lambda (key err) + (leave (_ "failed to read public key: ~a: ~a~%") + (error-source err) (error-string err))))) + + (let ((key (read-key)) + (acl (current-acl))) + (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) + (leave (_ "s-expression does not denote a public key~%"))) + + ;; Add KEY to the ACL and write that. + (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) + (with-atomic-file-output %acl-file + (lambda (port) + (display (canonical-sexp->string acl) port)))))) + +(define (guix-archive . 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 (lines port) + ;; Return lines read from PORT. + (let loop ((line (read-line port)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line port) + (cons line result))))) + + (with-error-handling + ;; Ask for absolute file names so that .drv file names passed from the + ;; user to 'read-derivation' are absolute when it returns. + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (let ((opts (parse-options))) + (cond ((assoc-ref opts 'generate-key) + => + generate-key-pair) + ((assoc-ref opts 'authorize) + (authorize-key)) + (else + (let ((store (open-connection))) + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + (else + (leave + (_ "either '--export' or '--import' \ +must be specified~%"))))))))))) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm new file mode 100644 index 0000000000..c7a14f7a8b --- /dev/null +++ b/guix/scripts/authenticate.scm @@ -0,0 +1,101 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts authenticate) + #:use-module (guix config) + #:use-module (guix utils) + #:use-module (guix pk-crypto) + #:use-module (guix pki) + #:use-module (guix ui) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:export (guix-authenticate)) + +;;; Commentary: +;;; +;;; This program is used internally by the daemon to sign exported archive +;;; (the 'export-paths' RPC), and to authenticate imported archives (the +;;; 'import-paths' RPC.) +;;; +;;; Code: + +(define (read-canonical-sexp file) + "Read a gcrypt sexp from FILE and return it." + (call-with-input-file file + (compose string->canonical-sexp get-string-all))) + +(define (read-hash-data file) + "Read sha256 hash data from FILE and return it as a gcrypt sexp." + (let* ((hex (call-with-input-file file get-string-all)) + (bv (base16-string->bytevector (string-trim-both hex)))) + (bytevector->hash-data bv))) + + +;;; +;;; Entry point with 'openssl'-compatible interface. We support this +;;; interface because that's what the daemon expects, and we want to leave it +;;; unmodified currently. +;;; + +(define (guix-authenticate . args) + (match args + (("rsautl" "-sign" "-inkey" key "-in" hash-file) + ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes + ;; both the hash and the actual signature. + (let* ((secret-key (read-canonical-sexp key)) + (public-key (if (string-suffix? ".sec" key) + (read-canonical-sexp + (string-append (string-drop-right key 4) ".pub")) + (leave + (_ "cannot find public key for secret key '~a'~%") + key))) + (data (read-hash-data hash-file)) + (signature (signature-sexp data secret-key public-key))) + (display (canonical-sexp->string signature)) + #t)) + (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) + ;; Read the signature as produced above, check whether its public key is + ;; authorized, and verify the signature, and print the signed data to + ;; stdout upon success. + (let* ((sig+data (read-canonical-sexp signature-file)) + (public-key (find-sexp-token sig+data 'public-key)) + (data (find-sexp-token sig+data 'data)) + (signature (find-sexp-token sig+data 'sig-val))) + (if (and data signature) + (if (authorized-key? public-key) + (if (verify signature data public-key) + (begin + (display (bytevector->base16-string + (hash-data->bytevector data))) + #t) ; success + (leave (_ "error: invalid signature: ~a~%") + (canonical-sexp->string signature))) + (leave (_ "error: unauthorized public key: ~a~%") + (canonical-sexp->string public-key))) + (leave (_ "error: corrupt signature data: ~a~%") + (canonical-sexp->string sig+data))))) + (("--help") + (display (_ "Usage: guix authenticate OPTION... +Sign or verify the signature on the given file. This tool is meant to +be used internally by 'guix-daemon'.\n"))) + (("--version") + (show-version-and-exit "guix authenticate")) + (else + (leave (_ "wrong arguments"))))) + +;;; authenticate.scm ends here diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index dd9a9b8127..7cb3710853 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -32,14 +32,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)) + #:autoload (gnu packages) (find-best-packages-by-name) + #:export (derivation-from-expression + guix-build)) -(define %store - (make-parameter #f)) - -(define (derivation-from-expression str package-derivation +(define (derivation-from-expression store str package-derivation system source?) "Read/eval STR and return the corresponding derivation path for SYSTEM. When SOURCE? is true and STR evaluates to a package, return the derivation of @@ -50,12 +47,57 @@ derivation of a package." (if source? (let ((source (package-source p))) (if source - (package-source-derivation (%store) source) + (package-source-derivation store source) (leave (_ "package `~a' has no source~%") (package-name p)))) - (package-derivation (%store) p system))) + (package-derivation store p system))) ((? procedure? proc) - (run-with-store (%store) (proc) #:system system)))) + (run-with-store store (proc) #:system system)))) + +(define (specification->package spec) + "Return a package matching SPEC. SPEC 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 spec))) + (match (find-best-packages-by-name name version) + ((p) ; one match + p) + ((p x ...) ; several matches + (warning (_ "ambiguous package specification `~a'~%") spec) + (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)))))) + +(define (register-root store 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 + (leave (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))))))) ;;; @@ -66,6 +108,7 @@ derivation of a package." ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -91,6 +134,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " --no-substitutes build instead of resorting to pre-built substitutes")) (display (_ " + --no-build-hook do not attempt to offload builds via the build hook")) + (display (_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) (display (_ " @@ -157,6 +202,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (alist-cons 'substitutes? #f (alist-delete 'substitutes? result)))) + (option '("no-build-hook") #f #f + (lambda (opt name arg result) + (alist-cons 'build-hook? #f + (alist-delete 'build-hook? result)))) (option '("max-silent-time") #t #f (lambda (opt name arg result) (alist-cons 'max-silent-time (string->number* arg) @@ -173,6 +222,36 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (alist-cons 'log-file? #t result))))) +(define (options->derivations store opts) + "Given OPTS, the result of 'args-fold', return a list of derivations to +build." + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) + + (define src? (assoc-ref opts 'source?)) + (define sys (assoc-ref opts 'system)) + + (filter-map (match-lambda + (('expression . str) + (derivation-from-expression store str package->derivation + sys src?)) + (('argument . (? derivation-path? drv)) + (call-with-input-file drv read-derivation)) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (('argument . (? string? x)) + (let ((p (specification->package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation store s)) + (package->derivation store p sys)))) + (_ #f)) + opts)) + ;;; ;;; Entry point. @@ -188,146 +267,66 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (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 - (leave (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))))))) - - (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 - (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 - (leave (_ "~A: package not found for version ~a~%") - name version) - (leave (_ "~A: unknown package~%") name)))))) - (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let ((opts (parse-options))) - (define package->derivation - (match (assoc-ref opts 'target) - (#f package-derivation) - (triplet - (cut package-cross-derivation <> <> triplet <>)))) - - (parameterize ((%store (open-connection))) - (let* ((src? (assoc-ref opts 'source?)) - (sys (assoc-ref opts 'system)) - (drv (filter-map (match-lambda - (('expression . str) - (derivation-from-expression - str package->derivation sys src?)) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (('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)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) + (let* ((opts (parse-options)) + (store (open-connection)) + (drv (options->derivations store opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) - (unless (assoc-ref opts 'log-file?) - (show-what-to-build (%store) drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?))) + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?))) - ;; TODO: Add more options. - (set-build-options (%store) - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:max-silent-time (assoc-ref opts 'max-silent-time) - #:verbosity (assoc-ref opts 'verbosity)) + ;; TODO: Add more options. + (set-build-options store + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:use-build-hook? (assoc-ref opts 'build-hook?) + #:max-silent-time (assoc-ref opts 'max-silent-time) + #:verbosity (assoc-ref opts 'verbosity)) - (cond ((assoc-ref opts 'log-file?) - (for-each (lambda (file) - (let ((log (log-file (%store) file))) - (if log - (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") - file)))) - (delete-duplicates - (append (map derivation-file-name drv) - (filter-map (match-lambda - (('argument - . (? store-path? file)) - file) - (_ #f)) - opts))))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path - d out-name))) - (derivation-outputs d)))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (cond ((assoc-ref opts 'log-file?) + (for-each (lambda (file) + (let ((log (log-file store file))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") + file)))) + (delete-duplicates + (append (map derivation-file-name drv) + (filter-map (match-lambda + (('argument + . (? store-path? file)) + file) + (_ #f)) + opts))))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv) + (for-each (lambda (d) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) + drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 49fa457a9c..04393abc9a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; @@ -41,7 +41,8 @@ #:use-module ((gnu packages base) #:select (guile-final)) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module (guix gnu-maintenance) - #:export (guix-package)) + #:export (specification->package+output + guix-package)) (define %store (make-parameter #f)) @@ -56,7 +57,7 @@ (cut string-append <> "/.guix-profile"))) (define %profile-directory - (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" + (string-append %state-directory "/profiles/" (or (and=> (getenv "USER") (cut string-append "per-user/" <>)) "default"))) @@ -292,21 +293,24 @@ return its return value." (format (current-error-port) " interrupted by signal ~a~%" SIGINT) #f)))) -(define newest-available-packages - (memoize find-newest-available-packages)) - -(define (find-best-packages-by-name name version) - "If version is #f, return the list of packages named NAME with the highest -version numbers; otherwise, return the list of packages named NAME and at -VERSION." - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#f '())))) +(define-syntax-rule (leave-on-EPIPE exp ...) + "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' +with successful exit code. This is useful when writing to the standard output +may lead to EPIPE, because the standard output is piped through 'head' or +similar." + (catch 'system-error + (lambda () + exp ...) + (lambda args + ;; We really have to exit this brutally, otherwise Guile eventually + ;; attempts to flush all the ports, leading to an uncaught EPIPE down + ;; the path. + (if (= EPIPE (system-error-errno args)) + (primitive-_exit 0) + (apply throw args))))) (define* (specification->package+output spec #:optional (output "out")) - "Find the package and output specified by SPEC, or #f and #f; SPEC may + "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: guile @@ -342,7 +346,7 @@ version; if SPEC does not specify an output, return OUTPUT." "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)) + (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) (case (version-compare candidate-version current-version) ((>) #t) @@ -970,15 +974,17 @@ more information.~%")) profile)) ((string-null? pattern) (let ((numbers (generation-numbers profile))) - (if (equal? numbers '(0)) - (exit 0) - (for-each list-generation numbers)))) + (leave-on-EPIPE + (if (equal? numbers '(0)) + (exit 0) + (for-each list-generation numbers))))) ((matching-generations pattern profile) => (lambda (numbers) (if (null-list? numbers) (exit 1) - (for-each list-generation numbers)))) + (leave-on-EPIPE + (for-each list-generation numbers))))) (else (leave (_ "invalid syntax: ~a~%") pattern))) @@ -988,15 +994,16 @@ more information.~%")) (let* ((regexp (and regexp (make-regexp regexp))) (manifest (profile-manifest profile)) (installed (manifest-entries manifest))) - (for-each (match-lambda - (($ <manifest-entry> 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)))) + (leave-on-EPIPE + (for-each (match-lambda + (($ <manifest-entry> 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)))) - ;; Show most recently installed packages last. - (reverse installed)) + ;; Show most recently installed packages last. + (reverse installed))) #t)) (('list-available regexp) @@ -1010,16 +1017,17 @@ more information.~%")) 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) - (string<? (package-name p1) - (package-name p2))))) + (leave-on-EPIPE + (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) + (string<? (package-name p1) + (package-name p2)))))) #t)) (('search regexp) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 0da29d435b..901b3fb064 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -72,21 +72,6 @@ ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) -(define (with-atomic-file-output file proc) - "Call PROC with an output port for the file that is going to replace FILE. -Upon success, FILE is atomically replaced by what has been written to the -output port, and PROC's result is returned." - (let* ((template (string-append file ".XXXXXX")) - (out (mkstemp! template))) - (with-throw-handler #t - (lambda () - (let ((result (proc out))) - (close out) - (rename-file template file) - result)) - (lambda (key . args) - (false-if-exception (delete-file template)))))) - ;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it. ;; See <http://bugs.gnu.org/14404>. (set! regexp-exec @@ -594,7 +579,6 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; Local Variables: -;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: |