diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-05-23 14:55:44 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-05-23 15:02:26 +0200 |
commit | bc73a84398fa54b0a11a80c749bf78eb0a58dbe6 (patch) | |
tree | 3e7b6670989ceb4f31464bad632c0332121d96a0 /guix | |
parent | 12b6f6527e49c8c4191929a72b1692dbd9eb2440 (diff) | |
parent | 624d4e2e6ba402c374a340869306eec65a808a20 (diff) | |
download | gnu-guix-bc73a84398fa54b0a11a80c749bf78eb0a58dbe6.tar gnu-guix-bc73a84398fa54b0a11a80c749bf78eb0a58dbe6.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/ant-build-system.scm | 12 | ||||
-rw-r--r-- | guix/build/download.scm | 105 | ||||
-rw-r--r-- | guix/build/graft.scm | 28 | ||||
-rw-r--r-- | guix/derivations.scm | 133 | ||||
-rw-r--r-- | guix/download.scm | 45 | ||||
-rw-r--r-- | guix/graph.scm | 2 | ||||
-rw-r--r-- | guix/import/cran.scm | 8 | ||||
-rw-r--r-- | guix/import/gnu.scm | 48 | ||||
-rw-r--r-- | guix/scripts/build.scm | 13 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 82 | ||||
-rw-r--r-- | guix/scripts/import.scm | 11 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 21 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 12 | ||||
-rw-r--r-- | guix/store.scm | 2 | ||||
-rw-r--r-- | guix/upstream.scm | 5 |
15 files changed, 376 insertions, 151 deletions
diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 27277af34b..6dc19ff2db 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -86,6 +86,17 @@ INPUTS." (find-files dir "\\.*jar$"))) inputs)) ":")) +(define* (unpack #:key source #:allow-other-keys) + "Unpack the jar archive SOURCE. When SOURCE is not a jar archive fall back +to the default GNU unpack strategy." + (if (string-suffix? ".jar" source) + (begin + (mkdir "src") + (with-directory-excursion "src" + (zero? (system* "jar" "-xf" source)))) + ;; Use GNU unpack strategy for things that aren't jar archives. + ((assq-ref gnu:%standard-phases 'unpack) #:source source))) + (define* (configure #:key inputs outputs (jar-name #f) #:allow-other-keys) (when jar-name @@ -151,6 +162,7 @@ repack them. This is necessary to ensure that archives are reproducible." (define %standard-phases (modify-phases gnu:%standard-phases + (replace 'unpack unpack) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/download.scm b/guix/build/download.scm index fec4cec3e8..7741726c41 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -426,6 +426,85 @@ port if PORT is a TLS session record port." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) + +;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit +;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation +;; procedure rejects dates in which the hour is not padded with a zero but +;; with whitespace. +(begin + (define-syntax string-match? + (lambda (x) + (syntax-case x () + ((_ str pat) (string? (syntax->datum #'pat)) + (let ((p (syntax->datum #'pat))) + #`(let ((s str)) + (and + (= (string-length s) #,(string-length p)) + #,@(let lp ((i 0) (tests '())) + (if (< i (string-length p)) + (let ((c (string-ref p i))) + (lp (1+ i) + (case c + ((#\.) ; Whatever. + tests) + ((#\d) ; Digit. + (cons #`(char-numeric? (string-ref s #,i)) + tests)) + ((#\a) ; Alphabetic. + (cons #`(char-alphabetic? (string-ref s #,i)) + tests)) + (else ; Literal. + (cons #`(eqv? (string-ref s #,i) #,c) + tests))))) + tests))))))))) + + (define (parse-rfc-822-date str space zone-offset) + (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer)) + (parse-month (@@ (web http) parse-month)) + (bad-header (@@ (web http) bad-header))) + ;; We could verify the day of the week but we don't. + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 17 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 16 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + ;; The next two clauses match dates that have a space instead of + ;; a leading zero for hours, like " 8:49:37". + ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 18 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 17 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + (else + (bad-header 'date str) ; prevent tail call + #f)))) + (module-set! (resolve-module '(web http)) + 'parse-rfc-822-date parse-rfc-822-date)) + ;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile ;; up to 2.0.11. (unless (or (> (string->number (major-version)) 2) @@ -605,10 +684,22 @@ Return a list of URIs." (else (list uri)))) -(define* (url-fetch url file #:key (mirrors '())) +(define* (url-fetch url file + #:key + (mirrors '()) (content-addressed-mirrors '()) + (hashes '())) "Fetch FILE from URL; URL may be either a single string, or a list of string denoting alternate URLs for FILE. Return #f on failure, and FILE -on success." +on success. + +When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve +'mirror://' URIs. + +HASHES must be a list of algorithm/hash pairs, where each algorithm is a +symbol such as 'sha256 and each hash is a bytevector. +CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash +algorithm and a hash, return a URL where the specified data can be retrieved +or #f." (define uri (append-map (cut maybe-expand-mirrors <> mirrors) (match url @@ -628,13 +719,21 @@ on success." uri) #f))) + (define content-addressed-urls + (append-map (lambda (make-url) + (filter-map (match-lambda + ((hash-algo . hash) + (make-url hash-algo hash))) + hashes)) + content-addressed-mirrors)) + ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means ;; '\n', not '\r', so it's not appropriate here. (setvbuf (current-output-port) _IONBF) (setvbuf (current-error-port) _IOLBF) - (let try ((uri uri)) + (let try ((uri (append uri content-addressed-urls))) (match uri ((uri tail ...) (or (fetch uri file) diff --git a/guix/build/graft.scm b/guix/build/graft.scm index b216e6c0d7..b61982dd64 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -83,6 +83,28 @@ writing the result to OUTPUT." (put-u8 output (char->integer char)) result))))) +(define (rename-matching-files directory mapping) + "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is +a list of store file name pairs." + (let* ((mapping (map (match-lambda + ((source . target) + (cons (basename source) (basename target)))) + mapping)) + (matches (find-files directory + (lambda (file stat) + (assoc-ref mapping (basename file))) + #:directories? #t))) + + ;; XXX: This is not quite correct: if MAPPING contains "foo", and + ;; DIRECTORY contains "bar/foo/foo", we first rename "bar/foo" and then + ;; "bar/foo/foo" no longer exists so we fail. Oh well, surely that's good + ;; enough! + (for-each (lambda (file) + (let ((target (assoc-ref mapping (basename file)))) + (rename-file file + (string-append (dirname file) "/" target)))) + matches))) + (define* (rewrite-directory directory output mapping #:optional (store (%store-directory))) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of @@ -115,6 +137,8 @@ file name pairs." (replace-store-references input output mapping store) (chmod output (stat:perms stat)))))))) + ((directory) + (mkdir-p dest)) (else (error "unsupported file type" stat))))) @@ -124,6 +148,8 @@ file name pairs." (umask #o022) (n-par-for-each (parallel-job-count) - rewrite-leaf (find-files directory))) + rewrite-leaf (find-files directory (const #t) + #:directories? #t)) + (rename-matching-files output mapping)) ;;; graft.scm ends here diff --git a/guix/derivations.scm b/guix/derivations.scm index d4f697477b..76593f373b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -176,6 +176,11 @@ download with a fixed hash (aka. `fetchurl')." #t) (_ #f))) +(define (derivation-input<? input1 input2) + "Compare INPUT1 and INPUT2, two <derivation-input>." + (string<? (derivation-input-path input1) + (derivation-input-path input2))) + (define (derivation-input-output-paths input) "Return the list of output paths corresponding to INPUT, a <derivation-input>." @@ -190,6 +195,30 @@ the store." (every (cut valid-path? store <>) (derivation-input-output-paths input))) +(define (coalesce-duplicate-inputs inputs) + "Return a list of inputs, such that when INPUTS contains the same DRV twice, +they are coalesced, with their sub-derivations merged. This is needed because +Nix itself keeps only one of them." + (fold (lambda (input result) + (match input + (($ <derivation-input> path sub-drvs) + ;; XXX: quadratic + (match (find (match-lambda + (($ <derivation-input> p s) + (string=? p path))) + result) + (#f + (cons input result)) + ((and dup ($ <derivation-input> _ sub-drvs2)) + ;; Merge DUP with INPUT. + (let ((sub-drvs (delete-duplicates + (append sub-drvs sub-drvs2)))) + (cons (make-derivation-input path + (sort sub-drvs string<?)) + (delq dup result)))))))) + '() + inputs)) + (define* (derivation-prerequisites drv #:optional (cut? (const #f))) "Return the list of derivation-inputs required to build DRV, recursively. @@ -473,29 +502,6 @@ that form." (define (write-string-list lst) (write-list lst write port)) - (define (coalesce-duplicate-inputs inputs) - ;; Return a list of inputs, such that when INPUTS contains the same DRV - ;; twice, they are coalesced, with their sub-derivations merged. This is - ;; needed because Nix itself keeps only one of them. - (fold (lambda (input result) - (match input - (($ <derivation-input> path sub-drvs) - ;; XXX: quadratic - (match (find (match-lambda - (($ <derivation-input> p s) - (string=? p path))) - result) - (#f - (cons input result)) - ((and dup ($ <derivation-input> _ sub-drvs2)) - ;; Merge DUP with INPUT. - (let ((sub-drvs (delete-duplicates - (append sub-drvs sub-drvs2)))) - (cons (make-derivation-input path sub-drvs) - (delq dup result)))))))) - '() - inputs)) - (define (write-output output port) (match output ((name . ($ <derivation-output> path hash-algo hash recursive?)) @@ -515,7 +521,7 @@ that form." (display "(" port) (write path port) (display "," port) - (write-string-list (sort sub-drvs string<?)) + (write-string-list sub-drvs) (display ")" port)))) (define (write-env-var env-var port) @@ -527,35 +533,20 @@ that form." (write value port) (display ")" port)))) - ;; Note: lists are sorted alphabetically, to conform with the behavior of - ;; C++ `std::map' in Nix itself. - + ;; Assume all the lists we are writing are already sorted. (match drv (($ <derivation> outputs inputs sources system builder args env-vars) (display "Derive(" port) - (write-list (sort outputs - (lambda (o1 o2) - (string<? (car o1) (car o2)))) - write-output - port) + (write-list outputs write-output port) (display "," port) - (write-list (sort (coalesce-duplicate-inputs inputs) - (lambda (i1 i2) - (string<? (derivation-input-path i1) - (derivation-input-path i2)))) - write-input - port) + (write-list inputs write-input port) (display "," port) - (write-string-list (sort sources string<?)) + (write-string-list sources) (format port ",~s,~s," system builder) (write-string-list args) (display "," port) - (write-list (sort env-vars - (lambda (e1 e2) - (string<? (car e1) (car e2)))) - write-env-var - port) + (write-list env-vars write-env-var port) (display ")" port)))) (define derivation->string @@ -653,7 +644,10 @@ derivation at FILE." (let ((hash (derivation-path->base16-hash path))) (make-derivation-input hash sub-drvs)))) inputs)) - (drv (make-derivation outputs inputs sources + (drv (make-derivation outputs + (sort (coalesce-duplicate-inputs inputs) + derivation-input<?) + sources system builder args env-vars #f))) @@ -820,30 +814,38 @@ output should not be used." (make-derivation outputs inputs sources system builder args env-vars file)))) + (define input->derivation-input + (match-lambda + (((? derivation? drv)) + (make-derivation-input (derivation-file-name drv) '("out"))) + (((? derivation? drv) sub-drvs ...) + (make-derivation-input (derivation-file-name drv) sub-drvs)) + (((? direct-store-path? input)) + (make-derivation-input input '("out"))) + (((? direct-store-path? input) sub-drvs ...) + (make-derivation-input input sub-drvs)) + ((input . _) + (let ((path (add-to-store store (basename input) + #t "sha256" input))) + (make-derivation-input path '()))))) + + ;; Note: lists are sorted alphabetically, to conform with the behavior of + ;; C++ `std::map' in Nix itself. + (let* ((outputs (map (lambda (name) ;; Return outputs with an empty path. (cons name (make-derivation-output "" hash-algo hash recursive?))) - outputs)) - (inputs (map (match-lambda - (((? derivation? drv)) - (make-derivation-input (derivation-file-name drv) - '("out"))) - (((? derivation? drv) sub-drvs ...) - (make-derivation-input (derivation-file-name drv) - sub-drvs)) - (((? direct-store-path? input)) - (make-derivation-input input '("out"))) - (((? direct-store-path? input) sub-drvs ...) - (make-derivation-input input sub-drvs)) - ((input . _) - (let ((path (add-to-store store - (basename input) - #t "sha256" input))) - (make-derivation-input path '())))) - (delete-duplicates inputs))) - (env-vars (env-vars-with-empty-outputs (user+system-env-vars))) + (sort outputs string<?))) + (inputs (sort (coalesce-duplicate-inputs + (map input->derivation-input + (delete-duplicates inputs))) + derivation-input<?)) + (env-vars (sort (env-vars-with-empty-outputs + (user+system-env-vars)) + (lambda (e1 e2) + (string<? (car e1) (car e2))))) (drv-masked (make-derivation outputs (filter (compose derivation-path? derivation-input-path) @@ -858,8 +860,7 @@ output should not be used." (let ((file (add-text-to-store store (string-append name ".drv") (derivation->string drv) - (map derivation-input-path - inputs)))) + (map derivation-input-path inputs)))) (set-file-name drv file)))) (define* (map-derivation store drv mapping diff --git a/guix/download.scm b/guix/download.scm index 88f285dc0a..67c55aff33 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -202,7 +202,8 @@ (debian "http://ftp.de.debian.org/debian/" "http://ftp.fr.debian.org/debian/" - "http://ftp.debian.org/debian/")))) + "http://ftp.debian.org/debian/" + "http://archive.debian.org/debian/")))) (define %mirror-file ;; Copy of the list of mirrors to a file. This allows us to keep a single @@ -210,6 +211,22 @@ ;; 'object->string'. (plain-file "mirrors" (object->string %mirrors))) +(define %content-addressed-mirrors + ;; List of content-addressed mirrors. Each mirror is represented as a + ;; procedure that takes an algorithm (symbol) and a hash (bytevector), and + ;; returns a URL or #f. + ;; TODO: Add more. + '(list (lambda (algo hash) + ;; 'tarballs.nixos.org' supports several algorithms. + (string-append "http://tarballs.nixos.org/" + (symbol->string algo) "/" + (bytevector->nix-base32-string hash))))) + +(define %content-addressed-mirror-file + ;; Content-addressed mirrors stored in a file. + (plain-file "content-addressed-mirrors" + (object->string %content-addressed-mirrors))) + (define (gnutls-package) "Return the default GnuTLS package." (let ((module (resolve-interface '(gnu packages tls)))) @@ -258,12 +275,21 @@ in the store." %load-path))) #~#t) - (use-modules (guix build download)) + (use-modules (guix build download) + (guix base32)) + + (let ((value-from-environment (lambda (variable) + (call-with-input-string + (getenv variable) + read)))) + (url-fetch (value-from-environment "guix download url") + #$output + #:mirrors (call-with-input-file #$%mirror-file read) - (url-fetch (call-with-input-string (getenv "guix download url") - read) - #$output - #:mirrors (call-with-input-file #$%mirror-file read)))) + ;; Content-addressed mirrors. + #:hashes (value-from-environment "guix download hashes") + #:content-addressed-mirrors + (primitive-load #$%content-addressed-mirror-file))))) (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) @@ -278,14 +304,17 @@ in the store." #:hash hash #:modules '((guix build download) (guix build utils) - (guix ftp-client)) + (guix ftp-client) + (guix base32)) ;; Use environment variables and a fixed script ;; name so there's only one script in store for ;; all the downloads. #:script-name "download" #:env-vars - `(("guix download url" . ,(object->string url))) + `(("guix download url" . ,(object->string url)) + ("guix download hashes" + . ,(object->string `((,hash-algo . ,hash))))) ;; Honor the user's proxy settings. #:leaked-env-vars '("http_proxy" "https_proxy") diff --git a/guix/graph.scm b/guix/graph.scm index 1a8f2d55b3..ad93403a1e 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -65,7 +65,7 @@ (identifier node-type-identifier) ;node -> M identifier (label node-type-label) ;node -> string (edges node-type-edges) ;node -> M list of nodes - (convert node-type-convert ;package -> M list of nodes + (convert node-type-convert ;any -> M list of nodes (default (lift1 list %store-monad))) (name node-type-name) ;string (description node-type-description)) ;string diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 69485bc88d..f9369414cd 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -111,11 +111,11 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "http://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.2. Bioconductor packages should be +;; The latest Bioconductor release is 3.3. Bioconductor packages should be ;; updated together. (define %bioconductor-svn-url (string-append "https://readonly:readonly@" - "hedgehog.fhcrc.org/bioconductor/branches/RELEASE_3_2/" + "hedgehog.fhcrc.org/bioconductor/branches/RELEASE_3_3/" "madman/Rpacks/")) @@ -267,7 +267,7 @@ s-expression corresponding to that package, or #f on failure." (upstream-source (package (package-name package)) (version version) - (urls (bioconductor-uri upstream-name version)))))) + (urls (list (bioconductor-uri upstream-name version))))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 834f0ae5cf..2cfb46beb9 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,8 +55,8 @@ (define* (gnu-package->sexp package release #:key (key-download 'interactive)) "Return the 'package' sexp for the RELEASE (a <gnu-release>) of PACKAGE (a -<gnu-package>). Use KEY-DOWNLOAD as the OpenPGP key download policy (see -'download-tarball' for details.)" +<gnu-package>), or #f upon failure. Use KEY-DOWNLOAD as the OpenPGP key +download policy (see 'download-tarball' for details.)" (define name (gnu-package-name package)) @@ -79,25 +79,29 @@ (find (cute string-suffix? (string-append archive-type ".sig") <>) (upstream-source-signature-urls release))) - (let ((tarball (with-store store - (download-tarball store url sig-url - #:key-download key-download)))) - `(package - (name ,name) - (version ,(upstream-source-version release)) - (source (origin - (method url-fetch) - (uri (string-append ,url-base version - ,(string-append ".tar." archive-type))) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - (build-system gnu-build-system) - (synopsis ,(gnu-package-doc-summary package)) - (description ,(gnu-package-doc-description package)) - (home-page ,(match (gnu-package-doc-urls package) - ((head . tail) (qualified-url head)))) - (license find-by-yourself!)))) + (with-store store + (match (download-tarball store url sig-url + #:key-download key-download) + ((? string? tarball) + `(package + (name ,name) + (version ,(upstream-source-version release)) + (source (origin + (method url-fetch) + (uri (string-append ,url-base version + ,(string-append ".tar." archive-type))) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (file-sha256 tarball)))))) + (build-system gnu-build-system) + (synopsis ,(gnu-package-doc-summary package)) + (description ,(gnu-package-doc-description package)) + (home-page ,(match (gnu-package-doc-urls package) + ((head . tail) (qualified-url head)))) + (license find-by-yourself!))) + (#f ;failure to download or authenticate the tarball + #f)))) (define* (gnu->guix-package name #:key (key-download 'interactive)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 320ec39be2..a02a0d5792 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -65,9 +65,13 @@ found. Return #f if no build log was found." (define (valid-url? url) ;; Probe URL and return #t if it is accessible. - (guard (c ((http-get-error? c) #f)) - (close-port (http-fetch url #:buffered? #f)) - #t)) + (catch 'getaddrinfo-error + (lambda () + (guard (c ((http-get-error? c) #f)) + (close-port (http-fetch url #:buffered? #f)) + #t)) + (lambda _ + #f))) (define (find-url file) (let ((base (basename file))) @@ -681,7 +685,8 @@ needed." (_ #f)) opts))) - (unless (assoc-ref opts 'log-file?) + (unless (or (assoc-ref opts 'log-file?) + (assoc-ref opts 'derivations-only?)) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index ba63780e2b..782fca5d63 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -33,6 +33,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type @@ -70,11 +71,27 @@ name." ;; Filter out origins and other non-package dependencies. (filter package? packages)))) +(define assert-package + (match-lambda + ((? package? package) + package) + (x + (raise + (condition + (&message + (message (format #f (_ "~a: invalid argument (package name expected)") + x)))))))) + +(define nodes-from-package + ;; The default conversion method. + (lift1 (compose list assert-package) %store-monad)) + (define %package-node-type ;; Type for the traversal of package nodes. (node-type (name "package") (description "the DAG of packages, excluding implicit inputs") + (convert nodes-from-package) ;; We use package addresses as unique identifiers. This generally works ;; well, but for generated package objects, we could end up with two @@ -131,6 +148,7 @@ Dependencies may include packages, origin, and file names." (node-type (name "bag") (description "the DAG of packages, including implicit inputs") + (convert nodes-from-package) (identifier bag-node-identifier) (label node-full-name) (edges (lift1 (compose (cut filter package? <>) bag-node-edges) @@ -140,6 +158,7 @@ Dependencies may include packages, origin, and file names." (node-type (name "bag-with-origins") (description "the DAG of packages and origins, including implicit inputs") + (convert nodes-from-package) (identifier bag-node-identifier) (label node-full-name) (edges (lift1 (lambda (thing) @@ -170,6 +189,7 @@ GNU-BUILD-SYSTEM have zero dependencies." (node-type (name "bag-emerged") (description "same as 'bag', but without the bootstrap nodes") + (convert nodes-from-package) (identifier bag-node-identifier) (label node-full-name) (edges (lift1 (compose (cut filter package? <>) @@ -215,10 +235,19 @@ a plain store file." (node-type (name "derivation") (description "the DAG of derivations") - (convert (lambda (package) - (with-monad %store-monad - (>>= (package->derivation package) - (lift1 list %store-monad))))) + (convert (match-lambda + ((? package? package) + (with-monad %store-monad + (>>= (package->derivation package) + (lift1 list %store-monad)))) + ((? derivation-path? item) + (mbegin %store-monad + ((store-lift add-temp-root) item) + (return (list (file->derivation item))))) + (x + (raise + (condition (&message (message "unsupported argument for \ +derivation graph"))))))) (identifier (lift1 derivation-node-identifier %store-monad)) (label derivation-node-label) (edges (lift1 derivation-dependencies %store-monad)))) @@ -246,12 +275,20 @@ substitutes." (node-type (name "references") (description "the DAG of run-time dependencies (store references)") - (convert (lambda (package) - ;; Return the output file names of PACKAGE. - (mlet %store-monad ((drv (package->derivation package))) - (return (match (derivation->output-paths drv) - (((_ . file-names) ...) - file-names)))))) + (convert (match-lambda + ((? package? package) + ;; Return the output file names of PACKAGE. + (mlet %store-monad ((drv (package->derivation package))) + (return (match (derivation->output-paths drv) + (((_ . file-names) ...) + file-names))))) + ((? store-path? item) + (with-monad %store-monad + (return (list item)))) + (x + (raise + (condition (&message (message "unsupported argument for \ +reference graph"))))))) (identifier (lift1 identity %store-monad)) (label store-path-package-name) (edges references*))) @@ -348,7 +385,9 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (alist-cons 'argument arg result)) %default-options)) (type (assoc-ref opts 'node-type)) - (packages (filter-map (match-lambda + (items (filter-map (match-lambda + (('argument . (? store-path? item)) + item) (('argument . spec) (specification->package spec)) (('expression . exp) @@ -356,15 +395,18 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (_ #f)) opts))) (with-store store - (run-with-store store - ;; XXX: Since grafting can trigger unsolicited builds, disable it. - (mlet %store-monad ((_ (set-grafting #f)) - (nodes (mapm %store-monad - (node-type-convert type) - packages))) - (export-graph (concatenate nodes) - (current-output-port) - #:node-type type)))))) + ;; 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)) + (run-with-store store + ;; XXX: Since grafting can trigger unsolicited builds, disable it. + (mlet %store-monad ((_ (set-grafting #f)) + (nodes (mapm %store-monad + (node-type-convert type) + items))) + (export-graph (concatenate nodes) + (current-output-port) + #:node-type type))))))) #t) ;;; graph.scm ends here diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 7b29794e8f..e54744feca 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -107,7 +107,10 @@ Run IMPORTER with ARGS.\n")) (show-version-and-exit "guix import")) ((importer args ...) (if (member importer importers) - (let ((expr (apply (resolve-importer importer) args))) - (pretty-print expr (newline-rewriting-port (current-output-port)))) - (format (current-error-port) - (_ "guix import: invalid importer~%")))))) + (match (apply (resolve-importer importer) args) + ((and expr ('package _ ...)) + (pretty-print expr (newline-rewriting-port + (current-output-port)))) + (x + (leave (_ "'~a' import failed~%") importer))) + (leave (_ "~a: invalid importer~%") importer))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 06001d3eae..b4fdb6f905 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -600,15 +600,6 @@ be determined." ((? origin?) (and=> (origin-actual-file-name patch) basename)))) -(define (package-name->cpe-name name) - "Do a basic conversion of NAME, a Guix package name, to the corresponding -Common Platform Enumeration (CPE) name." - (match name - ("icecat" "firefox") ;or "firefox_esr" - ("grub" "grub2") - ;; TODO: Add more. - (_ name))) - (define (current-vulnerabilities*) "Like 'current-vulnerabilities', but return the empty list upon networking or HTTP errors. This allows network-less operation and makes problems with @@ -635,9 +626,15 @@ from ~s: ~a (~s)~%") (current-vulnerabilities*))))) (lambda (package) "Return a list of vulnerabilities affecting PACKAGE." - ((force lookup) - (package-name->cpe-name (package-name package)) - (package-version package))))) + ;; First we retrieve the Common Platform Enumeration (CPE) name and + ;; version for PACKAGE, then we can pass them to LOOKUP. + (let ((name (or (assoc-ref (package-properties package) + 'cpe-name) + (package-name package))) + (version (or (assoc-ref (package-properties package) + 'cpe-version) + (package-version package)))) + ((force lookup) name version))))) (define (check-vulnerabilities package) "Check for known vulnerabilities for PACKAGE." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d46d610347..5cdc55f2b2 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -440,9 +440,15 @@ the cache STR originates form." (define (narinfo-cache-file cache-url path) "Return the name of the local file that contains an entry for PATH. The entry is stored in a sub-directory specific to CACHE-URL." - (string-append %narinfo-cache-directory "/" - (bytevector->base32-string (sha256 (string->utf8 cache-url))) - "/" (store-path-hash-part path))) + ;; The daemon does not sanitize its input, so PATH could be something like + ;; "/gnu/store/foo". Gracefully handle that. + (match (store-path-hash-part path) + (#f + (leave (_ "'~a' does not name a store item~%") path)) + ((? string? hash-part) + (string-append %narinfo-cache-directory "/" + (bytevector->base32-string (sha256 (string->utf8 cache-url))) + "/" hash-part)))) (define (cached-narinfo cache-url path) "Check locally if we have valid info about PATH coming from CACHE-URL. diff --git a/guix/store.scm b/guix/store.scm index f352a99cbd..4d89f4a413 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -615,7 +615,7 @@ store directory (/gnu/store)." boolean) (define-operation (query-path-hash (store-path path)) - "Return the SHA256 hash of PATH as a bytevector." + "Return the SHA256 hash of the nar serialization of PATH as a bytevector." base16) (define hash-part->path diff --git a/guix/upstream.scm b/guix/upstream.scm index 167c9ff89a..18157376d2 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -143,8 +143,9 @@ no update is needed or known." #:key (key-download 'interactive)) "Download the tarball at URL to the store; check its OpenPGP signature at SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball -file name. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; -allowed values: 'interactive' (default), 'always', and 'never'." +file name; return #f on failure (network failure or authentication failure). +KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed +values: 'interactive' (default), 'always', and 'never'." (let ((tarball (download-to-store store url))) (if (not signature-url) tarball |