From 6e94a574787895cd74edd4ecca3fa347ed457330 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 May 2016 16:47:12 +0200 Subject: guix build: Do not show what to build when '-d' is used. * guix/scripts/build.scm (guix-build): Don't call 'show-what-to-build' when OPTS contains 'derivations-only?'. --- guix/scripts/build.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 320ec39be2..c38ffe6e89 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -681,7 +681,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?) -- cgit v1.2.3 From c22a475725b99463de6e163a212c9398116c8aa0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 May 2016 16:56:21 +0200 Subject: guix build: Catch 'getaddrinfo-error' for '--log-file'. * guix/scripts/build.scm (log-url)[valid-url?]: Catch 'getaddrinfo-error'. --- guix/scripts/build.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index c38ffe6e89..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))) -- cgit v1.2.3 From cd436bf05a8344acf4462f3602e7d360821a902a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 May 2016 17:37:47 +0200 Subject: download: Support content-addressed mirrors. * guix/download.scm (%content-addressed-mirrors) (%content-addressed-mirror-file): New variables. * guix/download.scm (url-fetch)[builder]: Define 'value-from-environment. Pass #:hashes and #:content-addressed-mirrors to 'url-fetch'. Define "guix download hashes" environment variable. * guix/build/download.scm (url-fetch): Add #:content-addressed-mirrors and #:hashes. [content-addressed-urls]: New variable. Use it. --- guix/build/download.scm | 26 +++++++++++++++++++++++--- guix/download.scm | 42 +++++++++++++++++++++++++++++++++++------- 2 files changed, 58 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index fec4cec3e8..824e1c354a 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -605,10 +605,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 +640,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/download.scm b/guix/download.scm index 88f285dc0a..ff0bef3c1f 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -210,6 +210,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 +274,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 +303,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") -- cgit v1.2.3 From 6b287c5c35fc95f5bae7df8107ae6639d67344b8 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 16 May 2016 12:10:49 +0300 Subject: download: Update debian mirrors. * guix/download.scm (mirrors)[debian]: Add Debian's archive to the Debian mirror list. --- guix/download.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index ff0bef3c1f..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 -- cgit v1.2.3 From 8bfd602bb00ba7bed8f0108f4cea5ac92b772b7e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 29 Apr 2016 22:12:24 +0200 Subject: build: Accept dates with space-padded hour field. * guix/build/download.scm: Replace "parse-rfc-822-date" from the (web http) module. --- guix/build/download.scm | 79 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 79 insertions(+) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 824e1c354a..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 , 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 , present in Guile ;; up to 2.0.11. (unless (or (> (string->number (major-version)) 2) -- cgit v1.2.3 From 9583e07caea25ddec367e462151805ef8d86a445 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 6 May 2016 14:54:33 +0200 Subject: import cran: Use URL for Bioconductor 3.3. * guix/import/cran.scm (%bioconductor-svn-url): Update to release URL for version 3.3. --- guix/import/cran.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 69485bc88d..6f2ceedeba 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 +;;; Copyright © 2015, 2016 Ricardo Wurmus ;;; Copyright © 2015, 2016 Ludovic Courtès ;;; ;;; 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/")) -- cgit v1.2.3 From 9916ae15bb7622fb75f819d561cbc2c4257d0acd Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 10 May 2016 14:18:44 +0200 Subject: import cran: latest-bioconductor-release: Wrap Bioconductor URL in list. * guix/import/cran.scm (latest-bioconductor-release): Wrap Bioconductor URL in list in the "urls" field of the "upstream-source" value. --- guix/import/cran.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 6f2ceedeba..f9369414cd 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -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." -- cgit v1.2.3 From 787afdd0f1ce1d4aa7500d858f2635462b444699 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 17 May 2016 13:36:44 +0200 Subject: import: Exit with non-zero when an unknown importer is asked. * guix/scripts/import.scm (guix-import): Use 'leave' instead of 'format' when IMPORTER is unknown. --- guix/scripts/import.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 7b29794e8f..cf8fc073b2 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -109,5 +109,4 @@ Run IMPORTER with ARGS.\n")) (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~%")))))) + (leave (_ "~a: invalid importer~%") importer))))) -- cgit v1.2.3 From 149590380adb240e0993931b4f72e6f285b24483 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 17 May 2016 13:41:07 +0200 Subject: import: Gracefully report import failures. Previously, something like 'guix import gnu which' would spit out a backtrace if, say, the 'which' tarball could not be authenticated. * guix/upstream.scm (download-tarball): Mention failure modes in docstring. * guix/import/gnu.scm (gnu-package->sexp): Return #f when 'download-tarball' returns #f. * guix/scripts/import.scm (guix-import): Call 'leave' when IMPORTER does not return a (package ...) sexp. --- guix/import/gnu.scm | 48 ++++++++++++++++++++++++++---------------------- guix/scripts/import.scm | 8 ++++++-- guix/upstream.scm | 5 +++-- 3 files changed, 35 insertions(+), 26 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; ;;; 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 ) of PACKAGE (a -). Use KEY-DOWNLOAD as the OpenPGP key download policy (see -'download-tarball' for details.)" +), 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/import.scm b/guix/scripts/import.scm index cf8fc073b2..e54744feca 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -107,6 +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)))) + (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/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 -- cgit v1.2.3 From aa8fff0cebd8390c2faf733da79d9a1499458261 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 17 May 2016 13:50:10 +0200 Subject: store: Clarify 'query-path-hash' docstring. * guix/store.scm (query-path-hash): Clarify docstring. --- guix/store.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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 -- cgit v1.2.3 From 99effc8faa43d478371eb06aee5df8ae1383c51a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 17 May 2016 18:04:13 +0200 Subject: lint: Honor 'cpe-name' and 'cpe-version' package properties. * guix/scripts/lint.scm (package-name->cpe-name): Remove. (package-vulnerabilities): Honor 'cpe-name' and 'cpe-version' properties. * gnu/packages/grub.scm (grub)[properties]: New field. * gnu/packages/gnuzilla.scm (icecat)[properties]: Add 'cpe-name' and 'cpe-version'. * doc/guix.texi (Invoking guix lint): Mention 'cpe-name'. --- doc/guix.texi | 13 +++++++++++++ gnu/packages/gnuzilla.scm | 6 +++++- gnu/packages/grub.scm | 5 +++-- guix/scripts/lint.scm | 21 +++++++++------------ 4 files changed, 30 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 0e63ecadfd..3f0106be02 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4961,6 +4961,19 @@ To view information about a particular vulnerability, visit pages such as: where @code{CVE-YYYY-ABCD} is the CVE identifier---e.g., @code{CVE-2015-7554}. +Package developers can specify in package recipes the +@uref{https://nvd.nist.gov/cpe.cfm,Common Platform Enumeration (CPE)} +name and version of the package when they differ from the name that Guix +uses, as in this example: + +@example +(package + (name "grub") + ;; @dots{} + ;; CPE calls this package "grub2". + (properties '((cpe-name . "grub2")))) +@end example + @item formatting Warn about obvious source code formatting issues: trailing white space, use of tabulations, etc. diff --git a/gnu/packages/gnuzilla.scm b/gnu/packages/gnuzilla.scm index df1075c370..7e52534b8f 100644 --- a/gnu/packages/gnuzilla.scm +++ b/gnu/packages/gnuzilla.scm @@ -517,4 +517,8 @@ standards.") software, which does not recommend non-free plugins and addons. It also features built-in privacy-protecting features.") (license license:mpl2.0) ;and others, see toolkit/content/license.html - (properties '((ftp-directory . "/gnu/gnuzilla"))))) + (properties + `((ftp-directory . "/gnu/gnuzilla") + (cpe-name . "firefox_esr") + (cpe-version . ,(string-drop-right version + (string-length "-gnu1"))))))) diff --git a/gnu/packages/grub.scm b/gnu/packages/grub.scm index 5fc7ee8386..ec2feebbf4 100644 --- a/gnu/packages/grub.scm +++ b/gnu/packages/grub.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Leo Famulari ;;; @@ -132,4 +132,5 @@ then goes on to load the rest of the operating system. As a multiboot bootloader, GRUB handles the presence of multiple operating systems installed on the same computer; upon booting the computer, the user is presented with a menu to select one of the installed operating systems.") - (license gpl3+))) + (license gpl3+) + (properties '((cpe-name . "grub2"))))) 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." -- cgit v1.2.3 From 932f2b70a6a5eee15b1508d7aae7f8a7fdb0e23a Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 10 May 2016 15:50:28 +0200 Subject: ant-build-system: Add unpack phase. * guix/build/ant-build-system.scm (unpack): New procedure. (%standard-phases): Use it. --- guix/build/ant-build-system.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'guix') 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) -- cgit v1.2.3 From 3cabdead6fbe080d9466bb3130a2b36dd4b07090 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 May 2016 23:24:50 +0200 Subject: graph: Use absolute file name canonicalization. * guix/scripts/graph.scm (guix-graph): Wrap in 'with-fluids'. --- guix/scripts/graph.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index ba63780e2b..1623421196 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -356,15 +356,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) + packages))) + (export-graph (concatenate nodes) + (current-output-port) + #:node-type type))))))) #t) ;;; graph.scm ends here -- cgit v1.2.3 From 97507ebedc8e1265c2ed354e50a218fb9ee6087b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 May 2016 23:27:48 +0200 Subject: derivations: 'derivation' sorts items in the resulting object. * guix/derivations.scm (derivation-inputderivation-input] [coalesce-duplicate-inputs]: New procedures. Sort OUTPUTS, INPUTS, and ENV-VARS. * tests/derivations.scm ("read-derivation vs. derivation"): New test. --- guix/derivations.scm | 133 +++++++++++++++++++++++++------------------------- tests/derivations.scm | 27 ++++++++++ 2 files changed, 94 insertions(+), 66 deletions(-) (limited to 'guix') 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." + (string." @@ -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 + (($ path sub-drvs) + ;; XXX: quadratic + (match (find (match-lambda + (($ p s) + (string=? p path))) + result) + (#f + (cons input result)) + ((and dup ($ _ 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 path sub-drvs) - ;; XXX: quadratic - (match (find (match-lambda - (($ p s) - (string=? p path))) - result) - (#f - (cons input result)) - ((and dup ($ _ 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 . ($ 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 outputs inputs sources system builder args env-vars) (display "Derive(" port) - (write-list (sort outputs - (lambda (o1 o2) - (stringstring @@ -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-inputderivation-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 stringderivation-input + (delete-duplicates inputs))) + derivation-inputstring 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/tests/derivations.scm b/tests/derivations.scm index cb7196e2a9..d8553b223e 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -367,6 +367,33 @@ (and (eq? 'one (call-with-input-file one read)) (eq? 'two (call-with-input-file two read))))))) +(test-assert "read-derivation vs. derivation" + ;; Make sure 'derivation' and 'read-derivation' return objects that are + ;; identical. + (let* ((sources (unfold (cut >= <> 10) + (lambda (n) + (add-text-to-store %store + (format #f "input~a" n) + (random-text))) + 1+ + 0)) + (inputs (map (lambda (file) + (derivation %store "derivation-input" + %bash '() + #:inputs `((,%bash) (,file)))) + sources)) + (builder (add-text-to-store %store "builder.sh" + "echo one > $one ; echo two > $two" + '())) + (drv (derivation %store "derivation" + %bash `(,builder) + #:inputs `((,%bash) (,builder) + ,@(map list (append sources inputs))) + #:outputs '("two" "one"))) + (drv* (call-with-input-file (derivation-file-name drv) + read-derivation))) + (equal? drv* drv))) + (test-assert "multiple-output derivation, derivation-path->output-path" (let* ((builder (add-text-to-store %store "builder.sh" "echo one > $out ; echo two > $second" -- cgit v1.2.3 From a773c3142dd168e1c4480614d3f5fd9d003954cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 May 2016 17:07:23 +0200 Subject: graph: Allow store file names for 'derivation' and 'references' graphs. * guix/scripts/graph.scm (%derivation-node-type)[convert]: Add 'derivation-path?' and catch-all clauses. (%reference-node-type)[convert]: Add 'store-path?' and catch-all clauses. (assert-package, nodes-from-package): New procedures. (%package-node-type, %bag-node-type,%bag-with-origins-node-type) (%bag-emerged-node-type): Add 'convert' field (guix-graph): Rename 'packages' to 'items' and allow 'store-path?' arguments. * guix/graph.scm ()[convert]: Adjust comment. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 14 +++++++++++ guix/graph.scm | 2 +- guix/scripts/graph.scm | 63 ++++++++++++++++++++++++++++++++++++++++---------- tests/guix-graph.sh | 18 ++++++++++++++- 4 files changed, 83 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 3f0106be02..d88cc256d7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5161,6 +5161,12 @@ derivations (@pxref{Derivations}) and plain store items. Compared to the above representation, many additional nodes are visible, including build scripts, patches, Guile modules, etc. +For this type of graph, it is also possible to pass a @file{.drv} file +name instead of a package name, as in: + +@example +guix graph -t derivation `guix system build -d my-config.scm` +@end example @end table All the types above correspond to @emph{build-time dependencies}. The @@ -5173,6 +5179,14 @@ by @command{guix gc --references} (@pxref{Invoking guix gc}). If the given package output is not available in the store, @command{guix graph} attempts to obtain dependency information from substitutes. + +Here you can also pass a store file name instead of a package name. For +example, the command below produces the reference graph of your profile +(which can be big!): + +@example +guix graph -t references `readlink -f ~/.guix-profile` +@end example @end table The available options are the following: 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/scripts/graph.scm b/guix/scripts/graph.scm index 1623421196..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) @@ -364,7 +403,7 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (mlet %store-monad ((_ (set-grafting #f)) (nodes (mapm %store-monad (node-type-convert type) - packages))) + items))) (export-graph (concatenate nodes) (current-output-port) #:node-type type))))))) diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh index 4d5a755bc1..1ec99706fd 100644 --- a/tests/guix-graph.sh +++ b/tests/guix-graph.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015 Ludovic Courtès +# Copyright © 2015, 2016 Ludovic Courtès # # This file is part of GNU Guix. # @@ -20,6 +20,10 @@ # Test the 'guix graph' command-line utility. # +tmpfile1="t-guix-graph1-$$" +tmpfile2="t-guix-graph2-$$" +trap 'rm -f "$tmpfile1" "$tmpfile2"' EXIT + guix graph --version for package in guile-bootstrap coreutils python @@ -37,3 +41,15 @@ guix graph -e '(@ (gnu packages bootstrap) %bootstrap-guile)' \ | grep guile-bootstrap if guix graph -e +; then false; else true; fi + +# Try passing store file names. + +guix graph -t references guile-bootstrap > "$tmpfile1" +guix graph -t references `guix build guile-bootstrap` > "$tmpfile2" +cmp "$tmpfile1" "$tmpfile2" + +# XXX: Filter the file names in the graph to work around the fact that we get +# a mixture of relative and absolute file names. +guix graph -t derivation coreutils > "$tmpfile1" +guix graph -t derivation `guix build -d coreutils` > "$tmpfile2" +cmp "$tmpfile1" "$tmpfile2" -- cgit v1.2.3 From 30d4bc0434aa5d438c2d433f39c80e1f4a25bcac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 May 2016 17:18:58 +0200 Subject: substitute: Gracefully handle invalid store file names. Before, something like: echo have /gnu/foo | ./test-env guix substitute --query would lead to an ugly backtrace. * guix/scripts/substitute.scm (narinfo-cache-file): Call 'leave' when 'store-hash-part' returns #f. --- guix/scripts/substitute.scm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) (limited to 'guix') 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. -- cgit v1.2.3 From cf8b312d1872aec1f38a179eeb981d79bf7faa03 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 May 2016 22:11:56 +0200 Subject: grafts: Preserve empty directories when grafting. * guix/build/graft.scm (rewrite-directory)[rewrite-leaf]: Add case for 'directory. Pass #:directories? #t to 'find-files'. --- guix/build/graft.scm | 5 ++++- tests/grafts.scm | 24 ++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index b216e6c0d7..e9fce03181 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -115,6 +115,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 +126,7 @@ 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))) ;;; graft.scm ends here diff --git a/tests/grafts.scm b/tests/grafts.scm index afed704cde..f8c9eced1d 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -127,6 +127,30 @@ (list one two dep) (references %store dep))))))) +(test-assert "graft-derivation, preserve empty directories" + (run-with-store %store + (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) + (graft -> (graft + (origin %bash) + (replacement fake))) + (drv (gexp->derivation + "to-graft" + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output + "/a/b/c/d")) + (symlink #$%bash + (string-append #$output + "/bash"))) + #:modules '((guix build utils)))) + (grafted ((store-lift graft-derivation) drv + (list graft))) + (_ (built-derivations (list grafted))) + (out -> (derivation->output-path grafted))) + (return (and (string=? (readlink (string-append out "/bash")) + fake) + (file-is-directory? (string-append out "/a/b/c/d"))))))) + (test-assert "graft-derivation, no dependencies on grafted output" (run-with-store %store (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) -- cgit v1.2.3 From ece6864bd04fc2f9ff86fd4ac9cb0712dd71c094 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 May 2016 22:14:46 +0200 Subject: grafts: Rename files whose name matches a graft. Fixes . Reported by Mark H Weaver . * guix/build/graft.scm (rename-matching-files): New procedure. (rewrite-directory): Use it. * tests/grafts.scm ("graft-derivation, renaming"): New test. --- guix/build/graft.scm | 25 ++++++++++++++++++++++++- tests/grafts.scm | 17 +++++++++++++++++ 2 files changed, 41 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index e9fce03181..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 @@ -127,6 +149,7 @@ file name pairs." (n-par-for-each (parallel-job-count) rewrite-leaf (find-files directory (const #t) - #:directories? #t))) + #:directories? #t)) + (rename-matching-files output mapping)) ;;; graft.scm ends here diff --git a/tests/grafts.scm b/tests/grafts.scm index f8c9eced1d..8cd048552c 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -182,4 +182,21 @@ (and (string=? (readlink one) repl) (string=? (readlink two) one)))))) +(test-assert "graft-derivation, renaming" ; + (let* ((build `(begin + (use-modules (guix build utils)) + (mkdir-p (string-append (assoc-ref %outputs "out") "/" + (assoc-ref %build-inputs "in"))))) + (orig (build-expression->derivation %store "thing-to-graft" build + #:modules '((guix build utils)) + #:inputs `(("in" ,%bash)))) + (repl (add-text-to-store %store "bash" "fake bash")) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement repl)))))) + (and (build-derivations %store (list grafted)) + (let ((out (derivation->output-path grafted))) + (file-is-directory? (string-append out "/" repl)))))) + (test-end) -- cgit v1.2.3