From e7ff05438f6044eb452b6dcd8b05b45afbc61496 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 12:07:10 +0100 Subject: ui: Factorize error-reporting wrapper code. * guix/ui.scm (augmented-system-error-handler): New procedure. (error-reporting-wrapper): New macro. (symlink, copy-file): Define using 'error-reporting-wrapper'. --- guix/ui.scm | 49 +++++++++++++++++++++++-------------------------- 1 file changed, 23 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 7d4c437354..03196dbeaf 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -332,39 +332,36 @@ Report bugs to: ~a.") %guix-bug-report-address) General help using GNU software: ")) (newline)) +(define (augmented-system-error-handler file) + "Return a 'system-error' handler that mentions FILE in its message." + (lambda (key proc fmt args errno) + ;; Augment the FMT and ARGS with information about TARGET (this + ;; information is missing as of Guile 2.0.11, making the exception + ;; uninformative.) + (apply throw key proc "~A: ~S" + (list (strerror (car errno)) file) + (list errno)))) + +(define-syntax-rule (error-reporting-wrapper proc (args ...) file) + "Wrap PROC such that its 'system-error' exceptions are augmented to mention +FILE." + (let ((real-proc (@ (guile) proc))) + (lambda (args ...) + (catch 'system-error + (lambda () + (real-proc args ...)) + (augmented-system-error-handler file))))) + (set! symlink ;; We 'set!' the global binding because (gnu build ...) modules and similar ;; typically don't use (guix ui). - (let ((real-symlink (@ (guile) symlink))) - (lambda (target link) - "This is a 'symlink' replacement that provides proper error reporting." - (catch 'system-error - (lambda () - (real-symlink target link)) - (lambda (key proc fmt args errno) - ;; Augment the FMT and ARGS with information about LINK (this - ;; information is missing as of Guile 2.0.11, making the exception - ;; uninformative.) - (apply throw key proc "~A: ~S" - (list (strerror (car errno)) link) - (list errno))))))) + (error-reporting-wrapper symlink (source target) target)) (set! copy-file ;; Note: here we use 'set!', not #:replace, because UIs typically use ;; 'copy-recursively', which doesn't use (guix ui). - (let ((real-copy-file (@ (guile) copy-file))) - (lambda (source target) - "This is a 'copy-file' replacement that provides proper error reporting." - (catch 'system-error - (lambda () - (real-copy-file source target)) - (lambda (key proc fmt args errno) - ;; Augment the FMT and ARGS with information about TARGET (this - ;; information is missing as of Guile 2.0.11, making the exception - ;; uninformative.) - (apply throw key proc "~A: ~S" - (list (strerror (car errno)) target) - (list errno))))))) + (error-reporting-wrapper copy-file (source target) target)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error -- cgit v1.2.3 From 6d30b1b2ca92705a6f3c06ddaf8ccf06466089d3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 12:09:01 +0100 Subject: ui: Wrap 'canonicalize-path' for better error reporting. Reported by Christopher Baines. * guix/ui.scm (canonicalize-path): New procedure. --- guix/ui.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 03196dbeaf..6247944068 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -362,6 +362,9 @@ FILE." ;; 'copy-recursively', which doesn't use (guix ui). (error-reporting-wrapper copy-file (source target) target)) +(set! canonicalize-path + (error-reporting-wrapper canonicalize-path (file) file)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error -- cgit v1.2.3 From 4cd5ec801bb6c82cc1df2c4ac419d89614aa5d1b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 18:14:19 +0100 Subject: import: github: Fix regression on the /releases retrieval. Fixes a regression introduced in 62bd24db39a86f80242f923eb4cc2f18f3b02c67, which introduced a call to 'hash-table->alist'. * guix/import/github.scm (json-fetch*): New procedure. (latest-released-version): Use it. --- guix/import/github.scm | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index 01452b12e3..a41511aff6 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -19,16 +19,28 @@ (define-module (guix import github) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (json) #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) - #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix http-client) #:use-module (web uri) #:export (%github-updater)) +(define (json-fetch* url) + "Return a representation of the JSON resource URL (a list or hash table), or +#f if URL returns 404." + (guard (c ((and (http-get-error? c) + (= 404 (http-get-error-code c))) + #f)) ;"expected" if package is unknown + (let* ((port (http-fetch url)) + (result (json->scm port))) + (close-port port) + result))) + (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" @@ -125,7 +137,7 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" "https://api.github.com/repos/" (github-user-slash-repository url) "/releases")) - (json (json-fetch + (json (json-fetch* (if token (string-append api-url "?access_token=" token) api-url)))) -- cgit v1.2.3 From 608a50b66c73d5bdfd224195b839e01b781c354c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 18:22:53 +0100 Subject: http-client: Provide 'User-Agent' header by default. * guix/http-client.scm (http-fetch): Add #:headers parameter and honor it. Rename 'auth-header' to 'headers'. * guix/import/github.scm (json-fetch*): Add comment about required User-Agent. --- guix/http-client.scm | 26 ++++++++++++++------------ guix/import/github.scm | 1 + 2 files changed, 15 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 0090783524..78d39a0208 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; @@ -223,13 +223,14 @@ or if EOF is reached." 'shutdown (const #f)) (define* (http-fetch uri #:key port (text? #f) (buffered? #t) - keep-alive? (verify-certificate? #t)) + keep-alive? (verify-certificate? #t) + (headers '((user-agent . "GNU Guile")))) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be -reused for future HTTP requests. +reused for future HTTP requests. HEADERS is an alist of extra HTTP headers. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. @@ -240,13 +241,14 @@ Raise an '&http-get-error' condition if downloading fails." (let ((port (or port (open-connection-for-uri uri #:verify-certificate? verify-certificate?))) - (auth-header (match (uri-userinfo uri) - ((? string? str) - (list (cons 'Authorization - (string-append "Basic " - (base64-encode - (string->utf8 str)))))) - (_ '())))) + (headers (match (uri-userinfo uri) + ((? string? str) + (cons (cons 'Authorization + (string-append "Basic " + (base64-encode + (string->utf8 str)))) + headers)) + (_ headers)))) (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF)) (let*-values (((resp data) @@ -254,10 +256,10 @@ Raise an '&http-get-error' condition if downloading fails." (if (guile-version>? "2.0.7") (http-get uri #:streaming? #t #:port port #:keep-alive? #t - #:headers auth-header) ; 2.0.9+ + #:headers headers) ; 2.0.9+ (http-get* uri #:decode-body? text? ; 2.0.7 #:keep-alive? #t - #:port port #:headers auth-header))) + #:port port #:headers headers))) ((code) (response-code resp))) (case code diff --git a/guix/import/github.scm b/guix/import/github.scm index a41511aff6..df5a6b0e08 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -36,6 +36,7 @@ (guard (c ((and (http-get-error? c) (= 404 (http-get-error-code c))) #f)) ;"expected" if package is unknown + ;; Note: github.com returns 403 if we omit a 'User-Agent' header. (let* ((port (http-fetch url)) (result (json->scm port))) (close-port port) -- cgit v1.2.3 From d8c8e423ed67897a8cc236e68658baacdce1b5fd Mon Sep 17 00:00:00 2001 From: ng0 Date: Thu, 12 Jan 2017 00:39:25 +0000 Subject: licenses: Add wtfpl2. * guix/licenses.scm (wtfpl2): New variable. Signed-off-by: Leo Famulari --- guix/licenses.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 1e19300586..7b2ac2d311 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -8,7 +8,7 @@ ;;; Copyright © 2016 Leo Famulari ;;; Copyright © 2016 Fabian Harfert ;;; Copyright © 2016 Rene Saavedra -;;; Copyright © 2016 ng0 +;;; Copyright © 2016, 2017 ng0 ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,7 +74,8 @@ x11 x11-style zpl2.1 zlib - fsf-free)) + fsf-free + wtfpl2)) (define-record-type (license name uri comment) @@ -450,6 +451,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://unlicense.org/" "https://www.gnu.org/licenses/license-list.html#Unlicense")) +(define wtfpl2 + (license "WTFPL 2" + "http://www.wtfpl.net" + "http://www.wtfpl.net/about/")) + (define x11 (license "X11" "http://directory.fsf.org/wiki/License:X11" -- cgit v1.2.3 From 4d8e95097e5c40da9dd57d358bd189dcf82ff9bf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jan 2017 23:30:43 +0100 Subject: challenge: Return comparison reports instead of just discrepancies. This makes it easier to distinguish between matches, mismatches, and the various cases of inconclusive reports. * guix/scripts/challenge.scm (): Rename to... (): ... this. Add 'result' field. (comparison-report): New macro. (comparison-report-predicate, comparison-report-mismatch?) (comparison-report-match?) (comparison-report-inconclusive?): New procedures. (discrepancies): Rename to... (compare-contents): ... this. Change to return a list of . Remove calls to 'warning'. (summarize-discrepancy): Rename to... (summarize-report): ... this. Adjust to . (guix-challenge): Likewise. * tests/challenge.scm ("no discrepancies") ("one discrepancy"): Adjust to new API. ("inconclusive: no substitutes") ("inconclusive: no local build"): New tests. --- guix/scripts/challenge.scm | 161 ++++++++++++++++++++++++++++----------------- tests/challenge.scm | 62 ++++++++++++++--- 2 files changed, 152 insertions(+), 71 deletions(-) (limited to 'guix') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 9ab4fbe2a9..f14e931d74 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,12 +37,17 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (web uri) - #:export (discrepancies + #:export (compare-contents - discrepancy? - discrepancy-item - discrepancy-local-sha256 - discrepancy-narinfos + comparison-report? + comparison-report-item + comparison-report-result + comparison-report-local-sha256 + comparison-report-narinfos + + comparison-report-match? + comparison-report-mismatch? + comparison-report-inconclusive? guix-challenge)) @@ -61,13 +66,38 @@ (define ensure-store-item ;XXX: move to (guix ui)? (@@ (guix scripts size) ensure-store-item)) -;; Representation of a hash mismatch for ITEM. -(define-record-type - (discrepancy item local-sha256 narinfos) - discrepancy? - (item discrepancy-item) ;string, /gnu/store/… item - (local-sha256 discrepancy-local-sha256) ;bytevector | #f - (narinfos discrepancy-narinfos)) ;list of +;; Representation of a comparison report for ITEM. +(define-record-type + (%comparison-report item result local-sha256 narinfos) + comparison-report? + (item comparison-report-item) ;string, /gnu/store/… item + (result comparison-report-result) ;'match | 'mismatch | 'inconclusive + (local-sha256 comparison-report-local-sha256) ;bytevector | #f + (narinfos comparison-report-narinfos)) ;list of + +(define-syntax comparison-report + ;; Some sort of a an enum to make sure 'result' is correct. + (syntax-rules (match mismatch inconclusive) + ((_ item 'match rest ...) + (%comparison-report item 'match rest ...)) + ((_ item 'mismatch rest ...) + (%comparison-report item 'mismatch rest ...)) + ((_ item 'inconclusive rest ...) + (%comparison-report item 'inconclusive rest ...)))) + +(define (comparison-report-predicate result) + "Return a predicate that returns true when pass a REPORT that has RESULT." + (lambda (report) + (eq? (comparison-report-result report) result))) + +(define comparison-report-mismatch? + (comparison-report-predicate 'mismatch)) + +(define comparison-report-match? + (comparison-report-predicate 'match)) + +(define comparison-report-inconclusive? + (comparison-report-predicate 'inconclusive)) (define (locally-built? store item) "Return true if ITEM was built locally." @@ -88,10 +118,10 @@ Otherwise return #f." (define-syntax-rule (report args ...) (format (current-error-port) args ...)) -(define (discrepancies items servers) +(define (compare-contents items servers) "Challenge the substitute servers whose URLs are listed in SERVERS by comparing the hash of the substitutes of ITEMS that they serve. Return the -list of discrepancies. +list of objects. This procedure does not authenticate narinfos from SERVERS, nor does it verify that they are signed by an authorized public keys. The reason is that, by @@ -100,11 +130,7 @@ taken since we do not import the archives." (define (compare item reference) ;; Return a procedure to compare the hash of ITEM with REFERENCE. (lambda (narinfo url) - (if (not narinfo) - (begin - (warning (_ "~a: no substitute at '~a'~%") - item url) - #t) + (or (not narinfo) (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo)))) (bytevector=? reference value))))) @@ -116,9 +142,7 @@ taken since we do not import the archives." ((url urls ...) (if (not first) (select-reference item narinfos urls) - (narinfo-hash->sha256 (narinfo-hash first)))))) - (() - (warning (_ "no substitutes for '~a'; cannot conclude~%") item)))) + (narinfo-hash->sha256 (narinfo-hash first)))))))) (mlet* %store-monad ((local (mapm %store-monad query-locally-built-hash items)) @@ -130,42 +154,54 @@ taken since we do not import the archives." vhash)) vlist-null remote))) - (return (filter-map (lambda (item local) - (let ((narinfos (vhash-fold* cons '() item narinfos))) - (define reference - (or local - (begin - (warning (_ "no local build for '~a'~%") item) - (select-reference item narinfos servers)))) - - (if (every (compare item reference) - narinfos servers) - #f - (discrepancy item local narinfos)))) - items - local)))) - -(define* (summarize-discrepancy discrepancy - #:key (hash->string - bytevector->nix-base32-string)) - "Write to the current error port a summary of DISCREPANCY, a -object that denotes a hash mismatch." - (match discrepancy - (($ item local (narinfos ...)) + (return (map (lambda (item local) + (match (vhash-fold* cons '() item narinfos) + (() ;no substitutes + (comparison-report item 'inconclusive local '())) + ((narinfo) + (if local + (if ((compare item local) narinfo (first servers)) + (comparison-report item 'match + local (list narinfo)) + (comparison-report item 'mismatch + local (list narinfo))) + (comparison-report item 'inconclusive + local (list narinfo)))) + ((narinfos ...) + (let ((reference + (or local (select-reference item narinfos + servers)))) + (if (every (compare item reference) narinfos servers) + (comparison-report item 'match + local narinfos) + (comparison-report item 'mismatch + local narinfos)))))) + items + local)))) + +(define* (summarize-report comparison-report + #:key (hash->string + bytevector->nix-base32-string)) + "Write to the current error port a summary of REPORT, a +object." + (match comparison-report + (($ item 'mismatch local (narinfos ...)) (report (_ "~a contents differ:~%") item) (if local (report (_ " local hash: ~a~%") (hash->string local)) - (warning (_ "no local build for '~a'~%") item)) - + (report (_ " no local build for '~a'~%") item)) (for-each (lambda (narinfo) - (if narinfo - (report (_ " ~50a: ~a~%") - (uri->string (narinfo-uri narinfo)) - (hash->string - (narinfo-hash->sha256 (narinfo-hash narinfo)))) - (report (_ " ~50a: unavailable~%") - (uri->string (narinfo-uri narinfo))))) - narinfos)))) + (report (_ " ~50a: ~a~%") + (uri->string (narinfo-uri narinfo)) + (hash->string + (narinfo-hash->sha256 (narinfo-hash narinfo))))) + narinfos)) + (($ item 'inconclusive #f narinfos) + (warning (_ "could not challenge '~a': no local build~%") item)) + (($ item 'inconclusive locals ()) + (warning (_ "could not challenge '~a': no substitutes~%") item)) + (($ item 'match) + #t))) ;;; @@ -236,13 +272,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) #:use-substitutes? #f) (run-with-store store - (mlet* %store-monad ((items (mapm %store-monad - ensure-store-item files)) - (issues (discrepancies items urls))) - (for-each summarize-discrepancy issues) - (unless (null? issues) - (exit 2)) - (return (null? issues))) + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (reports (compare-contents items urls))) + (for-each summarize-report reports) + + (exit (cond ((any comparison-report-mismatch? reports) 2) + ((every comparison-report-match? reports) 0) + (else 1)))) #:system system)))))))) ;;; challenge.scm ends here diff --git a/tests/challenge.scm b/tests/challenge.scm index 9505042a45..387d205a64 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -69,8 +69,15 @@ (built-derivations (list drv)) (mlet %store-monad ((hash (query-path-hash* out))) (with-derivation-narinfo* drv (sha256 => hash) - (>>= (discrepancies (list out) (%test-substitute-urls)) - (lift1 null? %store-monad)))))))) + (>>= (compare-contents (list out) (%test-substitute-urls)) + (match-lambda + ((report) + (return + (and (string=? out (comparison-report-item report)) + (bytevector=? + (comparison-report-local-sha256 report) + hash) + (comparison-report-match? report)))))))))))) (test-assertm "one discrepancy" (let ((text (random-text))) @@ -90,20 +97,57 @@ (modulo (+ b 1) 128)) w))) (with-derivation-narinfo* drv (sha256 => wrong-hash) - (>>= (discrepancies (list out) (%test-substitute-urls)) + (>>= (compare-contents (list out) (%test-substitute-urls)) (match-lambda - ((discrepancy) + ((report) (return - (and (string=? out (discrepancy-item discrepancy)) + (and (string=? out (comparison-report-item (pk report))) + (eq? 'mismatch (comparison-report-result report)) (bytevector=? hash - (discrepancy-local-sha256 - discrepancy)) - (match (discrepancy-narinfos discrepancy) + (comparison-report-local-sha256 + report)) + (match (comparison-report-narinfos report) ((bad) (bytevector=? wrong-hash (narinfo-hash->sha256 (narinfo-hash bad)))))))))))))))) +(test-assertm "inconclusive: no substitutes" + (mlet* %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output))) + (out -> (derivation->output-path drv)) + (_ (built-derivations (list drv))) + (hash (query-path-hash* out))) + (>>= (compare-contents (list out) (%test-substitute-urls)) + (match-lambda + ((report) + (return + (and (string=? out (comparison-report-item report)) + (comparison-report-inconclusive? report) + (null? (comparison-report-narinfos report)) + (bytevector=? (comparison-report-local-sha256 report) + hash)))))))) + +(test-assertm "inconclusive: no local build" + (let ((text (random-text))) + (mlet* %store-monad ((drv (gexp->derivation "something" + #~(list #$output #$text))) + (out -> (derivation->output-path drv)) + (hash -> (sha256 #vu8()))) + (with-derivation-narinfo* drv (sha256 => hash) + (>>= (compare-contents (list out) (%test-substitute-urls)) + (match-lambda + ((report) + (return + (and (string=? out (comparison-report-item report)) + (comparison-report-inconclusive? report) + (not (comparison-report-local-sha256 report)) + (match (comparison-report-narinfos report) + ((narinfo) + (bytevector=? (narinfo-hash->sha256 + (narinfo-hash narinfo)) + hash)))))))))))) + + (test-end) ;;; Local Variables: -- cgit v1.2.3 From 153b62957cd5b08ccc2440854c90b5693ba52eea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Jan 2017 00:03:32 +0100 Subject: challenge: Add '--verbose'. * guix/scripts/challenge.scm (summarize-report): Add #:verbose? parameter. [report-hashes]: New procedure. Use it. Honor VERBOSE? in the 'match case. (show-help, %options): Add '--verbose'. (guix-challenge): Honor it. --- doc/guix.texi | 5 +++++ guix/scripts/challenge.scm | 48 ++++++++++++++++++++++++++++++---------------- 2 files changed, 37 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index c495e39f42..fa07aba5ad 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6412,6 +6412,11 @@ The one option that matters is: Consider @var{urls} the whitespace-separated list of substitute source URLs to compare to. +@item --verbose +@itemx -v +Show details about matches (identical contents) in addition to +information about mismatches. + @end table @node Invoking guix copy diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f14e931d74..815bb789c3 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -180,28 +180,35 @@ taken since we do not import the archives." local)))) (define* (summarize-report comparison-report - #:key (hash->string - bytevector->nix-base32-string)) + #:key + (hash->string bytevector->nix-base32-string) + verbose?) "Write to the current error port a summary of REPORT, a -object." +object. When VERBOSE?, display matches in addition to mismatches and +inconclusive reports." + (define (report-hashes item local narinfos) + (if local + (report (_ " local hash: ~a~%") (hash->string local)) + (report (_ " no local build for '~a'~%") item)) + (for-each (lambda (narinfo) + (report (_ " ~50a: ~a~%") + (uri->string (narinfo-uri narinfo)) + (hash->string + (narinfo-hash->sha256 (narinfo-hash narinfo))))) + narinfos)) + (match comparison-report (($ item 'mismatch local (narinfos ...)) (report (_ "~a contents differ:~%") item) - (if local - (report (_ " local hash: ~a~%") (hash->string local)) - (report (_ " no local build for '~a'~%") item)) - (for-each (lambda (narinfo) - (report (_ " ~50a: ~a~%") - (uri->string (narinfo-uri narinfo)) - (hash->string - (narinfo-hash->sha256 (narinfo-hash narinfo))))) - narinfos)) + (report-hashes item local narinfos)) (($ item 'inconclusive #f narinfos) (warning (_ "could not challenge '~a': no local build~%") item)) (($ item 'inconclusive locals ()) (warning (_ "could not challenge '~a': no substitutes~%") item)) - (($ item 'match) - #t))) + (($ item 'match local (narinfos ...)) + (when verbose? + (report (_ "~a contents match:~%") item) + (report-hashes item local narinfos))))) ;;; @@ -214,6 +221,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (display (_ " --substitute-urls=URLS compare build results with those at URLS")) + (display (_ " + -v, --verbose show details about successful comparisons")) (newline) (display (_ " -h, --help display this help and exit")) @@ -237,6 +246,11 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (alist-cons 'substitute-urls (string-tokenize arg) (alist-delete 'substitute-urls result)) + rest))) + (option '("verbose" #\v) #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'verbose? #t result) rest))))) (define %default-options @@ -256,7 +270,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (_ #f)) opts)) (system (assoc-ref opts 'system)) - (urls (assoc-ref opts 'substitute-urls))) + (urls (assoc-ref opts 'substitute-urls)) + (verbose? (assoc-ref opts 'verbose?))) (leave-on-EPIPE (with-store store ;; Disable grafts since substitute servers normally provide only @@ -275,7 +290,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (mlet* %store-monad ((items (mapm %store-monad ensure-store-item files)) (reports (compare-contents items urls))) - (for-each summarize-report reports) + (for-each (cut summarize-report <> #:verbose? verbose?) + reports) (exit (cond ((any comparison-report-mismatch? reports) 2) ((every comparison-report-match? reports) 0) -- cgit v1.2.3 From deac976d3d26c7b85b9c90efb424b0aa94f1027c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Jan 2017 15:13:07 +0100 Subject: daemon: Client settings no longer override daemon settings. Fixes . * nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x161. * nix/nix-daemon/nix-daemon.cc (performOp): "build-max-jobs", "build-max-silent-time", and "build-cores" are no longer read upfront; instead, read them from the key/value list at the end. * nix/nix-daemon/guix-daemon.cc (main): Explicitly set 'settings.maxBuildJobs'. * guix/store.scm (%protocol-version): Bump to #x161. (set-build-options): #:max-build-jobs, #:max-silent-time, and #:build-cores now default to #f. Adjust handshake to new protocol. * tests/store.scm ("build-cores"): New test. * tests/guix-daemon.sh: Add test for default "build-cores" value. --- guix/store.scm | 34 +++++++++++++++++++++++++--------- nix/libstore/worker-protocol.hh | 2 +- nix/nix-daemon/guix-daemon.cc | 5 +++-- nix/nix-daemon/nix-daemon.cc | 16 ++++++++++++---- tests/guix-daemon.sh | 29 ++++++++++++++++++++++++++++- tests/store.scm | 27 ++++++++++++++++++++++++++- 6 files changed, 95 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 49549d0771..7152a5556a 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -138,7 +138,7 @@ direct-store-path log-file)) -(define %protocol-version #x10f) +(define %protocol-version #x161) (define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-2 #x6478696f) ; "dxio" @@ -537,14 +537,14 @@ encoding conversion errors." #:key keep-failed? keep-going? fallback? (verbosity 0) rounds ;number of build rounds - (max-build-jobs 1) + max-build-jobs timeout - (max-silent-time 3600) + max-silent-time (use-build-hook? #t) (build-verbosity 0) (log-type 0) (print-build-trace #t) - (build-cores (current-processor-count)) + build-cores (use-substitutes? #t) ;; Client-provided substitute URLs. If it is #f, @@ -570,21 +570,37 @@ encoding conversion errors." ...))))) (write-int (operation-id set-options) socket) (send (boolean keep-failed?) (boolean keep-going?) - (boolean fallback?) (integer verbosity) - (integer max-build-jobs) (integer max-silent-time)) + (boolean fallback?) (integer verbosity)) + (when (< (nix-server-minor-version server) #x61) + (let ((max-build-jobs (or max-build-jobs 1)) + (max-silent-time (or max-silent-time 3600))) + (send (integer max-build-jobs) (integer max-silent-time)))) (when (>= (nix-server-minor-version server) 2) (send (boolean use-build-hook?))) (when (>= (nix-server-minor-version server) 4) (send (integer build-verbosity) (integer log-type) (boolean print-build-trace))) - (when (>= (nix-server-minor-version server) 6) - (send (integer build-cores))) + (when (and (>= (nix-server-minor-version server) 6) + (< (nix-server-minor-version server) #x61)) + (let ((build-cores (or build-cores (current-processor-count)))) + (send (integer build-cores)))) (when (>= (nix-server-minor-version server) 10) (send (boolean use-substitutes?))) (when (>= (nix-server-minor-version server) 12) (let ((pairs `(,@(if timeout `(("build-timeout" . ,(number->string timeout))) '()) + ,@(if max-silent-time + `(("build-max-silent-time" + . ,(number->string max-silent-time))) + '()) + ,@(if max-build-jobs + `(("build-max-jobs" + . ,(number->string max-build-jobs))) + '()) + ,@(if build-cores + `(("build-cores" . ,(number->string build-cores))) + '()) ,@(if substitute-urls `(("substitute-urls" . ,(string-join substitute-urls))) diff --git a/nix/libstore/worker-protocol.hh b/nix/libstore/worker-protocol.hh index bdeaca2e3a..efe9eadf23 100644 --- a/nix/libstore/worker-protocol.hh +++ b/nix/libstore/worker-protocol.hh @@ -6,7 +6,7 @@ namespace nix { #define WORKER_MAGIC_1 0x6e697863 #define WORKER_MAGIC_2 0x6478696f -#define PROTOCOL_VERSION 0x160 +#define PROTOCOL_VERSION 0x161 #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00) #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff) diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index d5d33a587a..aa47a290d2 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2012, 2013, 2014, 2015, 2016 Ludovic Courtès + Copyright (C) 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès This file is part of GNU Guix. @@ -301,8 +301,9 @@ main (int argc, char *argv[]) /* Turn automatic deduplication on by default. */ settings.autoOptimiseStore = true; - /* Default to using as many cores as possible. */ + /* Default to using as many cores as possible and one job at a time. */ settings.buildCores = 0; + settings.maxBuildJobs = 1; argvSaved = argv; diff --git a/nix/nix-daemon/nix-daemon.cc b/nix/nix-daemon/nix-daemon.cc index 47b67d5863..79580ffb48 100644 --- a/nix/nix-daemon/nix-daemon.cc +++ b/nix/nix-daemon/nix-daemon.cc @@ -549,8 +549,12 @@ static void performOp(bool trusted, unsigned int clientVersion, settings.keepGoing = readInt(from) != 0; settings.set("build-fallback", readInt(from) ? "true" : "false"); verbosity = (Verbosity) readInt(from); - settings.set("build-max-jobs", std::to_string(readInt(from))); - settings.set("build-max-silent-time", std::to_string(readInt(from))); + + if (GET_PROTOCOL_MINOR(clientVersion) < 0x61) { + settings.set("build-max-jobs", std::to_string(readInt(from))); + settings.set("build-max-silent-time", std::to_string(readInt(from))); + } + if (GET_PROTOCOL_MINOR(clientVersion) >= 2) settings.useBuildHook = readInt(from) != 0; if (GET_PROTOCOL_MINOR(clientVersion) >= 4) { @@ -558,7 +562,8 @@ static void performOp(bool trusted, unsigned int clientVersion, logType = (LogType) readInt(from); settings.printBuildTrace = readInt(from) != 0; } - if (GET_PROTOCOL_MINOR(clientVersion) >= 6) + if (GET_PROTOCOL_MINOR(clientVersion) >= 6 + && GET_PROTOCOL_MINOR(clientVersion) < 0x61) settings.set("build-cores", std::to_string(readInt(from))); if (GET_PROTOCOL_MINOR(clientVersion) >= 10) settings.set("build-use-substitutes", readInt(from) ? "true" : "false"); @@ -567,7 +572,10 @@ static void performOp(bool trusted, unsigned int clientVersion, for (unsigned int i = 0; i < n; i++) { string name = readString(from); string value = readString(from); - if (name == "build-timeout" || name == "build-repeat" || name == "use-ssh-substituter") + if (name == "build-timeout" || name == "build-max-silent-time" + || name == "build-max-jobs" || name == "build-cores" + || name == "build-repeat" + || name == "use-ssh-substituter") settings.set(name, value); else settings.set(trusted ? name : "untrusted-" + name, value); diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 7122eed0e6..fde49e25a2 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2014, 2015, 2016 Ludovic Courtès +# Copyright © 2012, 2014, 2015, 2016, 2017 Ludovic Courtès # # This file is part of GNU Guix. # @@ -118,3 +118,30 @@ guile -c " (clear-failed-paths store (list out)) (null? (query-failed-paths store))))))) #:guile-for-build (%guile-for-build)) " + +kill "$daemon_pid" + + +# Make sure the daemon's default 'build-cores' setting is honored. + +guix-daemon --listen="$socket" --disable-chroot --cores=42 & +daemon_pid=$! + +GUIX_DAEMON_SOCKET="$socket" \ +guile -c ' + (use-modules (guix) (gnu packages) (guix tests)) + + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo $NIX_BUILD_CORES > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv (derivation store "the-thing" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("x" . ,(random-text)))))) + (and (build-derivations store (list drv)) + (exit + (= 42 (pk (call-with-input-file (derivation->output-path drv) + read)))))))' diff --git a/tests/store.scm b/tests/store.scm index 123ea8a787..983766d862 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -948,4 +948,29 @@ (string=? (derivation-file-name d) (path-info-deriver (query-path-info %store o)))))) +(test-equal "build-cores" + (list 0 42) + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo $NIX_BUILD_CORES > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv1 (derivation store "the-thing" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("x" . ,(random-text))))) + (drv2 (derivation store "the-thing" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("x" . ,(random-text)))))) + (and (build-derivations store (list drv1)) + (begin + (set-build-options store #:build-cores 42) + (build-derivations store (list drv2))) + (list (call-with-input-file (derivation->output-path drv1) + read) + (call-with-input-file (derivation->output-path drv2) + read)))))) + (test-end "store") -- cgit v1.2.3 From d9da3a757d3081403081577c4e07763c9b809043 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Jan 2017 15:32:43 +0100 Subject: guix build: Do not force 'build-cores', 'max-build-jobs', and 'max-silent-time'. This lets the daemon use its own default settings unless otherwise specified. * guix/scripts/build.scm (set-build-options-from-command-line): Do not provide default values for #:build-cores and #:max-build-jobs. (%default-options): Remove 'max-silent-time'. --- guix/scripts/build.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ccb4c275fc..551275e89f 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, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -344,8 +344,8 @@ options handled by 'set-build-options-from-command-line', and listed in #:keep-failed? (assoc-ref opts 'keep-failed?) #:keep-going? (assoc-ref opts 'keep-going?) #:rounds (assoc-ref opts 'rounds) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) + #:build-cores (assoc-ref opts 'cores) + #:max-build-jobs (assoc-ref opts 'max-jobs) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:substitute-urls (assoc-ref opts 'substitute-urls) @@ -462,7 +462,6 @@ options handled by 'set-build-options-from-command-line', and listed in (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) - (max-silent-time . 3600) (verbosity . 0))) (define (show-help) -- cgit v1.2.3 From 6da5bb7b1b7ddf4aa5a5efcb83250506bcd67036 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Jan 2017 22:28:24 +0100 Subject: guix build: Add '--repair'. * guix/scripts/build.scm (show-help, %options): Add '--repair'. * doc/guix.texi (Invoking guix gc): Mention 'guix build --repair'. (Additional Build Options): Document it. --- doc/guix.texi | 13 ++++++++++++- guix/scripts/build.scm | 8 ++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 55657ec81c..bf9dbaa726 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2274,11 +2274,14 @@ traverses @emph{all the files in the store}, this command can take a long time, especially on systems with a slow disk drive. @cindex repairing the store +@cindex corruption, recovering from Using @option{--verify=repair} or @option{--verify=contents,repair} causes the daemon to try to repair corrupt store items by fetching substitutes for them (@pxref{Substitutes}). Because repairing is not atomic, and thus potentially dangerous, it is available only to the -system administrator. +system administrator. A lightweight alternative, when you know exactly +which items in the store are corrupt, is @command{guix build --repair} +(@pxref{Invoking guix build}). @item --optimize @cindex deduplication @@ -4859,6 +4862,14 @@ When used in conjunction with @option{--keep-failed}, the differing output is kept in the store, under @file{/gnu/store/@dots{}-check}. This makes it easy to look for differences between the two results. +@item --repair +@cindex repairing store items +@cindex corruption, recovering from +Attempt to repair the specified store items, if they are corrupt, by +re-downloading or rebuilding them. + +This operation is not atomic and thus restricted to @code{root}. + @item --derivations @itemx -d Return the derivation paths, not the output paths, of the given diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 551275e89f..8326d64f48 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -485,6 +485,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -d, --derivations return the derivation paths of the given packages")) (display (_ " --check rebuild items to check for non-determinism issues")) + (display (_ " + --repair repair the specified items")) (display (_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) @@ -535,6 +537,12 @@ must be one of 'package', 'all', or 'transitive'~%") (alist-cons 'build-mode (build-mode check) result) rest))) + (option '("repair") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-mode (build-mode repair) + result) + rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg -- cgit v1.2.3 From 849a1b8133263741754dfec7a424d9de05a165ef Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Jan 2017 09:25:52 +0000 Subject: profiles: Export 'ca-certificate-bundle'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/profiles.scm: Export ca-certificate-bundle, such that it can be used in other G-expressions. This is useful where these G-expressions run programs that require a ca-certificate-bundle, e.g. git. Signed-off-by: Ludovic Courtès --- guix/profiles.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index e7707b6543..495a9e2e7c 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -92,6 +92,7 @@ profile-manifest package->manifest-entry packages->manifest + ca-certificate-bundle %default-profile-hooks profile-derivation -- cgit v1.2.3 From 90ad5c8836138b7fd4d1bd0243dfa8b30ae0cf21 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jan 2017 21:59:00 +0100 Subject: grafts: Actually cache grafts during the derivation DAG traversal. This fixes a regression introduced in d38bc9a9f6feefc465964531520fee5663a12f48 whereby the cache was effectively disabled. Reported by Thomas Danckaert . * guix/grafts.scm (with-cache): In the cache miss case, wrap body in 'mbegin'. --- guix/grafts.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index 2006d3908e..b60c8cfd90 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -222,8 +222,9 @@ available." (return result)) (#f ;cache miss (mlet %state-monad ((result (begin exp ...))) - (set-current-state (vhash-consq key result cache)) - (return result)))))) + (mbegin %state-monad + (set-current-state (vhash-consq key result cache)) + (return result))))))) (define* (cumulative-grafts store drv grafts references -- cgit v1.2.3 From 0aeed5e310504a9ef2cf6a2b2a7e76086eb8c2fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jan 2017 22:05:43 +0100 Subject: grafts: Preserve the cache across recursive calls. Before this commit, we'd lose the cache across recursive calls to 'cumulative-grafts', which isn't great performance-wise. This bug was already present before d38bc9a9f6feefc465964531520fee5663a12f48. * guix/grafts.scm (with-cache): In the miss case, call 'current-state' after EXP has been evaluated. --- guix/grafts.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index b60c8cfd90..e14a40f8d1 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -221,7 +221,8 @@ available." ((_ . result) ;cache hit (return result)) (#f ;cache miss - (mlet %state-monad ((result (begin exp ...))) + (mlet %state-monad ((result (begin exp ...)) + (cache (current-state))) (mbegin %state-monad (set-current-state (vhash-consq key result cache)) (return result))))))) -- cgit v1.2.3 From 840f38ba37af1d09eb1e896a6350d6ab7f6532d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Jan 2017 16:57:56 +0100 Subject: guix environment, build: Allow absolute file names with '--root'. Reported by Chris Webber. * guix/scripts/build.scm (register-root): If ROOT is absolute, keep it as is. * guix/scripts/environment.scm (register-gc-root): Likewise. * tests/guix-environment.sh (expected): Add test. --- guix/scripts/build.scm | 6 ++++-- guix/scripts/environment.scm | 8 +++++--- tests/guix-environment.sh | 7 ++++++- 3 files changed, 15 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8326d64f48..d7d71b7ab9 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -99,8 +99,10 @@ found. Return #f if no build log was found." (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))) + (let* ((root (if (string-prefix? "/" root) + root + (string-append (canonicalize-path (dirname root)) + "/" root)))) (catch 'system-error (lambda () (match paths diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d3be6a84f..a08367d1b1 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015 David Thompson -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -531,8 +531,10 @@ message if any test fails." (define (register-gc-root target root) "Make ROOT an indirect root to TARGET. This is procedure is idempotent." - (let* ((root (string-append (canonicalize-path (dirname root)) - "/" root))) + (let* ((root (if (string-prefix? "/" root) + root + (string-append (canonicalize-path (dirname root)) + "/" root)))) (catch 'system-error (lambda () (symlink target root) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 2b3bbfe036..9115949123 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016 Ludovic Courtès +# Copyright © 2015, 2016, 2017 Ludovic Courtès # # This file is part of GNU Guix. # @@ -74,7 +74,12 @@ test `readlink "$gcroot"` = "$expected" guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ -- guile -c 1 test `readlink "$gcroot"` = "$expected" +rm "$gcroot" +# Same with an absolute file name. +guix environment --bootstrap -r "$PWD/$gcroot" --ad-hoc guile-bootstrap \ + -- guile -c 1 +test `readlink "$gcroot"` = "$expected" case "`uname -m`" in x86_64) -- cgit v1.2.3 From d18b79fed895b9ca5cdb3a9a68c8e02bdaef30d8 Mon Sep 17 00:00:00 2001 From: Mathieu OTHACEHE Date: Tue, 17 Jan 2017 09:17:30 +0100 Subject: import: github: Catch HTTP 403 error during fetch. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/github.scm (json-fetch*): Catch 403 HTTP error that may be raised if a github token has not been set. Signed-off-by: Mathieu OTHACEHE Signed-off-by: Ludovic Courtès --- guix/import/github.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index df5a6b0e08..1e0bb53d9a 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -32,10 +32,13 @@ (define (json-fetch* url) "Return a representation of the JSON resource URL (a list or hash table), or -#f if URL returns 404." +#f if URL returns 403 or 404." (guard (c ((and (http-get-error? c) - (= 404 (http-get-error-code c))) - #f)) ;"expected" if package is unknown + (let ((error (http-get-error-code c))) + (or (= 403 error) + (= 404 error)))) + #f)) ;; "expected" if there is an authentification error (403), + ;; or if package is unknown (404). ;; Note: github.com returns 403 if we omit a 'User-Agent' header. (let* ((port (http-fetch url)) (result (json->scm port))) -- cgit v1.2.3 From 57f068bec5349e250ce321262609ca8978a81f7f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Jan 2017 23:20:57 +0100 Subject: syscalls: Extract 'bytes->string'. * guix/build/syscalls.scm (bytes->string): New procedure. (bytevector->string-list): Use it. --- guix/build/syscalls.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 2e37846ff0..c06013cd08 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -900,6 +900,15 @@ bytevector BV at INDEX." ;; The most terrible interface, live from Scheme. (syscall->procedure int "ioctl" (list int unsigned-long '*))) +(define (bytes->string bytes) + "Read BYTES, a list of bytes, and return the null-terminated string decoded +from there, or #f if that would be an empty string." + (match (take-while (negate zero?) bytes) + (() + #f) + (non-zero + (list->string (map integer->char non-zero))))) + (define (bytevector->string-list bv stride len) "Return the null-terminated strings found in BV every STRIDE bytes. Read at most LEN bytes from BV." @@ -911,9 +920,7 @@ most LEN bytes from BV." (reverse result)) (_ (loop (drop bytes stride) - (cons (list->string (map integer->char - (take-while (negate zero?) bytes))) - result)))))) + (cons (bytes->string bytes) result)))))) (define* (network-interface-names #:optional sock) "Return the names of existing network interfaces. This is typically limited -- cgit v1.2.3 From 150309726f221c9b982e594466d35f5b895391d5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Jan 2017 23:21:25 +0100 Subject: syscalls: Add utmpx procedures and data structure. * guix/build/syscalls.scm (): New record type. (%utmpx): New C struct. (login-type): New bits. (setutxent, endutxent, getutxent, utmpx-entries): New procedures. --- guix/build/syscalls.scm | 113 +++++++++++++++++++++++++++++++++++++++++++++++- tests/syscalls.scm | 13 +++++- 2 files changed, 124 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index c06013cd08..475fc96490 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -25,6 +25,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -126,7 +127,22 @@ window-size-x-pixels window-size-y-pixels terminal-window-size - terminal-columns)) + terminal-columns + + utmpx? + utmpx-login-type + utmpx-pid + utmpx-line + utmpx-id + utmpx-user + utmpx-host + utmpx-termination-status + utmpx-exit-status + utmpx-session-id + utmpx-time + utmpx-address + login-type + utmpx-entries)) ;;; Commentary: ;;; @@ -1487,4 +1503,99 @@ always a positive integer." (fall-back) (apply throw args)))))) + +;;; +;;; utmpx. +;;; + +(define-record-type + (utmpx type pid line id user host termination exit + session time address) + utmpx? + (type utmpx-login-type) ;login-type + (pid utmpx-pid) + (line utmpx-line) ;device name + (id utmpx-id) + (user utmpx-user) ;user name + (host utmpx-host) ;host name | #f + (termination utmpx-termination-status) + (exit utmpx-exit-status) + (session utmpx-session-id) ;session ID, for windowing + (time utmpx-time) ;entry time + (address utmpx-address)) + +(define-c-struct %utmpx ; + sizeof-utmpx + (lambda (type pid line id user host termination exit session + seconds useconds address %reserved) + (utmpx type pid + (bytes->string line) id + (bytes->string user) + (bytes->string host) termination exit + session + (make-time time-utc (* 1000 useconds) seconds) + address)) + read-utmpx + write-utmpx! + (type short) + (pid int) + (line (array uint8 32)) + (id (array uint8 4)) + (user (array uint8 32)) + (host (array uint8 256)) + (termination short) + (exit short) + (session int32) + (time-seconds int32) + (time-useconds int32) + (address-v6 (array int32 4)) + (%reserved (array uint8 20))) + +(define-bits login-type + %unused-login-type->symbols + (define EMPTY 0) ;No valid user accounting information. + (define RUN_LVL 1) ;The system's runlevel. + (define BOOT_TIME 2) ;Time of system boot. + (define NEW_TIME 3) ;Time after system clock changed. + (define OLD_TIME 4) ;Time when system clock changed. + + (define INIT_PROCESS 5) ;Process spawned by the init process. + (define LOGIN_PROCESS 6) ;Session leader of a logged in user. + (define USER_PROCESS 7) ;Normal process. + (define DEAD_PROCESS 8) ;Terminated process. + + (define ACCOUNTING 9)) ;System accounting. + +(define setutxent + (let ((proc (syscall->procedure void "setutxent" '()))) + (lambda () + "Open the user accounting database." + (proc)))) + +(define endutxent + (let ((proc (syscall->procedure void "endutxent" '()))) + (lambda () + "Close the user accounting database." + (proc)))) + +(define getutxent + (let ((proc (syscall->procedure '* "getutxent" '()))) + (lambda () + "Return the next entry from the user accounting database." + (let ((ptr (proc))) + (if (null-pointer? ptr) + #f + (read-utmpx (pointer->bytevector ptr sizeof-utmpx))))))) + +(define (utmpx-entries) + "Return the list of entries read from the user accounting database." + (setutxent) + (let loop ((entries '())) + (match (getutxent) + (#f + (endutxent) + (reverse entries)) + ((? utmpx? entry) + (loop (cons entry entries)))))) + ;;; syscalls.scm ends here diff --git a/tests/syscalls.scm b/tests/syscalls.scm index e4ef32c522..fb2c8e7100 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; ;;; This file is part of GNU Guix. @@ -441,6 +441,17 @@ (> (terminal-columns (open-input-string "Join us now, share the software!")) 0)) +(test-assert "utmpx-entries" + (match (utmpx-entries) + (((? utmpx? entries) ...) + (every (lambda (entry) + (match (utmpx-user entry) + ((? string?) + (> (utmpx-pid entry) 0)) + (#f ;might be DEAD_PROCESS + #t))) + entries)))) + (test-end) (false-if-exception (delete-file temp-file)) -- cgit v1.2.3 From ac080e296e161e5145a7db75f7685b47c755c827 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Jan 2017 16:42:31 +0100 Subject: lint: Display PACKAGE@VERSION. * guix/scripts/lint.scm (run-checkers): Remove 'name' variable. Display PACKAGE@VERSION instead of PACKAGE-VERSION. --- guix/scripts/lint.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9b991786c3..afc1369ad1 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -959,12 +959,12 @@ or a list thereof") (define* (run-checkers package #:optional (checkers %checkers)) "Run the given CHECKERS on PACKAGE." - (let ((tty? (isatty? (current-error-port))) - (name (package-full-name package))) + (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) (when tty? - (format (current-error-port) "checking ~a [~a]...\x1b[K\r" - name (lint-checker-name checker)) + (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r" + (package-name package) (package-version package) + (lint-checker-name checker)) (force-output (current-error-port))) ((lint-checker-check checker) package)) checkers) -- cgit v1.2.3 From 3483f004a98f103acff96effe1309cc620372e79 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Jan 2017 00:35:16 +0100 Subject: syscalls: Export 'read-utmpx'. * guix/build/syscalls.scm (read-utmpx-from-port): New procedure. * tests/syscalls.scm ("read-utmpx, EOF") ("read-utmpx"): New tests. --- guix/build/syscalls.scm | 13 ++++++++++++- tests/syscalls.scm | 9 +++++++++ 2 files changed, 21 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 475fc96490..b68c48a05a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -21,6 +21,7 @@ (define-module (guix build syscalls) #:use-module (system foreign) #:use-module (rnrs bytevectors) + #:autoload (ice-9 binary-ports) (get-bytevector-n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -142,7 +143,8 @@ utmpx-time utmpx-address login-type - utmpx-entries)) + utmpx-entries + (read-utmpx-from-port . read-utmpx))) ;;; Commentary: ;;; @@ -1598,4 +1600,13 @@ always a positive integer." ((? utmpx? entry) (loop (cons entry entries)))))) +(define (read-utmpx-from-port port) + "Read a utmpx entry from PORT. Return either the EOF object or a utmpx +entry." + (match (get-bytevector-n port sizeof-utmpx) + ((? eof-object? eof) + eof) + ((? bytevector? bv) + (read-utmpx bv)))) + ;;; syscalls.scm ends here diff --git a/tests/syscalls.scm b/tests/syscalls.scm index fb2c8e7100..92e02f3303 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -452,6 +452,15 @@ #t))) entries)))) +(test-assert "read-utmpx, EOF" + (eof-object? (read-utmpx (%make-void-port "r")))) + +(unless (access? "/var/run/utmpx" O_RDONLY) + (tes-skip 1)) +(test-assert "read-utmpx" + (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx))) + (or (utmpx? result) (eof-object? result)))) + (test-end) (false-if-exception (delete-file temp-file)) -- cgit v1.2.3 From fd7d1235f1d2e053bbc20d555bd9eed889845ca2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Jan 2017 17:48:24 +0100 Subject: grafts: Shallow grafting can be performed on a subset of the outputs. * guix/grafts.scm (graft-derivation/shallow): Add #:outputs parameter. [outputs]: Rename to... [output-pairs]: ... this. Adjust 'build-expression->derivation' call accordingly. --- guix/grafts.scm | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index e14a40f8d1..e44fc0544f 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -78,11 +78,12 @@ (define* (graft-derivation/shallow store drv grafts #:key (name (derivation-name drv)) + (outputs (derivation-output-names drv)) (guile (%guile-for-build)) (system (%current-system))) - "Return a derivation called NAME, based on DRV but with all the GRAFTS -applied. This procedure performs \"shallow\" grafting in that GRAFTS are not -recursively applied to dependencies of DRV." + "Return a derivation called NAME, which applies GRAFTS to the specified +OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS +are not recursively applied to dependencies of DRV." ;; XXX: Someday rewrite using gexps. (define mapping ;; List of store item pairs. @@ -96,14 +97,12 @@ recursively applied to dependencies of DRV." target)))) grafts)) - (define outputs - (map (match-lambda - ((name . output) - (cons name (derivation-output-path output)))) - (derivation-outputs drv))) - - (define output-names - (derivation-output-names drv)) + (define output-pairs + (map (lambda (output) + (cons output + (derivation-output-path + (assoc-ref (derivation-outputs drv) output)))) + outputs)) (define build `(begin @@ -111,7 +110,7 @@ recursively applied to dependencies of DRV." (guix build utils) (ice-9 match)) - (let* ((old-outputs ',outputs) + (let* ((old-outputs ',output-pairs) (mapping (append ',mapping (map (match-lambda ((name . file) @@ -143,10 +142,10 @@ recursively applied to dependencies of DRV." (guix build utils)) #:inputs `(,@(map (lambda (out) `("x" ,drv ,out)) - output-names) + outputs) ,@(append (map add-label sources) (map add-label targets))) - #:outputs output-names + #:outputs outputs #:local-build? #t))))) (define (item->deriver store item) "Return two values: the derivation that led to ITEM (a store item), and the -- cgit v1.2.3 From 482fda2729c3e76999892cb8f9a0391a7bd37119 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Jan 2017 10:20:02 +0100 Subject: grafts: Do not pull derivation outputs not depended on. Fixes . Previously, the grafting derivation of, say, brdf-explorer would pull in qt:doc even though brdf-explorer depends only on qt:out, not qt:doc. * guix/grafts.scm (with-cache): Use 'vhash-assoc' and 'vhash-cons' instead of 'vhash-assq' and 'vhash-consq'. (cumulative-grafts): Pass #:outputs to 'graft-derivation/shallow'. Use OUTPUTS instead of (derivation-output-names drv). (graft-derivation): Add #:outputs parameter; pass it to 'cumulative-grafts'. * tests/grafts.scm (make-derivation-input): New variable. ("graft-derivation, replaced derivation has multiple outputs"): Make sure P2:zzz is not part of the outputs of P3D. ("graft-derivation with #:outputs") ("graft-derivation, unused outputs not depended on"): New tests. --- guix/grafts.scm | 25 ++++++------ tests/grafts.scm | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 128 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index e44fc0544f..11885db226 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -216,14 +216,14 @@ available." (define-syntax-rule (with-cache key exp ...) "Cache the value of monadic expression EXP under KEY." (mlet %state-monad ((cache (current-state))) - (match (vhash-assq key cache) + (match (vhash-assoc key cache) ((_ . result) ;cache hit (return result)) (#f ;cache miss (mlet %state-monad ((result (begin exp ...)) (cache (current-state))) (mbegin %state-monad - (set-current-state (vhash-consq key result cache)) + (set-current-state (vhash-cons key result cache)) (return result))))))) (define* (cumulative-grafts store drv grafts @@ -264,7 +264,7 @@ derivations to the corresponding set of grafts." #:system system)) (state-return grafts)))) - (with-cache drv + (with-cache (cons (derivation-file-name drv) outputs) (match (non-self-references references drv outputs) (() ;no dependencies (return grafts)) @@ -281,29 +281,27 @@ derivations to the corresponding set of grafts." ;; applicable to DRV, to avoid creating several identical ;; grafted variants of DRV. (let* ((new (graft-derivation/shallow store drv applicable + #:outputs outputs #:guile guile #:system system)) - - ;; Replace references to any of the outputs of DRV, - ;; even if that's more than needed. This is so that - ;; the result refers only to the outputs of NEW and - ;; not to those of DRV. (grafts (append (map (lambda (output) (graft (origin drv) (origin-output output) (replacement new) (replacement-output output))) - (derivation-output-names drv)) + outputs) grafts))) (return grafts)))))))))) (define* (graft-derivation store drv grafts - #:key (guile (%guile-for-build)) + #:key + (guile (%guile-for-build)) + (outputs (derivation-output-names drv)) (system (%current-system))) - "Applied GRAFTS to DRV and all its dependencies, recursively. That is, if -GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft -DRV itself to refer to those grafted dependencies." + "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively. +That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of +DRV, and graft DRV itself to refer to those grafted dependencies." ;; First, pre-compute the dependency tree of the outputs of DRV. Do this ;; upfront to have as much parallelism as possible when querying substitute @@ -313,6 +311,7 @@ DRV itself to refer to those grafted dependencies." (match (run-with-state (cumulative-grafts store drv grafts references + #:outputs outputs #:guile guile #:system system) vlist-null) ;the initial cache ((first . rest) diff --git a/tests/grafts.scm b/tests/grafts.scm index 6454a03b1f..08f05c0f75 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +43,9 @@ (define %mkdir (bootstrap-binary "mkdir")) +(define make-derivation-input + (@@ (guix derivations) make-derivation-input)) + (test-begin "grafts") @@ -241,7 +244,18 @@ (replacement p1r) (replacement-output "ONE"))) (p3d (graft-derivation %store p3 (list p1g)))) - (and (build-derivations %store (list p3d)) + + (and (not (find (lambda (input) + ;; INPUT should not be P2:zzz since the result of P3 + ;; does not depend on it. See + ;; . + (and (string=? (derivation-input-path input) + (derivation-file-name p2)) + (member "zzz" + (derivation-input-sub-derivations input)))) + (derivation-inputs p3d))) + + (build-derivations %store (list p3d)) (let ((out (derivation->output-path (pk 'p2d p3d)))) (and (not (string=? (readlink out) (derivation->output-path p2 "aaa"))) @@ -249,6 +263,106 @@ (readlink (string-append out "/two"))) (file-exists? (string-append out "/one/replacement"))))))) +(test-assert "graft-derivation with #:outputs" + ;; Call 'graft-derivation' with a narrowed set of outputs passed as + ;; #:outputs. + (let* ((p1 (build-expression->derivation + %store "p1" + `(let ((one (assoc-ref %outputs "one")) + (two (assoc-ref %outputs "two"))) + (mkdir one) + (mkdir two)) + #:outputs '("one" "two"))) + (p1r (build-expression->derivation + %store "P1" + `(let ((other (assoc-ref %outputs "ONE"))) + (mkdir other) + (call-with-output-file (string-append other "/replacement") + (const #t))) + #:outputs '("ONE"))) + (p2 (build-expression->derivation + %store "p2" + `(let ((aaa (assoc-ref %outputs "aaa")) + (zzz (assoc-ref %outputs "zzz"))) + (mkdir zzz) (chdir zzz) + (mkdir aaa) (chdir aaa) + (symlink (assoc-ref %build-inputs "p1:two") "two")) + #:outputs '("aaa" "zzz") + #:inputs `(("p1:one" ,p1 "one") + ("p1:two" ,p1 "two")))) + (p1g (graft + (origin p1) + (origin-output "one") + (replacement p1r) + (replacement-output "ONE"))) + (p2g (graft-derivation %store p2 (list p1g) + #:outputs '("aaa")))) + ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft. + (eq? p2g p2))) + +(test-equal "graft-derivation, unused outputs not depended on" + '("aaa") + + ;; Make sure that the result of 'graft-derivation' does not pull outputs + ;; that are irrelevant to the grafting process. See + ;; . + (let* ((p1 (build-expression->derivation + %store "p1" + `(let ((one (assoc-ref %outputs "one")) + (two (assoc-ref %outputs "two"))) + (mkdir one) + (mkdir two)) + #:outputs '("one" "two"))) + (p1r (build-expression->derivation + %store "P1" + `(let ((other (assoc-ref %outputs "ONE"))) + (mkdir other) + (call-with-output-file (string-append other "/replacement") + (const #t))) + #:outputs '("ONE"))) + (p2 (build-expression->derivation + %store "p2" + `(let ((aaa (assoc-ref %outputs "aaa")) + (zzz (assoc-ref %outputs "zzz"))) + (mkdir zzz) (chdir zzz) + (symlink (assoc-ref %build-inputs "p1:two") "two") + (mkdir aaa) (chdir aaa) + (symlink (assoc-ref %build-inputs "p1:one") "one")) + #:outputs '("aaa" "zzz") + #:inputs `(("p1:one" ,p1 "one") + ("p1:two" ,p1 "two")))) + (p1g (graft + (origin p1) + (origin-output "one") + (replacement p1r) + (replacement-output "ONE"))) + (p2g (graft-derivation %store p2 (list p1g) + #:outputs '("aaa")))) + + ;; Here P2G should only depend on P1:one and P1R:one; it must not depend + ;; on P1:two or P1R:two since these are unused in the grafting process. + (and (not (eq? p2g p2)) + (let* ((inputs (derivation-inputs p2g)) + (match-input (lambda (drv) + (lambda (input) + (string=? (derivation-input-path input) + (derivation-file-name drv))))) + (p1-inputs (filter (match-input p1) inputs)) + (p1r-inputs (filter (match-input p1r) inputs)) + (p2-inputs (filter (match-input p2) inputs))) + (and (equal? p1-inputs + (list (make-derivation-input (derivation-file-name p1) + '("one")))) + (equal? p1r-inputs + (list + (make-derivation-input (derivation-file-name p1r) + '("ONE")))) + (equal? p2-inputs + (list + (make-derivation-input (derivation-file-name p2) + '("aaa")))) + (derivation-output-names p2g)))))) + (test-assert "graft-derivation, renaming" ; (let* ((build `(begin (use-modules (guix build utils)) -- cgit v1.2.3 From 0ca575f3bbb6de07469d5bf285ff1a8878a74e1e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 25 Jan 2017 07:24:20 +0000 Subject: container: Pass through TERM when calling exec. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/container/exec.scm (guix-container-exec): Capture the value of the TERM environment variable, and pass it through to the container. This means some applications now work where they did not before (e.g. htop), and others have more functionality, providing that the terminal was capable of enabling that functionality in the first place. Co-authored-by: Ludovic Courtès --- guix/scripts/container/exec.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index 10e70568cc..d6d267daff 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -74,7 +74,14 @@ and the other containing arguments for the command to be executed." (let* ((opts (parse-command-line args %options '(()) #:argument-handler handle-argument)) - (pid (assoc-ref opts 'pid))) + (pid (assoc-ref opts 'pid)) + (environment (filter-map (lambda (name) + (let ((value (getenv name))) + (and value (cons name value)))) + ;; Pass through the TERM environment + ;; variable to inform processes about + ;; the capabilities of the terminal. + '("TERM")))) (unless pid (leave (_ "no pid specified~%"))) @@ -89,6 +96,10 @@ and the other containing arguments for the command to be executed." (lambda () (match command ((program . program-args) + (for-each (match-lambda + ((name . value) + (setenv name value))) + environment) (apply execlp program program program-args))))))) (unless (zero? result) (leave (_ "exec failed with status ~d~%") result))))))) -- cgit v1.2.3 From db6afe387ae74943a0c66c7488be49bd509b51c4 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 25 Jan 2017 22:34:33 +0100 Subject: copy: Use userauth-public-key/auto! for ssh authentification. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/copy.scm (open-ssh-session): Replace userauth-agent! by userauth-public-key/auto!. This way, if ssh-agent is not run, default ssh key (~/.ssh/id_rsa) will be used as a fallback. Signed-off-by: Ludovic Courtès --- guix/scripts/copy.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 9ae204e6c6..624ef73e96 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -63,8 +63,8 @@ Throw an error on failure." (match (connect! session) ('ok - ;; Let the SSH agent authenticate us to the server. - (match (userauth-agent! session) + ;; Use public key authentication, via the SSH agent if it's available. + (match (userauth-public-key/auto! session) ('success session) (x -- cgit v1.2.3 From 2f977d92d3ae517788d3dee98f63680ca149aa1a Mon Sep 17 00:00:00 2001 From: Carlo Zancanaro Date: Sat, 21 Jan 2017 16:15:21 +1100 Subject: import: pypi: Don't add setuptools to propagated-inputs. * guix/import/pypi.scm (compute-inputs): Don't add setuptools to the imported package's propagated-inputs. --- guix/import/pypi.scm | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 7cce0fc594..ed0d4297a4 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -227,10 +227,8 @@ name/variable pairs describing the required inputs of this package." (sort (map (lambda (input) (list input (list 'unquote (string->symbol input)))) - (append '("python-setuptools") - ;; Argparse has been part of Python since 2.7. - (remove (cut string=? "python-argparse" <>) - (guess-requirements source-url wheel-url tarball)))) + (remove (cut string=? "python-argparse" <>) + (guess-requirements source-url wheel-url tarball))) (lambda args (match args (((a _ ...) (b _ ...)) -- cgit v1.2.3 From 0db2ff65e7101951fedf4357aa37aaf92f7df431 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 25 Jan 2017 20:52:27 +0100 Subject: bournish: Extend 'rm' command. * guix/build/bournish.scm (rm-command): New procedure. (%commands): Use it. * tests/bournish.scm: Add tests for "rm" and "rm -r". --- guix/build/bournish.scm | 11 ++++++++++- tests/bournish.scm | 12 ++++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index 51dad17ba7..e948cd03d3 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -105,6 +106,14 @@ characters." ((@ (guix build utils) dump-port) port (current-output-port)) *unspecified*))) +(define (rm-command . args) + "Emit code for the 'rm' command." + (cond ((member "-r" args) + `(for-each (@ (guix build utils) delete-file-recursively) + (list ,@(delete "-r" args)))) + (else + `(for-each delete-file (list ,@args))))) + (define (lines+chars port) "Return the number of lines and number of chars read from PORT." (let loop ((lines 0) (chars 0)) @@ -194,7 +203,7 @@ commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n")) `(("echo" ,(lambda strings `(list ,@strings))) ("cd" ,(lambda (dir) `(chdir ,dir))) ("pwd" ,(lambda () `(getcwd))) - ("rm" ,(lambda (file) `(delete-file ,file))) + ("rm" ,rm-command) ("cp" ,(lambda (source dest) `(copy-file ,source ,dest))) ("help" ,help-command) ("ls" ,ls-command) diff --git a/tests/bournish.scm b/tests/bournish.scm index 0f529ce42f..3b40ce2643 100644 --- a/tests/bournish.scm +++ b/tests/bournish.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,5 +39,16 @@ (read-and-compile (open-input-string "cd /foo\npwd\nls") #:from %bournish-language #:to 'scheme)) +(test-equal "rm" + '(for-each delete-file (list "foo" "bar")) + (read-and-compile (open-input-string "rm foo bar\n") + #:from %bournish-language #:to 'scheme)) + +(test-equal "rm -r" + '(for-each (@ (guix build utils) delete-file-recursively) + (list "/foo" "/bar")) + (read-and-compile (open-input-string "rm -r /foo /bar\n") + #:from %bournish-language #:to 'scheme)) + (test-end "bournish") -- cgit v1.2.3 From b03218d5326ba6fbb59d9425fb06a8aee9ed73a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Jan 2017 23:20:59 +0100 Subject: gnu-maintenance: Honor 'upstream-name' property in GNU updater. * guix/gnu-maintenance.scm (gnu-package?): Honor the 'usptream-name' property of PACKAGE. (ftp-server/directory): Likewise. --- guix/gnu-maintenance.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 789724c8c0..499967eb89 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -195,7 +195,9 @@ network to check in GNU's database." (or (gnu-home-page? package) (let ((url (and=> (package-source package) origin-uri)) - (name (package-name package))) + (name (or (assq-ref (package-properties package) + 'upstream-name) + (package-name package)))) (case (and (string? url) (mirror-type url)) ((gnu) #t) ((non-gnu) #f) @@ -210,10 +212,12 @@ network to check in GNU's database." (define (ftp-server/directory package) "Return the FTP server and directory where PACKAGE's tarball are stored." - (values (or (assoc-ref (package-properties package) 'ftp-server) - "ftp.gnu.org") - (or (assoc-ref (package-properties package) 'ftp-directory) - (string-append "/gnu/" (package-name package))))) + (let ((name (or (assq-ref (package-properties package) 'upstream-name) + (package-name package)))) + (values (or (assoc-ref (package-properties package) 'ftp-server) + "ftp.gnu.org") + (or (assoc-ref (package-properties package) 'ftp-directory) + (string-append "/gnu/" name))))) (define (sans-extension tarball) "Return TARBALL without its .tar.* or .zip extension." -- cgit v1.2.3 From 2e2cf9a3bd9f95c4d19f9acf9fd6c88dc48e7291 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Jan 2017 23:24:21 +0100 Subject: gnu-maintenance: GNU updater handles gnu.org-hosted Emacs packages. * guix/gnu-maintenance.scm (pure-gnu-package?): If an "emacs-" package matches 'gnu-hosted?', return true. (gnu-hosted?): New procedure. --- guix/gnu-maintenance.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 499967eb89..8a37ce56e6 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -448,8 +448,10 @@ hosted on ftp.gnu.org, or not under that name (this is the case for (define (pure-gnu-package? package) "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This excludes AucTeX, for instance, whose releases are now uploaded to -elpa.gnu.org, and all the GNOME packages." - (and (not (string-prefix? "emacs-" (package-name package))) +elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its +releases are on gnu.org." + (and (or (not (string-prefix? "emacs-" (package-name package))) + (gnu-hosted? package)) (not (gnome-package? package)) (gnu-package? package))) @@ -471,6 +473,9 @@ source URLs starts with PREFIX." (_ #f))) (_ #f)))) +(define gnu-hosted? + (url-prefix-predicate "mirror://gnu/")) + (define gnome-package? (url-prefix-predicate "mirror://gnome/")) -- cgit v1.2.3 From 6715e1ff2e09af3208f8f2a108ca100798ca1058 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Jan 2017 23:40:04 +0100 Subject: gnu-maintenance: 'gnu-package?' ignores invalid URLs. * guix/gnu-maintenance.scm (gnu-package?)[gnu-home-page?]: Add '>>' threading macro and use it. --- guix/gnu-maintenance.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 8a37ce56e6..9c94992ab6 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -187,11 +187,17 @@ network to check in GNU's database." 'non-gnu))))) (define (gnu-home-page? package) - (and=> (package-home-page package) - (lambda (url) - (and=> (uri-host (string->uri url)) - (lambda (host) - (member host '("www.gnu.org" "gnu.org"))))))) + (letrec-syntax ((>> (syntax-rules () + ((_ value proc) + (and=> value proc)) + ((_ value proc rest ...) + (and=> value + (lambda (next) + (>> (proc next) rest ...))))))) + (>> package package-home-page + string->uri uri-host + (lambda (host) + (member host '("www.gnu.org" "gnu.org")))))) (or (gnu-home-page? package) (let ((url (and=> (package-source package) origin-uri)) -- cgit v1.2.3 From 21f4a7c116ed884314f29a8dc69ed18092b35477 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Jan 2017 23:49:52 +0100 Subject: import: github: Better tolerate unexpected file extensions. * guix/import/github.scm (find-extension): Add ".tbz". (updated-github-url): When 'find-extension' returns #f, use "" for EXT. --- guix/import/github.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index 1e0bb53d9a..b249b39067 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -49,7 +49,8 @@ "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" (find (lambda (x) (string-suffix? x url)) - (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar" ".tgz" ".love"))) + (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar" + ".tgz" ".tbz" ".love"))) (define (updated-github-url old-package new-version) ;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in @@ -57,7 +58,7 @@ false if none is recognized" (define (updated-url url) (if (string-prefix? "https://github.com/" url) - (let ((ext (find-extension url)) + (let ((ext (or (find-extension url) "")) (name (package-name old-package)) (version (package-version old-package)) (prefix (string-append "https://github.com/" -- cgit v1.2.3 From 3b0fcc672d48ed67a807b20bde5d2f963c285074 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Jan 2017 00:11:33 +0100 Subject: packages: Add 'package-upstream-name' and use it. * guix/packages.scm (package-upstream-name): New procedure. * guix/gnu-maintenance.scm (gnu-package?, ftp-server/directory) (latest-release*, latest-gnome-release) (latest-kde-release): Use it instead of the inline expression. --- guix/gnu-maintenance.scm | 21 +++++++-------------- guix/packages.scm | 9 ++++++++- 2 files changed, 15 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 9c94992ab6..e4151c652c 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -201,9 +201,7 @@ network to check in GNU's database." (or (gnu-home-page? package) (let ((url (and=> (package-source package) origin-uri)) - (name (or (assq-ref (package-properties package) - 'upstream-name) - (package-name package)))) + (name (package-upstream-name package))) (case (and (string? url) (mirror-type url)) ((gnu) #t) ((non-gnu) #f) @@ -218,8 +216,7 @@ network to check in GNU's database." (define (ftp-server/directory package) "Return the FTP server and directory where PACKAGE's tarball are stored." - (let ((name (or (assq-ref (package-properties package) 'upstream-name) - (package-name package)))) + (let ((name (package-upstream-name package))) (values (or (assoc-ref (package-properties package) 'ftp-server) "ftp.gnu.org") (or (assoc-ref (package-properties package) 'ftp-directory) @@ -433,11 +430,9 @@ hosted on ftp.gnu.org, or not under that name (this is the case for \"emacs-auctex\", for instance.)" (let-values (((server directory) (ftp-server/directory package))) - (let ((name (or (assoc-ref (package-properties package) 'upstream-name) - (package-name package)))) - (false-if-ftp-error (latest-release name - #:server server - #:directory directory))))) + (false-if-ftp-error (latest-release (package-upstream-name package) + #:server server + #:directory directory)))) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses @@ -506,8 +501,7 @@ source URLs starts with PREFIX." (define upstream-name ;; Some packages like "NetworkManager" have camel-case names. - (or (assoc-ref (package-properties package) 'upstream-name) - (package-name package))) + (package-upstream-name package)) (false-if-ftp-error (latest-ftp-release upstream-name @@ -531,8 +525,7 @@ source URLs starts with PREFIX." (let ((uri (string->uri (origin-uri (package-source package))))) (false-if-ftp-error (latest-ftp-release - (or (assoc-ref (package-properties package) 'upstream-name) - (package-name package)) + (package-upstream-name package) #:server "mirrors.mit.edu" #:directory (string-append "/kde" (dirname (dirname (uri-path uri)))) diff --git a/guix/packages.scm b/guix/packages.scm index beb958f156..defde2478a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2014, 2015 Mark H Weaver ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2016 Alex Kost @@ -62,6 +62,7 @@ package package? package-name + package-upstream-name package-version package-full-name package-source @@ -296,6 +297,12 @@ name of its URI." package) 16))))) +(define (package-upstream-name package) + "Return the upstream name of PACKAGE, which could be different from the name +it has in Guix." + (or (assq-ref (package-properties package) 'upstream-name) + (package-name package))) + (define (hidden-package p) "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus, user interfaces, ignores." -- cgit v1.2.3 From f9704f179a5160013c4a401dce3761714bba8e72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Jan 2017 16:33:57 +0100 Subject: Add (guix memoization). * guix/combinators.scm (memoize): Remove. * guix/memoization.scm: New file. * Makefile.am (MODULES): Add it. * gnu/packages.scm, gnu/packages/bootstrap.scm, guix/build-system/gnu.scm, guix/build-system/python.scm, guix/derivations.scm, guix/gnu-maintenance.scm, guix/import/cran.scm, guix/import/elpa.scm, guix/modules.scm, guix/scripts/build.scm, guix/scripts/graph.scm, guix/scripts/lint.scm, guix/store.scm, guix/utils.scm: Adjust imports accordingly. --- .dir-locals.el | 2 + Makefile.am | 3 +- gnu/packages.scm | 3 +- gnu/packages/bootstrap.scm | 4 +- guix/build-system/gnu.scm | 4 +- guix/build-system/python.scm | 4 +- guix/combinators.scm | 18 +------ guix/derivations.scm | 1 + guix/gnu-maintenance.scm | 2 +- guix/import/cran.scm | 4 +- guix/import/elpa.scm | 3 +- guix/memoization.scm | 114 +++++++++++++++++++++++++++++++++++++++++++ guix/modules.scm | 4 +- guix/scripts/build.scm | 1 - guix/scripts/graph.scm | 4 +- guix/scripts/lint.scm | 2 +- guix/store.scm | 2 +- guix/utils.scm | 2 +- 18 files changed, 140 insertions(+), 37 deletions(-) create mode 100644 guix/memoization.scm (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index adcc50c560..917fd3004a 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -52,6 +52,8 @@ (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1)) (eval . (put 'with-derivation-substitute 'scheme-indent-function 2)) + (eval . (put 'mlambda 'scheme-indent-function 1)) + (eval . (put 'mlambdaq 'scheme-indent-function 1)) (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) (eval . (put 'with-monad 'scheme-indent-function 1)) (eval . (put 'mbegin 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index c13d0df8a4..360c356f10 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès # Copyright © 2013 Andreas Enge # Copyright © 2015 Alex Kost # Copyright © 2016 Mathieu Lirzin @@ -39,6 +39,7 @@ MODULES = \ guix/pk-crypto.scm \ guix/pki.scm \ guix/combinators.scm \ + guix/memoization.scm \ guix/utils.scm \ guix/sets.scm \ guix/modules.scm \ diff --git a/gnu/packages.scm b/gnu/packages.scm index f55c294a18..ec2473422f 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2016 Alex Kost @@ -24,6 +24,7 @@ #:use-module (guix packages) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix memoization) #:use-module (guix combinators) #:use-module ((guix build utils) #:select ((package-name->name+version diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index dd922c3ae4..7cde51fff8 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2014, 2015 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -28,7 +28,7 @@ #:use-module ((guix store) #:select (add-to-store add-text-to-store)) #:use-module ((guix derivations) #:select (derivation)) #:use-module ((guix utils) #:select (gnu-triplet->nix-system)) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index f6df183da4..f05ddf91f5 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +19,7 @@ (define-module (guix build-system gnu) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index d4d3d28f2a..bfe0eca9f6 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; @@ -21,7 +21,7 @@ (define-module (guix build-system python) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) diff --git a/guix/combinators.scm b/guix/combinators.scm index 9e4689ba9c..11cad62ccf 100644 --- a/guix/combinators.scm +++ b/guix/combinators.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2014 Eric Bavier ;;; ;;; This file is part of GNU Guix. @@ -20,8 +20,7 @@ (define-module (guix combinators) #:use-module (ice-9 match) #:use-module (ice-9 vlist) - #:export (memoize - fold2 + #:export (fold2 fold-tree fold-tree-leaves compile-time-value)) @@ -33,19 +32,6 @@ ;;; ;;; Code: -(define (memoize proc) - "Return a memoizing version of PROC." - (let ((cache (make-hash-table))) - (lambda args - (let ((results (hash-ref cache args))) - (if results - (apply values results) - (let ((results (call-with-values (lambda () - (apply proc args)) - list))) - (hash-set! cache args results) - (apply values results))))))) - (define fold2 (case-lambda ((proc seed1 seed2 lst) diff --git a/guix/derivations.scm b/guix/derivations.scm index b712c508e5..056b1163b4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -31,6 +31,7 @@ #:use-module (ice-9 vlist) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix memoization) #:use-module (guix combinators) #:use-module (guix monads) #:use-module (guix hash) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index e4151c652c..05ea19236b 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -30,7 +30,7 @@ #:use-module (guix http-client) #:use-module (guix ftp-client) #:use-module (guix utils) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 463a25514e..40cdea029b 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016 Ricardo Wurmus -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,7 +27,7 @@ #:use-module (srfi srfi-41) #:use-module (ice-9 receive) #:use-module (web uri) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (guix http-client) #:use-module (guix hash) #:use-module (guix store) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 96cf5bbae6..c0b0c415cf 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,7 +35,6 @@ #:use-module (guix base32) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module ((guix combinators) #:select (memoize)) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package %elpa-updater)) diff --git a/guix/memoization.scm b/guix/memoization.scm new file mode 100644 index 0000000000..d64f60fe9c --- /dev/null +++ b/guix/memoization.scm @@ -0,0 +1,114 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix memoization) + #:export (memoize + mlambda + mlambdaq)) + +(define-syntax-rule (call/mv thunk) + (call-with-values thunk list)) +(define-syntax-rule (return/mv lst) + (apply values lst)) + +(define-syntax-rule (call/1 thunk) + (thunk)) +(define-syntax-rule (return/1 value) + value) + +(define %nothing ;nothingness + (list 'this 'is 'nothing)) + +(define-syntax define-cache-procedure + (syntax-rules () + "Define a procedure NAME that implements a cache using HASH-REF and +HASH-SET!. Use CALL to invoke the thunk and RETURN to return its value; CALL +and RETURN are used to distinguish between multiple-value and single-value +returns." + ((_ name hash-ref hash-set! call return) + (define (name cache key thunk) + "Cache the result of THUNK under KEY in CACHE, or return the +already-cached result." + (let ((results (hash-ref cache key %nothing))) + (if (eq? results %nothing) + (let ((results (call thunk))) + (hash-set! cache key results) + (return results)) + (return results))))) + ((_ name hash-ref hash-set!) + (define-cache-procedure name hash-ref hash-set! + call/mv return/mv)))) + +(define-cache-procedure cached/mv hash-ref hash-set!) +(define-cache-procedure cachedq/mv hashq-ref hashq-set!) +(define-cache-procedure cached hash-ref hash-set! call/1 return/1) +(define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1) + +(define (memoize proc) + "Return a memoizing version of PROC. + +This is a generic version of 'mlambda' what works regardless of the arity of +'proc'. It is more expensive since the argument list is always allocated, and +the result is returned via (apply values results)." + (let ((cache (make-hash-table))) + (lambda args + (cached/mv cache args + (lambda () + (apply proc args)))))) + +(define-syntax %mlambda + (syntax-rules () + "Return a memoizing lambda. This is restricted to procedures that return +exactly one value." + ((_ cached () body ...) + ;; The zero-argument case is equivalent to a promise. + (let ((result #f) (cached? #f)) + (lambda () + (unless cached? + (set! result (begin body ...)) + (set! cached? #t)) + result))) + + ;; Optimize the fixed-arity case such that there's no argument list + ;; allocated. XXX: We can't really avoid the closure allocation since + ;; Guile 2.0's compiler will always keep it. + ((_ cached (arg) body ...) ;one argument + (let ((cache (make-hash-table)) + (proc (lambda (arg) body ...))) + (lambda (arg) + (cached cache arg (lambda () (proc arg)))))) + ((_ _ (args ...) body ...) ;two or more arguments + (let ((cache (make-hash-table)) + (proc (lambda (args ...) body ...))) + (lambda (args ...) + ;; XXX: Always use 'cached', which uses 'equal?', to compare the + ;; argument lists. + (cached cache (list args ...) + (lambda () + (proc args ...)))))))) + +(define-syntax-rule (mlambda formals body ...) + "Define a memoizing lambda. The lambda's arguments are compared with +'equal?', and BODY is expected to yield a single return value." + (%mlambda cached formals body ...)) + +(define-syntax-rule (mlambdaq formals body ...) + "Define a memoizing lambda. If FORMALS lists a single argument, it is +compared using 'eq?'; otherwise, the argument list is compared using 'equal?'. +BODY is expected to yield a single return value." + (%mlambda cachedq formals body ...)) diff --git a/guix/modules.scm b/guix/modules.scm index 24f613ff4e..2ff94007b5 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix modules) - #:use-module ((guix utils) #:select (memoize)) + #:use-module (guix memoization) #:use-module (guix sets) #:use-module (srfi srfi-26) #:use-module (ice-9 match) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index d7d71b7ab9..68402fda18 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -24,7 +24,6 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix grafts) - #:use-module (guix combinators) ;; Use the procedure that destructures "NAME-VERSION" forms. #:use-module ((guix utils) #:hide (package-name->name+version)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 79ce503a2e..8c82d8978c 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,12 +21,12 @@ #:use-module (guix graph) #:use-module (guix grafts) #:use-module (guix scripts) - #:use-module (guix combinators) #:use-module (guix packages) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix derivations) + #:use-module (guix memoization) #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index afc1369ad1..cb64dc8b2b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -32,7 +32,7 @@ #:use-module (guix records) #:use-module (guix ui) #:use-module (guix utils) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (guix scripts) #:use-module (guix gnu-maintenance) #:use-module (guix monads) diff --git a/guix/store.scm b/guix/store.scm index 7152a5556a..491cd5ac06 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -19,7 +19,7 @@ (define-module (guix store) #:use-module (guix utils) #:use-module (guix config) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix monads) #:autoload (guix base32) (bytevector->base32-string) diff --git a/guix/utils.scm b/guix/utils.scm index ee06e47fe9..8aa2cb734d 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -33,7 +33,7 @@ #:use-module (ice-9 binary-ports) #:autoload (rnrs io ports) (make-custom-binary-input-port) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) - #:use-module (guix combinators) + #:use-module (guix memoization) #:use-module ((guix build utils) #:select (dump-port)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module (ice-9 vlist) -- cgit v1.2.3 From 55b2d921456e888f097bf4e43a3d25b112f3e563 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Jan 2017 17:09:34 +0100 Subject: Use 'mlambda' instead of 'memoize'. * gnu/packages.scm (find-newest-available-packages): Use 'mlambda' instead of (memoize (lambda ...) ...). * gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Likewise. * guix/build-system/gnu.scm (package-with-explicit-inputs)[rewritten-input]: Likewise. * guix/build-system/python.scm (package-with-explicit-python)[transform]: Likewise. * guix/derivations.scm (derivation->string): Likewise. * guix/gnu-maintenance.scm (gnu-package?): Likewise. * guix/modules.scm (module-file-dependencies): Likewise. * guix/scripts/graph.scm (standard-package-set): Likewise. * guix/scripts/lint.scm (official-gnu-packages*): Likewise. * guix/store.scm (store-regexp*): Likewise. * guix/utils.scm (location): Likewise. --- gnu/packages.scm | 31 ++++++++-------- gnu/packages/bootstrap.scm | 35 +++++++++--------- guix/build-system/gnu.scm | 47 ++++++++++++----------- guix/build-system/python.scm | 85 +++++++++++++++++++++--------------------- guix/derivations.scm | 88 ++++++++++++++++++++++---------------------- guix/gnu-maintenance.scm | 83 +++++++++++++++++++++-------------------- guix/modules.scm | 21 +++++------ guix/scripts/graph.scm | 11 +++--- guix/scripts/lint.scm | 9 ++--- guix/store.scm | 9 ++--- guix/utils.scm | 9 ++--- 11 files changed, 208 insertions(+), 220 deletions(-) (limited to 'guix') diff --git a/gnu/packages.scm b/gnu/packages.scm index ec2473422f..0aa289d56c 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -235,28 +235,27 @@ decreasing version order." matching))))) (define find-newest-available-packages - (memoize - (lambda () - "Return a vhash keyed by package names, and with + (mlambda () + "Return a vhash keyed by package names, and with associated values of the form (newest-version newest-package ...) where the preferred package is listed first." - ;; FIXME: Currently, the preferred package is whichever one - ;; was found last by 'fold-packages'. Find a better solution. - (fold-packages (lambda (p r) - (let ((name (package-name p)) - (version (package-version p))) - (match (vhash-assoc name r) - ((_ newest-so-far . pkgs) - (case (version-compare version newest-so-far) - ((>) (vhash-cons name `(,version ,p) r)) - ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) - ((<) r))) - (#f (vhash-cons name `(,version ,p) r))))) - vlist-null)))) + ;; FIXME: Currently, the preferred package is whichever one + ;; was found last by 'fold-packages'. Find a better solution. + (fold-packages (lambda (p r) + (let ((name (package-name p)) + (version (package-version p))) + (match (vhash-assoc name r) + ((_ newest-so-far . pkgs) + (case (version-compare version newest-so-far) + ((>) (vhash-cons name `(,version ,p) r)) + ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) + ((<) r))) + (#f (vhash-cons name `(,version ,p) r))))) + vlist-null))) (define (find-best-packages-by-name name version) "If version is #f, return the list of packages named NAME with the highest diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 7cde51fff8..c8d94c8303 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -131,30 +131,29 @@ successful, or false to signal an error." (license gpl3+))) (define package-with-bootstrap-guile - (memoize - (lambda (p) + (mlambda (p) "Return a variant of P such that all its origins are fetched with %BOOTSTRAP-GUILE." (define rewritten-input (match-lambda - ((name (? origin? o)) - `(,name ,(bootstrap-origin o))) - ((name (? package? p) sub-drvs ...) - `(,name ,(package-with-bootstrap-guile p) ,@sub-drvs)) - (x x))) + ((name (? origin? o)) + `(,name ,(bootstrap-origin o))) + ((name (? package? p) sub-drvs ...) + `(,name ,(package-with-bootstrap-guile p) ,@sub-drvs)) + (x x))) (package (inherit p) - (source (match (package-source p) - ((? origin? o) (bootstrap-origin o)) - (s s))) - (inputs (map rewritten-input - (package-inputs p))) - (native-inputs (map rewritten-input - (package-native-inputs p))) - (propagated-inputs (map rewritten-input - (package-propagated-inputs p))) - (replacement (and=> (package-replacement p) - package-with-bootstrap-guile)))))) + (source (match (package-source p) + ((? origin? o) (bootstrap-origin o)) + (s s))) + (inputs (map rewritten-input + (package-inputs p))) + (native-inputs (map rewritten-input + (package-native-inputs p))) + (propagated-inputs (map rewritten-input + (package-propagated-inputs p))) + (replacement (and=> (package-replacement p) + package-with-bootstrap-guile))))) (define* (glibc-dynamic-linker #:optional (system (or (and=> (%current-target-system) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index f05ddf91f5..730e638c89 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -84,15 +84,15 @@ builder, or the distro's final Guile when GUILE is #f." (let loop ((p p)) (define rewritten-input - (memoize - (match-lambda - ((name (? package? p) sub-drv ...) - ;; XXX: Check whether P's build system knows #:implicit-inputs, for - ;; things like `cross-pkg-config'. - (if (eq? (package-build-system p) gnu-build-system) - (cons* name (loop p) sub-drv) - (cons* name p sub-drv))) - (x x)))) + (mlambda (input) + (match input + ((name (? package? p) sub-drv ...) + ;; XXX: Check whether P's build system knows #:implicit-inputs, for + ;; things like `cross-pkg-config'. + (if (eq? (package-build-system p) gnu-build-system) + (cons* name (loop p) sub-drv) + (cons* name p sub-drv))) + (x x)))) (package (inherit p) (location (if (pair? loc) (source-properties->location loc) loc)) @@ -393,22 +393,21 @@ packages that must not be referenced." ;;; (define standard-cross-packages - (memoize - (lambda (target kind) - "Return the list of name/package tuples to cross-build for TARGET. KIND + (mlambda (target kind) + "Return the list of name/package tuples to cross-build for TARGET. KIND is one of `host' or `target'." - (let* ((cross (resolve-interface '(gnu packages cross-base))) - (gcc (module-ref cross 'cross-gcc)) - (binutils (module-ref cross 'cross-binutils)) - (libc (module-ref cross 'cross-libc))) - (case kind - ((host) - `(("cross-gcc" ,(gcc target - (binutils target) - (libc target))) - ("cross-binutils" ,(binutils target)))) - ((target) - `(("cross-libc" ,(libc target))))))))) + (let* ((cross (resolve-interface '(gnu packages cross-base))) + (gcc (module-ref cross 'cross-gcc)) + (binutils (module-ref cross 'cross-binutils)) + (libc (module-ref cross 'cross-libc))) + (case kind + ((host) + `(("cross-gcc" ,(gcc target + (binutils target) + (libc target))) + ("cross-binutils" ,(binutils target)))) + ((target) + `(("cross-libc" ,(libc target)))))))) (define* (gnu-cross-build store name #:key diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index bfe0eca9f6..383e8cb64a 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -87,49 +87,48 @@ pre-defined variants." ;; Memoize the transformations. Failing to do that, we would build a huge ;; object graph with lots of duplicates, which in turns prevents us from ;; benefiting from memoization in 'package-derivation'. - (memoize ;FIXME: use 'eq?' - (lambda (p) - (let* ((rewrite-if-package - (lambda (content) - ;; CONTENT may be a file name, in which case it is returned, - ;; or a package, which is rewritten with the new PYTHON and - ;; NEW-PREFIX. - (if (package? content) - (transform content) - content))) - (rewrite - (match-lambda - ((name content . rest) - (append (list name (rewrite-if-package content)) rest))))) - - (cond - ;; If VARIANT-PROPERTY is present, use that. - ((and variant-property - (assoc-ref (package-properties p) variant-property)) - => force) - - ;; Otherwise build the new package object graph. - ((eq? (package-build-system p) python-build-system) - (package - (inherit p) - (location (package-location p)) - (name (let ((name (package-name p))) - (string-append new-prefix - (if (string-prefix? old-prefix name) - (substring name - (string-length old-prefix)) - name)))) - (arguments - (let ((python (if (promise? python) - (force python) - python))) - (ensure-keyword-arguments (package-arguments p) - `(#:python ,python)))) - (inputs (map rewrite (package-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))))) - (else - p)))))) + (mlambda (p) ;XXX: use 'eq?' + (let* ((rewrite-if-package + (lambda (content) + ;; CONTENT may be a file name, in which case it is returned, + ;; or a package, which is rewritten with the new PYTHON and + ;; NEW-PREFIX. + (if (package? content) + (transform content) + content))) + (rewrite + (match-lambda + ((name content . rest) + (append (list name (rewrite-if-package content)) rest))))) + + (cond + ;; If VARIANT-PROPERTY is present, use that. + ((and variant-property + (assoc-ref (package-properties p) variant-property)) + => force) + + ;; Otherwise build the new package object graph. + ((eq? (package-build-system p) python-build-system) + (package + (inherit p) + (location (package-location p)) + (name (let ((name (package-name p))) + (string-append new-prefix + (if (string-prefix? old-prefix name) + (substring name + (string-length old-prefix)) + name)))) + (arguments + (let ((python (if (promise? python) + (force python) + python))) + (ensure-keyword-arguments (package-arguments p) + `(#:python ,python)))) + (inputs (map rewrite (package-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))))) + (else + p))))) transform) diff --git a/guix/derivations.scm b/guix/derivations.scm index 056b1163b4..47a783f42f 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -557,12 +557,11 @@ that form." (display ")" port)))) (define derivation->string - (memoize - (lambda (drv) - "Return the external representation of DRV as a string." - (with-fluids ((%default-port-encoding "UTF-8")) - (call-with-output-string - (cut write-derivation drv <>)))))) + (mlambda (drv) + "Return the external representation of DRV as a string." + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-output-string + (cut write-derivation drv <>))))) (define* (derivation->output-path drv #:optional (output "out")) "Return the store path of its output OUTPUT. Raise a @@ -584,12 +583,14 @@ DRV." (define derivation-path->output-path ;; This procedure is called frequently, so memoize it. - (memoize - (lambda* (path #:optional (output "out")) - "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store + (let ((memoized (mlambda (path output) + (derivation->output-path (call-with-input-file path + read-derivation) + output)))) + (lambda* (path #:optional (output "out")) + "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store path of its output OUTPUT." - (derivation->output-path (call-with-input-file path read-derivation) - output)))) + (memoized path output)))) (define (derivation-path->output-paths path) "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the @@ -616,23 +617,21 @@ in SIZE bytes." (loop (+ 1 i)))))) (define derivation-path->base16-hash - (memoize - (lambda (file) - "Return a string containing the base16 representation of the hash of the + (mlambda (file) + "Return a string containing the base16 representation of the hash of the derivation at FILE." - (call-with-input-file file - (compose bytevector->base16-string - derivation-hash - read-derivation))))) + (call-with-input-file file + (compose bytevector->base16-string + derivation-hash + read-derivation)))) (define derivation-hash ; `hashDerivationModulo' in derivations.cc - (memoize - (lambda (drv) + (mlambda (drv) "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." (match drv (($ ((_ . ($ path - (? symbol? hash-algo) (? bytevector? hash) - (? boolean? recursive?))))) + (? symbol? hash-algo) (? bytevector? hash) + (? boolean? recursive?))))) ;; A fixed-output derivation. (sha256 (string->utf8 @@ -642,14 +641,14 @@ derivation at FILE." ":" (bytevector->base16-string hash) ":" path)))) (($ outputs inputs sources - system builder args env-vars) + system builder args env-vars) ;; A regular derivation: replace the path of each input with that ;; input's hash; return the hash of serialization of the resulting ;; derivation. (let* ((inputs (map (match-lambda - (($ path sub-drvs) - (let ((hash (derivation-path->base16-hash path))) - (make-derivation-input hash sub-drvs)))) + (($ path sub-drvs) + (let ((hash (derivation-path->base16-hash path))) + (make-derivation-input hash sub-drvs)))) inputs)) (drv (make-derivation outputs (sort (coalesce-duplicate-inputs inputs) @@ -662,7 +661,7 @@ derivation at FILE." ;; the SHA256 port's `write' method gets called for every single ;; character. (sha256 - (string->utf8 (derivation->string drv))))))))) + (string->utf8 (derivation->string drv)))))))) (define (store-path type hash name) ; makeStorePath "Return the store path for NAME/HASH/TYPE." @@ -916,18 +915,17 @@ recursively." (define rewritten-input ;; Rewrite the given input according to MAPPING, and return an input ;; in the format used in 'derivation' calls. - (memoize - (lambda (input loop) - (match input - (($ path (sub-drvs ...)) - (match (vhash-assoc path mapping) - ((_ . (? derivation? replacement)) - (cons replacement sub-drvs)) - ((_ . replacement) - (list replacement)) - (#f - (let* ((drv (loop (call-with-input-file path read-derivation)))) - (cons drv sub-drvs))))))))) + (mlambda (input loop) + (match input + (($ path (sub-drvs ...)) + (match (vhash-assoc path mapping) + ((_ . (? derivation? replacement)) + (cons replacement sub-drvs)) + ((_ . replacement) + (list replacement)) + (#f + (let* ((drv (loop (call-with-input-file path read-derivation)))) + (cons drv sub-drvs)))))))) (let loop ((drv drv)) (let* ((inputs (map (cut rewritten-input <> loop) @@ -1058,13 +1056,13 @@ system, imported, and appears under FINAL-PATH in the resulting store path." (define search-path* ;; A memoizing version of 'search-path' so 'imported-modules' does not end ;; up looking for the same files over and over again. - (memoize (lambda (path file) - "Search for FILE in PATH and memoize the result. Raise a + (mlambda (path file) + "Search for FILE in PATH and memoize the result. Raise a '&file-search-error' condition if it could not be found." - (or (search-path path file) - (raise (condition - (&file-search-error (file file) - (path path)))))))) + (or (search-path path file) + (raise (condition + (&file-search-error (file file) + (path path))))))) (define (module->source-file-name module) "Return the file name corresponding to MODULE, a Guile module name (a list diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 05ea19236b..012f587525 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -165,49 +165,48 @@ found." (official-gnu-packages))) (define gnu-package? - (memoize - (let ((official-gnu-packages (memoize official-gnu-packages))) - (lambda (package) - "Return true if PACKAGE is a GNU package. This procedure may access the + (let ((official-gnu-packages (memoize official-gnu-packages))) + (mlambda (package) + "Return true if PACKAGE is a GNU package. This procedure may access the network to check in GNU's database." - (define (mirror-type url) - (let ((uri (string->uri url))) - (and (eq? (uri-scheme uri) 'mirror) - (cond - ((member (uri-host uri) - '("gnu" "gnupg" "gcc" "gnome")) - ;; Definitely GNU. - 'gnu) - ((equal? (uri-host uri) "cran") - ;; Possibly GNU: mirror://cran could be either GNU R itself - ;; or a non-GNU package. - #f) - (else - ;; Definitely non-GNU. - 'non-gnu))))) - - (define (gnu-home-page? package) - (letrec-syntax ((>> (syntax-rules () - ((_ value proc) - (and=> value proc)) - ((_ value proc rest ...) - (and=> value - (lambda (next) - (>> (proc next) rest ...))))))) - (>> package package-home-page - string->uri uri-host - (lambda (host) - (member host '("www.gnu.org" "gnu.org")))))) - - (or (gnu-home-page? package) - (let ((url (and=> (package-source package) origin-uri)) - (name (package-upstream-name package))) - (case (and (string? url) (mirror-type url)) - ((gnu) #t) - ((non-gnu) #f) - (else - (and (member name (map gnu-package-name (official-gnu-packages))) - #t))))))))) + (define (mirror-type url) + (let ((uri (string->uri url))) + (and (eq? (uri-scheme uri) 'mirror) + (cond + ((member (uri-host uri) + '("gnu" "gnupg" "gcc" "gnome")) + ;; Definitely GNU. + 'gnu) + ((equal? (uri-host uri) "cran") + ;; Possibly GNU: mirror://cran could be either GNU R itself + ;; or a non-GNU package. + #f) + (else + ;; Definitely non-GNU. + 'non-gnu))))) + + (define (gnu-home-page? package) + (letrec-syntax ((>> (syntax-rules () + ((_ value proc) + (and=> value proc)) + ((_ value proc rest ...) + (and=> value + (lambda (next) + (>> (proc next) rest ...))))))) + (>> package package-home-page + string->uri uri-host + (lambda (host) + (member host '("www.gnu.org" "gnu.org")))))) + + (or (gnu-home-page? package) + (let ((url (and=> (package-source package) origin-uri)) + (name (package-upstream-name package))) + (case (and (string? url) (mirror-type url)) + ((gnu) #t) + ((non-gnu) #f) + (else + (and (member name (map gnu-package-name (official-gnu-packages))) + #t)))))))) ;;; diff --git a/guix/modules.scm b/guix/modules.scm index 2ff94007b5..8c63f21a97 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -71,18 +71,17 @@ CLAUSES." result))))) (define module-file-dependencies - (memoize - (lambda (file) - "Return the list of the names of modules that the Guile module in FILE + (mlambda (file) + "Return the list of the names of modules that the Guile module in FILE depends on." - (call-with-input-file file - (lambda (port) - (match (read port) - (('define-module name clauses ...) - (extract-dependencies clauses)) - ;; XXX: R6RS 'library' form is ignored. - (_ - '()))))))) + (call-with-input-file file + (lambda (port) + (match (read port) + (('define-module name clauses ...) + (extract-dependencies clauses)) + ;; XXX: R6RS 'library' form is ignored. + (_ + '())))))) (define (module-name->file-name module) "Return the file name for MODULE." diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 8c82d8978c..9804d41929 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -191,12 +191,11 @@ Dependencies may include packages, origin, and file names." %store-monad)))) (define standard-package-set - (memoize - (lambda () - "Return the set of standard packages provided by GNU-BUILD-SYSTEM." - (match (standard-packages) - (((labels packages . output) ...) - (list->setq packages)))))) + (mlambda () + "Return the set of standard packages provided by GNU-BUILD-SYSTEM." + (match (standard-packages) + (((labels packages . output) ...) + (list->setq packages))))) (define (bag-node-edges-sans-bootstrap thing) "Like 'bag-node-edges', but pretend that the standard packages of diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index cb64dc8b2b..0b38aac319 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -559,12 +559,11 @@ patch could not be found." str))) (define official-gnu-packages* - (memoize - (lambda () - "A memoizing version of 'official-gnu-packages' that returns the empty + (mlambda () + "A memoizing version of 'official-gnu-packages' that returns the empty list when something goes wrong, such as a networking issue." - (let ((gnus (false-if-exception (official-gnu-packages)))) - (or gnus '()))))) + (let ((gnus (false-if-exception (official-gnu-packages)))) + (or gnus '())))) (define (check-gnu-synopsis+description package) "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and diff --git a/guix/store.scm b/guix/store.scm index 491cd5ac06..cb3fbed912 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1282,11 +1282,10 @@ valid inputs." (define store-regexp* ;; The substituter makes repeated calls to 'store-path-hash-part', hence ;; this optimization. - (memoize - (lambda (store) - "Return a regexp matching a file in STORE." - (make-regexp (string-append "^" (regexp-quote store) - "/([0-9a-df-np-sv-z]{32})-([^/]+)$"))))) + (mlambda (store) + "Return a regexp matching a file in STORE." + (make-regexp (string-append "^" (regexp-quote store) + "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))) (define (store-path-package-name path) "Return the package name part of PATH, a file name in the store." diff --git a/guix/utils.scm b/guix/utils.scm index 8aa2cb734d..72dc0687a4 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -771,11 +771,10 @@ be determined." (column location-column)) ; 0-indexed column (define location - (memoize - (lambda (file line column) - "Return the object for the given FILE, LINE, and COLUMN." - (and line column file - (make-location file line column))))) + (mlambda (file line column) + "Return the object for the given FILE, LINE, and COLUMN." + (and line column file + (make-location file line column)))) (define (source-properties->location loc) "Return a location object based on the info in LOC, an alist as returned -- cgit v1.2.3 From c9134e82fe0332787468dcd27f18bdc8609738fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Jan 2017 17:15:27 +0100 Subject: packages: Remove 'define-memoized/v' and use 'mlambdaq' instead. * guix/packages.scm (define-memoized/v): Remove. (package-transitive-supported-systems): Use 'mlambdaq' instead of 'define-memoized/v'. (package-input-rewriting)[replace]: Likewise. --- guix/packages.scm | 61 ++++++++++++++++++++----------------------------------- 1 file changed, 22 insertions(+), 39 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index defde2478a..4bc4b017f4 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,6 +28,7 @@ #:use-module (guix base32) #:use-module (guix grafts) #:use-module (guix derivations) + #:use-module (guix memoization) #:use-module (guix build-system) #:use-module (guix search-paths) #:use-module (guix gexp) @@ -697,38 +698,19 @@ in INPUTS and their transitive propagated inputs." `(assoc-ref ,alist ,(label input))) (transitive-inputs inputs))) -(define-syntax define-memoized/v - (lambda (form) - "Define a memoized single-valued unary procedure with docstring. -The procedure argument is compared to cached keys using `eqv?'." - (syntax-case form () - ((_ (proc arg) docstring body body* ...) - (string? (syntax->datum #'docstring)) - #'(define proc - (let ((cache (make-hash-table))) - (define (proc arg) - docstring - (match (hashv-get-handle cache arg) - ((_ . value) - value) - (_ - (let ((result (let () body body* ...))) - (hashv-set! cache arg result) - result)))) - proc)))))) - -(define-memoized/v (package-transitive-supported-systems package) - "Return the intersection of the systems supported by PACKAGE and those +(define package-transitive-supported-systems + (mlambdaq (package) + "Return the intersection of the systems supported by PACKAGE and those supported by its dependencies." - (fold (lambda (input systems) - (match input - ((label (? package? p) . _) - (lset-intersection - string=? systems (package-transitive-supported-systems p))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package)))) + (fold (lambda (input systems) + (match input + ((label (? package? p) . _) + (lset-intersection + string=? systems (package-transitive-supported-systems p))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package))))) (define* (supported-package? package #:optional (system (%current-system))) "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its @@ -775,14 +757,15 @@ package and returns its new name after rewrite." (_ input))) - (define-memoized/v (replace p) - "Return a variant of P with its inputs rewritten." - (package - (inherit p) - (name (rewrite-name (package-name p))) - (inputs (map rewrite (package-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))))) + (define replace + (mlambdaq (p) + ;; Return a variant of P with its inputs rewritten. + (package + (inherit p) + (name (rewrite-name (package-name p))) + (inputs (map rewrite (package-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p)))))) replace) -- cgit v1.2.3 From 3d520b542855e7e3bdf42235253a14cbc55178dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Jan 2017 17:17:13 +0100 Subject: gnu-maintenance: 'gnu-package?' uses 'eq?' memoization. * guix/gnu-maintenance.scm (gnu-package?): Use 'mlambdaq' instead of 'mlambda'. --- guix/gnu-maintenance.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 012f587525..07e6909641 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -166,7 +166,7 @@ found." (define gnu-package? (let ((official-gnu-packages (memoize official-gnu-packages))) - (mlambda (package) + (mlambdaq (package) "Return true if PACKAGE is a GNU package. This procedure may access the network to check in GNU's database." (define (mirror-type url) -- cgit v1.2.3 From 86a6ff4bb04963bd16e22a7c8133a82dd0af1014 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Jan 2017 18:51:19 +0100 Subject: build-system/python: 'package-with-explicit-python' uses 'eq?' memoization. * guix/build-system/python.scm (package-with-explicit-python): Use 'mlambdaq' instead of 'mlambda'. This does not change the graph and has no visible impact on performance. --- guix/build-system/python.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 383e8cb64a..17173f121e 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -87,7 +87,7 @@ pre-defined variants." ;; Memoize the transformations. Failing to do that, we would build a huge ;; object graph with lots of duplicates, which in turns prevents us from ;; benefiting from memoization in 'package-derivation'. - (mlambda (p) ;XXX: use 'eq?' + (mlambdaq (p) (let* ((rewrite-if-package (lambda (content) ;; CONTENT may be a file name, in which case it is returned, -- cgit v1.2.3 From 0d268c5d701423b770b05ed208461c47709dafb7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Jan 2017 12:55:24 +0100 Subject: store: Add 'add-data-to-store'. * guix/serialization.scm (write-bytevector): New procedure. (write-string): Rewrite in terms of 'write-bytevector'. * guix/store.scm (write-arg): Add 'bytevector' case. (add-data-to-store): New procedure, from former 'add-text-to-store'. (add-text-to-store): Rewrite in terms of 'add-data-to-store'. * tests/store.scm ("add-data-to-store"): New test. --- guix/serialization.scm | 12 +++++++----- guix/store.scm | 26 ++++++++++++++++++-------- tests/store.scm | 5 +++++ 3 files changed, 30 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/serialization.scm b/guix/serialization.scm index 5953b84616..4cab5910f7 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,7 +30,7 @@ #:export (write-int read-int write-long-long read-long-long write-padding - write-string + write-bytevector write-string read-string read-latin1-string read-maybe-utf8-string write-string-list read-string-list write-string-pairs @@ -102,15 +102,17 @@ (or (zero? m) (put-bytevector p zero 0 (- 8 m))))))) -(define (write-string s p) - (let* ((s (string->utf8 s)) - (l (bytevector-length s)) +(define (write-bytevector s p) + (let* ((l (bytevector-length s)) (m (modulo l 8)) (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) (bytevector-u32-set! b 0 l (endianness little)) (bytevector-copy! s 0 b 8 l) (put-bytevector p b))) +(define (write-string s p) + (write-bytevector (string->utf8 s) p)) + (define (read-byte-string p) (let* ((len (read-int p)) (m (modulo len 8)) diff --git a/guix/store.scm b/guix/store.scm index cb3fbed912..cce460f3ce 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -67,6 +67,7 @@ query-path-hash hash-part->path query-path-info + add-data-to-store add-text-to-store add-to-store build-things @@ -266,12 +267,15 @@ (path-info deriver hash refs registration-time nar-size))) (define-syntax write-arg - (syntax-rules (integer boolean string string-list string-pairs + (syntax-rules (integer boolean bytevector + string string-list string-pairs store-path store-path-list base16) ((_ integer arg p) (write-int arg p)) ((_ boolean arg p) (write-int (if arg 1 0) p)) + ((_ bytevector arg p) + (write-bytevector arg p)) ((_ string arg p) (write-string arg p)) ((_ string-list arg p) @@ -669,25 +673,31 @@ string). Raise an error if no such path exists." "Return the info (hash, references, etc.) for PATH." path-info) -(define add-text-to-store +(define add-data-to-store ;; A memoizing version of `add-to-store', to avoid repeated RPCs with ;; the very same arguments during a given session. (let ((add-text-to-store - (operation (add-text-to-store (string name) (string text) + (operation (add-text-to-store (string name) (bytevector text) (string-list references)) #f store-path))) - (lambda* (server name text #:optional (references '())) - "Add TEXT under file NAME in the store, and return its store path. + (lambda* (server name bytes #:optional (references '())) + "Add BYTES under file NAME in the store, and return its store path. REFERENCES is the list of store paths referred to by the resulting store path." - (let ((args `(,text ,name ,references)) - (cache (nix-server-add-text-to-store-cache server))) + (let* ((args `(,bytes ,name ,references)) + (cache (nix-server-add-text-to-store-cache server))) (or (hash-ref cache args) - (let ((path (add-text-to-store server name text references))) + (let ((path (add-text-to-store server name bytes references))) (hash-set! cache args path) path)))))) +(define* (add-text-to-store store name text #:optional (references '())) + "Add TEXT under file NAME in the store, and return its store path. +REFERENCES is the list of store paths referred to by the resulting store +path." + (add-data-to-store store name (string->utf8 text) references)) + (define true ;; Define it once and for all since we use it as a default value for ;; 'add-to-store' and want to make sure two default values are 'eq?' for the diff --git a/tests/store.scm b/tests/store.scm index 983766d862..64d3553f25 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -92,6 +92,11 @@ (test-skip (if %store 0 13)) +(test-equal "add-data-to-store" + #vu8(1 2 3 4 5) + (call-with-input-file (add-data-to-store %store "data" #vu8(1 2 3 4 5)) + get-bytevector-all)) + (test-assert "valid-path? live" (let ((p (add-text-to-store %store "hello" "hello, world"))) (valid-path? %store p))) -- cgit v1.2.3 From c003546b0c2a7a61958f5bfac04b25020d41e402 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jan 2017 06:26:30 +0000 Subject: environment: Fix setting writable? on networking related files MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/environment.scm (launch-environment/container): Include the file name in the call to string=? when deciding if the file should be writable. Signed-off-by: Ludovic Courtès --- guix/scripts/environment.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index a08367d1b1..8a3a935a10 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -421,7 +421,8 @@ host file systems to mount inside the container." ;; read-only within the ;; container. (writable? - (string=? "/etc/resolv.conf"))))) + (string=? file + "/etc/resolv.conf"))))) %network-configuration-files) '()) ;; Mappings for the union closure of all inputs. -- cgit v1.2.3 From f1a892c96f15f834f498a35cfa7b36069c640f52 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 Jan 2017 23:51:09 +0100 Subject: lint: Use the "@" syntax for versioned packages in warnings. * guix/scripts/lint.scm (emit-warning): Use the "@" syntax. --- guix/scripts/lint.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 0b38aac319..776e7332c5 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -90,9 +90,9 @@ ;; provided MESSAGE. (let ((loc (or (package-field-location package field) (package-location package)))) - (format (guix-warning-port) "~a: ~a: ~a~%" + (format (guix-warning-port) "~a: ~a@~a: ~a~%" (location->string loc) - (package-full-name package) + (package-name package) (package-version package) message))) (define (call-with-accumulated-warnings thunk) -- cgit v1.2.3 From 58f91e4d03e102058fc0f8a859cb144c40c6a1d0 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Fri, 27 Jan 2017 20:48:37 +0100 Subject: download: url-fetch/tarball: Make ‘name’ truly optional. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/download.scm (url-fetch/tarbomb): Fall back to ‘file-name’ if ‘name’ is #f, like the regular ‘url-fetch’ does. * gnu/packages/bioinformatics.scm (muscle)[source]: Remove ‘file-name’. * gnu/packages/engineering.scm (fastcap)[source]: Likewise. * gnu/packages/scheme.scm (scmutils)[source]: Likewise. --- gnu/packages/bioinformatics.scm | 1 - gnu/packages/engineering.scm | 1 - gnu/packages/scheme.scm | 1 - guix/download.scm | 12 ++++++++++-- 4 files changed, 10 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm index 79d479f75a..420bbc6fc8 100644 --- a/gnu/packages/bioinformatics.scm +++ b/gnu/packages/bioinformatics.scm @@ -3501,7 +3501,6 @@ that a read originated from a particular isoform.") (version "3.8.1551") (source (origin (method url-fetch/tarbomb) - (file-name (string-append name "-" version)) (uri (string-append "http://www.drive5.com/muscle/muscle_src_" version ".tar.gz")) diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm index b147764a7d..734efcdc73 100644 --- a/gnu/packages/engineering.scm +++ b/gnu/packages/engineering.scm @@ -259,7 +259,6 @@ featuring various improvements and bug fixes."))) (version "2.0-18Sep92") (source (origin (method url-fetch/tarbomb) - (file-name (string-append name "-" version ".tar.gz")) (uri (string-append "http://www.rle.mit.edu/cpg/codes/" name "-" version ".tgz")) (sha256 diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm index 2756805f3d..1210ab526b 100644 --- a/gnu/packages/scheme.scm +++ b/gnu/packages/scheme.scm @@ -604,7 +604,6 @@ threads.") (snippet ;; Remove binary code '(delete-file-recursively "scmutils/mit-scheme")) - (file-name (string-append name "-" version ".tar.gz")) (uri (string-append "http://groups.csail.mit.edu/mac/users/gjs/6946" "/scmutils-tarballs/" name "-" version "-x86-64-gnu-linux.tar.gz")) diff --git a/guix/download.scm b/guix/download.scm index e2e5cee777..e218c2e264 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2016 Alex Griffin ;;; Copyright © 2016 David Craven +;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -485,17 +486,24 @@ in the store." (guile (default-guile))) "Similar to 'url-fetch' but unpack the file from URL in a directory of its own. This helper makes it easier to deal with \"tar bombs\"." + (define file-name + (match url + ((head _ ...) + (basename head)) + (_ + (basename url)))) (define gzip (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) (define tar (module-ref (resolve-interface '(gnu packages base)) 'tar)) (mlet %store-monad ((drv (url-fetch url hash-algo hash - (string-append "tarbomb-" name) + (string-append "tarbomb-" + (or name file-name)) #:system system #:guile guile))) ;; Take the tar bomb, and simply unpack it as a directory. - (gexp->derivation name + (gexp->derivation (or name file-name) #~(begin (mkdir #$output) (setenv "PATH" (string-append #$gzip "/bin")) -- cgit v1.2.3 From 814b099a209f335944737e701cbfcb09ac811d58 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 25 Jan 2017 13:16:00 +0100 Subject: download: Add ‘url-fetch/zipbomb’. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit From this suggestion by Ludovic Courtès: * guix/download.scm (url-fetch/zipbomb): New procedure. --- guix/download.scm | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index e218c2e264..80efb9d9f1 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -36,6 +36,7 @@ #:export (%mirrors url-fetch url-fetch/tarbomb + url-fetch/zipbomb download-to-store)) ;;; Commentary: @@ -512,6 +513,35 @@ own. This helper makes it easier to deal with \"tar bombs\"." "xf" #$drv))) #:local-build? #t))) +(define* (url-fetch/zipbomb url hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile))) + "Similar to 'url-fetch' but unpack the zip file at URL in a directory of its +own. This helper makes it easier to deal with \"zip bombs\"." + (define file-name + (match url + ((head _ ...) + (basename head)) + (_ + (basename url)))) + (define unzip + (module-ref (resolve-interface '(gnu packages zip)) 'unzip)) + + (mlet %store-monad ((drv (url-fetch url hash-algo hash + (string-append "zipbomb-" + (or name file-name)) + #:system system + #:guile guile))) + ;; Take the zip bomb, and simply unpack it as a directory. + (gexp->derivation (or name file-name) + #~(begin + (mkdir #$output) + (chdir #$output) + (zero? (system* (string-append #$unzip "/bin/unzip") + #$drv))) + #:local-build? #t))) + (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port)) recursive? (verify-certificate? #t)) -- cgit v1.2.3 From 93897a4538af1aa849f186d8d34013232c6f9666 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 1 Feb 2017 23:41:12 +0100 Subject: download: Add GNOME mirror. * guix/download.scm (%mirrors): Add "https://download.gnome.org". --- guix/download.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 80efb9d9f1..813f51f489 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -88,6 +88,7 @@ "http://ftp.belnet.be/ftp.gnome.org/" "http://ftp.linux.org.uk/mirrors/ftp.gnome.org/" "http://ftp.gnome.org/pub/GNOME/" + "https://download.gnome.org/" "http://mirror.yandex.ru/mirrors/ftp.gnome.org/") (hackage "http://hackage.haskell.org/") -- cgit v1.2.3 From de643f0c15677665acce73db9c28c5488e623633 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 1 Feb 2017 12:08:45 +0100 Subject: build: r-build-system: Use deterministic built date. Fixes . * guix/build/r-build-system.scm (install): Pass "--built-timestamp" option to make build deterministic. --- guix/build/r-build-system.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 3fc13eb835..24aa73d4f2 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ricardo Wurmus +;;; Copyright © 2015, 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,6 +84,7 @@ (params (append configure-flags (list "--install-tests" (string-append "--library=" site-library) + "--built-timestamp=1970-01-01" "."))) (site-path (string-append site-library ":" (generate-site-path inputs)))) -- cgit v1.2.3 From d2a5e6982ddcbe1e5479bda62a72b3a94570855a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Feb 2017 00:20:40 +0100 Subject: file-systems: Add 'file-system-mapping->bind-mount'. * gnu/system/file-systems.scm (file-system-mapping->bind-mount): New procedure. * gnu/system/linux-container.scm (mapping->file-system): Remove. (containerized-operating-system)[mapping->fs]: Use 'file-system-mapping->bind-mount' instead of 'mapping->file-system'. * guix/scripts/environment.scm (launch-environment/container): Likewise. --- gnu/system/file-systems.scm | 17 +++++++++++++++++ gnu/system/linux-container.scm | 21 +++------------------ guix/scripts/environment.scm | 3 ++- 3 files changed, 22 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index fa56853fd1..b2721f2389 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -63,6 +63,8 @@ file-system-mapping-target file-system-mapping-writable? + file-system-mapping->bind-mount + %store-mapping)) ;;; Commentary: @@ -352,6 +354,21 @@ TARGET in the other system." (writable? file-system-mapping-writable? ;Boolean (default #f))) +(define (file-system-mapping->bind-mount mapping) + "Return a file system that realizes MAPPING, a , using +a bind mount." + (match mapping + (($ source target writable?) + (file-system + (mount-point target) + (device source) + (type "none") + (flags (if writable? + '(bind-mount) + '(bind-mount read-only))) + (check? #f) + (create-mount-point? #t))))) + (define %store-mapping ;; Mapping of the host's store into the guest. (file-system-mapping diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 24e61c3ead..bceea41332 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,25 +30,10 @@ #:use-module (gnu services) #:use-module (gnu system) #:use-module (gnu system file-systems) - #:export (mapping->file-system - system-container + #:export (system-container containerized-operating-system container-script)) -(define (mapping->file-system mapping) - "Return a file system that realizes MAPPING." - (match mapping - (($ source target writable?) - (file-system - (mount-point target) - (device source) - (type "none") - (flags (if writable? - '(bind-mount) - '(bind-mount read-only))) - (check? #f) - (create-mount-point? #t))))) - (define (containerized-operating-system os mappings) "Return an operating system based on OS for use in a Linux container environment. MAPPINGS is a list of to realize in the @@ -66,7 +51,7 @@ containerized OS." (operating-system-file-systems os))) (define (mapping->fs fs) - (file-system (inherit (mapping->file-system fs)) + (file-system (inherit (file-system-mapping->bind-mount fs)) (needed-for-boot? #t))) (operating-system (inherit os) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 8a3a935a10..0a1205d087 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -433,7 +433,8 @@ host file systems to mount inside the container." (writable? #f))) reqs))) (file-systems (append %container-file-systems - (map mapping->file-system mappings)))) + (map file-system-mapping->bind-mount + mappings)))) (exit/status (call-with-container file-systems (lambda () -- cgit v1.2.3 From 7597478e2e731c09890b25ff0b817d2d7c45d01f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Feb 2017 15:42:00 +0100 Subject: file-systems: Add '%network-configuration-files' and '%network-file-mappings'. * gnu/system/file-systems.scm (%network-configuration-files) (%network-file-mappings): New variables. * guix/scripts/environment.scm (%network-configuration-files): Remove. (launch-environment/container): Refer to '%network-file-mappings' instead of calling 'filter-map'. --- gnu/system/file-systems.scm | 24 +++++++++++++++++++++++- guix/scripts/environment.scm | 23 +---------------------- 2 files changed, 24 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 708d53d0a1..7011a279d3 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -18,6 +18,7 @@ (define-module (gnu system file-systems) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (guix records) #:use-module ((gnu build file-systems) #:select (string->uuid uuid->string)) @@ -64,7 +65,9 @@ file-system-mapping->bind-mount - %store-mapping)) + %store-mapping + %network-configuration-files + %network-file-mappings)) ;;; Commentary: ;;; @@ -389,4 +392,23 @@ a bind mount." (target (%store-prefix)) (writable? #f))) +(define %network-configuration-files + ;; List of essential network configuration files. + '("/etc/resolv.conf" + "/etc/nsswitch.conf" + "/etc/services" + "/etc/hosts")) + +(define %network-file-mappings + ;; List of file mappings for essential network files. + (filter-map (lambda (file) + (file-system-mapping + (source file) + (target file) + ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a + ;; symlink to a file in a tmpfs which, for an unknown reason, + ;; cannot be bind mounted read-only within the container. + (writable? (string=? file "/etc/resolv.conf")))) + %network-configuration-files)) + ;;; file-systems.scm ends here diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0a1205d087..44f490043c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -60,12 +60,6 @@ directories in PROFILE, the store path of a profile." (define %default-shell (or (getenv "SHELL") "/bin/sh")) -(define %network-configuration-files - '("/etc/resolv.conf" - "/etc/nsswitch.conf" - "/etc/services" - "/etc/hosts")) - (define (purify-environment) "Unset almost all environment variables. A small number of variables such as 'HOME' and 'USER' are left untouched." @@ -408,22 +402,7 @@ host file systems to mount inside the container." ;; When in Rome, do as Nix build.cc does: Automagically ;; map common network configuration files. (if network? - (filter-map (lambda (file) - (and (file-exists? file) - (file-system-mapping - (source file) - (target file) - ;; XXX: On some GNU/Linux - ;; systems, /etc/resolv.conf is a - ;; symlink to a file in a tmpfs - ;; which, for an unknown reason, - ;; cannot be bind mounted - ;; read-only within the - ;; container. - (writable? - (string=? file - "/etc/resolv.conf"))))) - %network-configuration-files) + %network-file-mappings '()) ;; Mappings for the union closure of all inputs. (map (lambda (dir) -- cgit v1.2.3 From 06d7d1190e1101ff73351d0324ae23bbd3997795 Mon Sep 17 00:00:00 2001 From: Ying Huang Date: Wed, 8 Feb 2017 20:10:46 +0800 Subject: profiles: gtk-im-modules: Fix for gtk3. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Gtk+3 now have multiple outputs, so the gtk-query-immodules-3.0 should be find in output "bin" instead of "out". * guix/profiles.scm (gtk-im-modules): Pass the path of gtk-query-immodules-x.x as 'query' argument to the 'build' procedure. Signed-off-by: 宋文武 --- guix/profiles.scm | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 495a9e2e7c..de82eae348 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -739,7 +739,7 @@ for both major versions of GTK+." (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3")) (gtk+-2 (manifest-lookup-package manifest "gtk+" "2"))) - (define (build gtk gtk-version) + (define (build gtk gtk-version query) (let ((major (string-take gtk-version 1))) (with-imported-modules '((guix build utils) (guix build union) @@ -756,8 +756,6 @@ for both major versions of GTK+." (let* ((prefix (string-append "/lib/gtk-" #$major ".0/" #$gtk-version)) - (query (string-append #$gtk "/bin/gtk-query-immodules-" - #$major ".0")) (destdir (string-append #$output prefix)) (moddirs (cons (string-append #$gtk prefix "/immodules") (filter file-exists? @@ -768,7 +766,7 @@ for both major versions of GTK+." ;; Generate a new immodules cache file. (mkdir-p (string-append #$output prefix)) - (let ((pipe (apply open-pipe* OPEN_READ query modules)) + (let ((pipe (apply open-pipe* OPEN_READ #$query modules)) (outfile (string-append #$output prefix "/immodules-gtk" #$major ".cache"))) (dynamic-wind @@ -783,9 +781,23 @@ for both major versions of GTK+." (close-pipe pipe))))))))) ;; Don't run the hook when there's nothing to do. - (let ((gexp #~(begin - #$(if gtk+ (build gtk+ "3.0.0") #t) - #$(if gtk+-2 (build gtk+-2 "2.10.0") #t)))) + (let* ((pkg-gtk+ (module-ref ; lazy reference + (resolve-interface '(gnu packages gtk)) 'gtk+)) + (gexp #~(begin + #$(if gtk+ + (build + gtk+ "3.0.0" + ;; Use 'gtk-query-immodules-3.0' from the 'bin' + ;; output of latest gtk+ package. + #~(string-append + #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0")) + #t) + #$(if gtk+-2 + (build + gtk+-2 "2.10.0" + #~(string-append + #$gtk+-2 "/bin/gtk-query-immodules-2.0")) + #t)))) (if (or gtk+ gtk+-2) (gexp->derivation "gtk-im-modules" gexp #:local-build? #t -- cgit v1.2.3 From 4eaac4b722b180b433b75127a30b871aaf9f0913 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Feb 2017 15:58:36 +0100 Subject: import: pypi: Correctly handle multiple-URL origins. Fixes . Reported by Sergei Trofimovich . * guix/import/pypi.scm (guix-package->pypi-name)[url->pypi-name]: New procedure. Rewrite body to match lists in addition to strings. * tests/pypi.scm ("guix-package->pypi-name, several URLs"): New test. --- guix/import/pypi.scm | 13 ++++++++++--- tests/pypi.scm | 10 ++++++++++ 2 files changed, 20 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index ed0d4297a4..1e433e3fb3 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2015 Cyril Roelandt -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -89,9 +89,16 @@ package." (define (guix-package->pypi-name package) "Given a Python PACKAGE built from pypi.python.org, return the name of the package on PyPI." - (let ((source-url (and=> (package-source package) origin-uri))) + (define (url->pypi-name url) (hyphen-package-name->name+version - (basename (file-sans-extension source-url))))) + (basename (file-sans-extension url)))) + + (match (and=> (package-source package) origin-uri) + ((? string? url) + (url->pypi-name url)) + ((lst ...) + (any url->pypi-name lst)) + (#f #f))) (define (wheel-url->extracted-directory wheel-url) (match (string-split (basename wheel-url) #\-) diff --git a/tests/pypi.scm b/tests/pypi.scm index 447c23ee95..a132900566 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -22,6 +22,7 @@ #:use-module (guix base32) #:use-module (guix hash) #:use-module (guix tests) + #:use-module (guix build-system python) #:use-module ((guix build utils) #:select (delete-file-recursively which)) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -90,6 +91,15 @@ baz > 13.37") (uri "https://pypi.python.org/packages/a2/3b/4756e6a0ceb14e084042a2a65c615d68d25621c6fd446d0fc10d14c4ce7d/certbot-0.8.1.tar.gz")))))) +(test-equal "guix-package->pypi-name, several URLs" + "cram" + (guix-package->pypi-name + (dummy-package "foo" + (source + (dummy-origin + (uri (list "https://bitheap.org/cram/cram-0.7.tar.gz" + (pypi-uri "cram" "0.7")))))))) + (test-assert "pypi->guix-package" ;; Replace network resources with sample data. (mock ((guix import utils) url-fetch -- cgit v1.2.3 From 81e0bc1834490a1a8092c75a0733b15c2b407285 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sun, 5 Feb 2017 14:42:10 +0100 Subject: import: json: Explicitly ask for JSON data. * guix/import/json.scm (json-fetch): Add #:headers to http-fetch call. --- guix/import/json.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 5940f5e48f..c76bc9313c 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -29,7 +29,8 @@ (guard (c ((and (http-get-error? c) (= 404 (http-get-error-code c))) #f)) ;"expected" if package is unknown - (let* ((port (http-fetch url)) + (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile") + (Accept . "application/json")))) (result (hash-table->alist (json->scm port)))) (close-port port) result))) -- cgit v1.2.3 From bc5844d14955c09330d47984d930e1e9aa8c0ee0 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Mon, 6 Feb 2017 18:19:26 +0100 Subject: import: Add stackage importer and updater. * guix/import/stackage.scm: New file. * guix/scripts/import/stackage.scm: New file. * Makefile.am (MODULES): Add new files. * guix/scripts/import.scm (importers): Add "stackage". * guix/scripts/refresh.scm (%updaters): Add %stackage-updater. * doc/guix.texi (Invoking 'guix import'): Document the importer. (Invoking 'guix refresh'): Add stackage to option --type valid values. * guix/import/hackage.scm (guix-package->hackage-name, hackage-fetch, hackage-source-url, hackage-cabal-url, hackage-package?): Export them. --- Makefile.am | 2 + doc/guix.texi | 33 +++++++++- guix/import/hackage.scm | 8 ++- guix/import/stackage.scm | 135 +++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 3 +- guix/scripts/import/stackage.scm | 115 +++++++++++++++++++++++++++++++++ guix/scripts/refresh.scm | 1 + 7 files changed, 294 insertions(+), 3 deletions(-) create mode 100644 guix/import/stackage.scm create mode 100644 guix/scripts/import/stackage.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 360c356f10..18501bddfc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -126,6 +126,7 @@ MODULES = \ guix/import/cabal.scm \ guix/import/cran.scm \ guix/import/hackage.scm \ + guix/import/stackage.scm \ guix/import/elpa.scm \ guix/scripts.scm \ guix/scripts/download.scm \ @@ -147,6 +148,7 @@ MODULES = \ guix/scripts/import/gnu.scm \ guix/scripts/import/nix.scm \ guix/scripts/import/hackage.scm \ + guix/scripts/import/stackage.scm \ guix/scripts/import/elpa.scm \ guix/scripts/environment.scm \ guix/scripts/publish.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 21082aece4..eca2d99487 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -31,7 +31,8 @@ Copyright @copyright{} 2016 Jan Nieuwenhuizen@* Copyright @copyright{} 2016 Julien Lepiller@* Copyright @copyright{} 2016 Alex ter Weele@* Copyright @copyright{} 2017 Clément Lassieur@* -Copyright @copyright{} 2017 Mathieu Othacehe +Copyright @copyright{} 2017 Mathieu Othacehe@* +Copyright @copyright{} 2017 Federico Beffa Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -5340,6 +5341,34 @@ package name by an at-sign and a version number as in the following example: guix import hackage mtl@@2.1.3.1 @end example +@item stackage +@cindex stackage +The @code{stackage} importer is a wrapper around the @code{hackage} one. +It takes a package name, looks up the package version included in a +long-term support (LTS) @uref{https://www.stackage.org, Stackage} +release and uses the @code{hackage} importer to retrieve its metadata. +Note that it is up to you to select an LTS release compatible with the +GHC compiler used by Guix. + +Specific command-line options are: + +@table @code +@item --no-test-dependencies +@itemx -t +Do not include dependencies required only by the test suites. +@item --lts-version=@var{version} +@itemx -r @var{version} +@var{version} is the desired LTS release version. If omitted the latest +release is used. +@end table + +The command below imports metadata for the @code{HTTP} Haskell package +included in the LTS Stackage release version 7.18: + +@example +guix import stackage --lts-version=7.18 HTTP +@end example + @item elpa @cindex elpa Import metadata from an Emacs Lisp Package Archive (ELPA) package @@ -5504,6 +5533,8 @@ the updater for @uref{https://rubygems.org, RubyGems} packages. the updater for @uref{https://github.com, GitHub} packages. @item hackage the updater for @uref{https://hackage.haskell.org, Hackage} packages. +@item stackage +the updater for @uref{https://www.stackage.org, Stackage} packages. @item crate the updater for @uref{https://crates.io, Crates} packages. @end table diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 9af78ea888..4d01ed23ea 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -37,7 +37,13 @@ #:use-module (guix packages) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (hackage->guix-package - %hackage-updater)) + %hackage-updater + + guix-package->hackage-name + hackage-fetch + hackage-source-url + hackage-cabal-url + hackage-package?)) (define ghc-standard-libraries ;; List of libraries distributed with ghc (7.10.2). We include GHC itself as diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm new file mode 100644 index 0000000000..542b718083 --- /dev/null +++ b/guix/import/stackage.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Federico Beffa +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix import stackage) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (guix import json) + #:use-module (guix import hackage) + #:use-module (guix memoization) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix ui) + #:export (stackage->guix-package + %stackage-updater)) + + +;;; +;;; Stackage info fetcher and access functions +;;; + +(define %stackage-url "http://www.stackage.org") + +(define (lts-info-ghc-version lts-info) + "Retruns the version of the GHC compiler contained in LTS-INFO." + (match lts-info + ((("snapshot" ("ghc" . version) _ _) _) version) + (_ #f))) + +(define (lts-info-packages lts-info) + "Retruns the alist of packages contained in LTS-INFO." + (match lts-info + ((_ ("packages" pkg ...)) pkg) + (_ '()))) + +(define stackage-lts-info-fetch + ;; "Retrieve the information about the LTS Stackage release VERSION." + (memoize + (lambda* (#:optional (version "")) + (let* ((url (if (string=? "" version) + (string-append %stackage-url "/lts") + (string-append %stackage-url "/lts-" version))) + (lts-info (json-fetch url))) + (if lts-info + (reverse lts-info) + (leave (_ "LTS release version not found: ~A~%") version)))))) + +(define (stackage-package-name pkg-info) + (assoc-ref pkg-info "name")) + +(define (stackage-package-version pkg-info) + (assoc-ref pkg-info "version")) + +(define (lts-package-version pkgs-info name) + "Return the version of the package with upstream NAME included in PKGS-INFO." + (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name)) + pkgs-info))) + (stackage-package-version pkg))) + + +;;; +;;; Importer entry point +;;; + +(define (hackage-name-version name version) + (and version (string-append name "@" version))) + +(define* (stackage->guix-package package-name ; upstream name + #:key + (include-test-dependencies? #t) + (lts-version "") + (packages-info + (lts-info-packages + (stackage-lts-info-fetch lts-version)))) + "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved +vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION +release at stackage.org. Return the `package' S-expression corresponding to +that package, or #f on failure. PACKAGES-INFO is the alist with the packages +included in the Stackage LTS release." + (let* ((version (lts-package-version packages-info package-name)) + (name-version (hackage-name-version package-name version))) + (if name-version + (hackage->guix-package name-version + #:include-test-dependencies? + include-test-dependencies?) + (leave (_ "package not found: ~A~%") package-name)))) + + +;;; +;;; Updater +;;; + +(define latest-lts-release + (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch))))) + (lambda* (package) + "Return an for the latest Stackage LTS release of +PACKAGE or #f it the package is not inlucded in the Stackage LTS release." + (let* ((hackage-name (guix-package->hackage-name package)) + (version (lts-package-version (pkgs-info) hackage-name)) + (name-version (hackage-name-version hackage-name version))) + (match (and=> name-version hackage-fetch) + (#f (format (current-error-port) + "warning: failed to parse ~a~%" + (hackage-cabal-url hackage-name)) + #f) + (_ (let ((url (hackage-source-url hackage-name version))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url)))))))))) + +(define %stackage-updater + (upstream-updater + (name 'stackage) + (description "Updater for Stackage LTS packages") + (pred hackage-package?) + (latest latest-lts-release))) + +;;; stackage.scm ends here diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 4d07e0fd69..8c2f705738 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,8 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran" "crate")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" + "cran" "crate")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm new file mode 100644 index 0000000000..cf47bff259 --- /dev/null +++ b/guix/scripts/import/stackage.scm @@ -0,0 +1,115 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Federico Beffa +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts import stackage) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix scripts) + #:use-module (guix import stackage) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-stackage)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + `((lts-version . "") + (include-test-dependencies? . #t))) + +(define (show-help) + (display (_ "Usage: guix import stackage PACKAGE-NAME +Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) + (display (_ " + -r VERSION, --lts-version=VERSION + specify the LTS version to use")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -t, --no-test-dependencies don't include test-only dependencies")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import stackage"))) + (option '(#\t "no-test-dependencies") #f #f + (lambda (opt name arg result) + (alist-cons 'include-test-dependencies? #f + (alist-delete 'include-test-dependencies? + result)))) + (option '(#\r "lts-version") #t #f + (lambda (opt name arg result) + (alist-cons 'lts-version arg + (alist-delete 'lts-version + result)))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-stackage . 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)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (stackage->guix-package + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?) + #:lts-version (assoc-ref opts 'lts-version)))) + (unless sexp + (leave (_ "failed to download cabal file for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) + +;;; stackage.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 0dd7eee974..4d3c695aaf 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -205,6 +205,7 @@ unavailable optional dependencies such as Guile-JSON." %elpa-updater %cran-updater %bioconductor-updater + ((guix import stackage) => %stackage-updater) %hackage-updater ((guix import cpan) => %cpan-updater) ((guix import pypi) => %pypi-updater) -- cgit v1.2.3 From a4824c60ef5ffc0cae3771a16524287904a1c8bd Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Thu, 9 Feb 2017 17:05:41 +0100 Subject: import: hackage: Handle unknown packages gracefully. * guix/import/hackage.scm (hackage-fetch): Add 'guard'. --- guix/import/hackage.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 4d01ed23ea..2c9df073d3 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -21,6 +21,7 @@ (define-module (guix import hackage) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-26) #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) @@ -115,12 +116,15 @@ version is returned." "Return the Cabal file for the package NAME-VERSION, or #f on failure. If the version part is omitted from the package name, then return the latest version." - (let-values (((name version) (package-name->name+version name-version))) - (let* ((url (hackage-cabal-url name version)) - (port (http-fetch url)) - (result (read-cabal (canonical-newline-port port)))) - (close-port port) - result))) + (guard (c ((and (http-get-error? c) + (= 404 (http-get-error-code c))) + #f)) ;"expected" if package is unknown + (let-values (((name version) (package-name->name+version name-version))) + (let* ((url (hackage-cabal-url name version)) + (port (http-fetch url)) + (result (read-cabal (canonical-newline-port port)))) + (close-port port) + result)))) (define string->license ;; List of valid values from -- cgit v1.2.3 From 6554be68b43d5b240c8075cdbb479c66a9780f59 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 29 Jan 2017 00:34:48 +0100 Subject: git-download: Add 'git-predicate'. * guix/git-download.scm (git-predicate): New procedure. * gnu/packages/package-management.scm (current-guix): Use it. (make-git-predicate): Remove. --- gnu/packages/package-management.scm | 37 +------------------------------ guix/git-download.scm | 43 ++++++++++++++++++++++++++++++++++++- 2 files changed, 43 insertions(+), 37 deletions(-) (limited to 'guix') diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 26802e0c62..8291740998 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -25,7 +25,6 @@ #:use-module (guix utils) #:use-module (guix build-system gnu) #:use-module (guix build-system python) - #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+ asl2.0)) #:use-module (gnu packages) #:use-module (gnu packages guile) @@ -53,10 +52,6 @@ #:use-module (gnu packages tls) #:use-module (gnu packages ssh) #:use-module (gnu packages vim) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) #:use-module (ice-9 match)) (define (boot-guile-uri arch) @@ -275,38 +270,8 @@ generated file." (_ #t))) -(define (make-git-predicate directory) - "Return a predicate that returns true if a file is part of the Git checkout -living at DIRECTORY. Upon Git failure, return #f instead of a predicate." - (define (parent-directory? thing directory) - ;; Return #t if DIRECTORY is the parent of THING. - (or (string-suffix? thing directory) - (and (string-index thing #\/) - (parent-directory? (dirname thing) directory)))) - - (let* ((pipe (with-directory-excursion directory - (open-pipe* OPEN_READ "git" "ls-files"))) - (files (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (reverse lines)) - (line - (loop (cons line lines)))))) - (status (close-pipe pipe))) - (and (zero? status) - (lambda (file stat) - (match (stat:type stat) - ('directory - ;; 'git ls-files' does not list directories, only regular files, - ;; so we need this special trick. - (any (cut parent-directory? <> file) files)) - ((or 'regular 'symlink) - (any (cut string-suffix? <> file) files)) - (_ - #f)))))) - (define-public current-guix - (let ((select? (delay (or (make-git-predicate + (let ((select? (delay (or (git-predicate (string-append (current-source-directory) "/../..")) source-file?)))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 62e625c715..5d86ab2b62 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2017 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix git-download) + #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) @@ -24,6 +26,9 @@ #:use-module (guix packages) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) #:export (git-reference git-reference? git-reference-url @@ -32,7 +37,8 @@ git-fetch git-version - git-file-name)) + git-file-name + git-predicate)) ;;; Commentary: ;;; @@ -119,4 +125,39 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." "Return the file-name for packages using git-download." (string-append name "-" version "-checkout")) +(define (git-predicate directory) + "Return a predicate that returns true if a file is part of the Git checkout +living at DIRECTORY. Upon Git failure, return #f instead of a predicate. + +The returned predicate takes two arguments FILE and STAT where FILE is an +absolute file name and STAT is the result of 'lstat'." + (define (parent-directory? thing directory) + ;; Return #t if DIRECTORY is the parent of THING. + (or (string-suffix? thing directory) + (and (string-index thing #\/) + (parent-directory? (dirname thing) directory)))) + + (let* ((pipe (with-directory-excursion directory + (open-pipe* OPEN_READ "git" "ls-files"))) + (files (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (reverse lines)) + (line + (loop (cons line lines)))))) + (status (close-pipe pipe))) + (and (zero? status) + (lambda (file stat) + (match (stat:type stat) + ('directory + ;; 'git ls-files' does not list directories, only regular files, + ;; so we need this special trick. + (any (lambda (f) (parent-directory? f file)) + files)) + ((or 'regular 'symlink) + (any (lambda (f) (string-suffix? f file)) + files)) + (_ + #f)))))) + ;;; git-download.scm ends here -- cgit v1.2.3 From 65e862d1a2914ad61201236c155058bcf33b5b9c Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Mon, 6 Feb 2017 16:45:08 +0100 Subject: gnu: Add dub-build-system. * guix/build-system/dub.scm: New file. * guix/build/dub-build-system.scm: New file. * Makefile.am (MODULES): Add them. * doc/guix.texi: Add section for dub-build-system. --- Makefile.am | 2 + doc/guix.texi | 10 +++ guix/build-system/dub.scm | 147 ++++++++++++++++++++++++++++++++++++++++ guix/build/dub-build-system.scm | 125 ++++++++++++++++++++++++++++++++++ 4 files changed, 284 insertions(+) create mode 100644 guix/build-system/dub.scm create mode 100644 guix/build/dub-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 18501bddfc..8fe22d48ad 100644 --- a/Makefile.am +++ b/Makefile.am @@ -64,6 +64,7 @@ MODULES = \ guix/build-system/ant.scm \ guix/build-system/cargo.scm \ guix/build-system/cmake.scm \ + guix/build-system/dub.scm \ guix/build-system/emacs.scm \ guix/build-system/asdf.scm \ guix/build-system/glib-or-gtk.scm \ @@ -88,6 +89,7 @@ MODULES = \ guix/build/download.scm \ guix/build/cargo-build-system.scm \ guix/build/cmake-build-system.scm \ + guix/build/dub-build-system.scm \ guix/build/emacs-build-system.scm \ guix/build/asdf-build-system.scm \ guix/build/git.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index eca2d99487..50cab274af 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3438,6 +3438,16 @@ Which Haskell compiler is used can be specified with the @code{#:haskell} parameter which defaults to @code{ghc}. @end defvr +@defvr {Scheme Variable} dub-build-system +This variable is exported by @code{(guix build-system dub)}. It +implements the Dub build procedure used by D packages, which +involves running @code{dub build} and @code{dub run}. +Installation is done by copying the files manually. + +Which D compiler is used can be specified with the @code{#:ldc} +parameter which defaults to @code{ldc}. +@end defvr + @defvr {Scheme Variable} emacs-build-system This variable is exported by @code{(guix build-system emacs)}. It implements an installation procedure similar to the packaging system diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm new file mode 100644 index 0000000000..13c89e8648 --- /dev/null +++ b/guix/build-system/dub.scm @@ -0,0 +1,147 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2016 David Craven +;;; Copyright © 2016 Danny Milosavljevic +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build-system dub) + #:use-module (guix search-paths) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (dub-build-system)) + +(define (default-ldc) + "Return the default ldc package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((ldc (resolve-interface '(gnu packages ldc)))) + (module-ref ldc 'ldc))) + +(define (default-dub) + "Return the default dub package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((ldc (resolve-interface '(gnu packages ldc)))) + (module-ref ldc 'dub))) + +(define (default-pkg-config) + "Return the default pkg-config package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((pkg-config (resolve-interface '(gnu packages pkg-config)))) + (module-ref pkg-config 'pkg-config))) + +(define %dub-build-system-modules + ;; Build-side modules imported by default. + `((guix build dub-build-system) + (guix build syscalls) + ,@%gnu-build-system-modules)) + +(define* (dub-build store name inputs + #:key + (tests? #t) + (test-target #f) + (dub-build-flags ''()) + (phases '(@ (guix build dub-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %dub-build-system-modules) + (modules '((guix build dub-build-system) + (guix build utils)))) + "Build SOURCE using DUB, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (dub-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:test-target ,test-target + #:dub-build-flags ,dub-build-flags + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (ldc (default-ldc)) + (dub (default-dub)) + (pkg-config (default-pkg-config)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + + (define private-keywords + '(#:source #:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs)) + + (and (not target) ;; TODO: support cross-compilation + (bag + (name name) + (system system) + (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system' + ,@(standard-packages))) + (build-inputs `(("ldc" ,ldc) + ("dub" ,dub) + ,@native-inputs)) + (outputs outputs) + (build dub-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define dub-build-system + (build-system + (name 'dub) + (description + "DUB build system, to build D packages") + (lower lower))) diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm new file mode 100644 index 0000000000..7c7cd8803c --- /dev/null +++ b/guix/build/dub-build-system.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven +;;; Copyright © 2017 Danny Milosavljevic +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build dub-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + dub-build)) + +;; Commentary: +;; +;; Builder-side code of the DUB (the build tool for D) build system. +;; +;; Code: + +;; FIXME: Needs to be parsed from url not package name. +(define (package-name->d-package-name name) + "Return the package name of NAME." + (match (string-split name #\-) + (("d" rest ...) + (string-join rest "-")) + (_ #f))) + +(define* (configure #:key inputs #:allow-other-keys) + "Prepare one new directory with all the required dependencies. + It's necessary to do this (instead of just using /gnu/store as the + directory) because we want to hide the libraries in subdirectories + lib/dub/... instead of polluting the user's profile root." + (let* ((dir (mkdtemp! "/tmp/dub.XXXXXX")) + (vendor-dir (string-append dir "/vendor"))) + (setenv "HOME" dir) + (mkdir vendor-dir) + (for-each + (match-lambda + ((name . path) + (let* ((d-package (package-name->d-package-name name)) + (d-basename (basename path))) + (when (and d-package path) + (match (string-split (basename path) #\-) + ((_ ... version) + (symlink (string-append path "/lib/dub/" d-basename) + (string-append vendor-dir "/" d-basename)))))))) + inputs) + (zero? (system* "dub" "add-path" vendor-dir)))) + +(define (grep string file-name) + "Find the first occurence of STRING in the file named FILE-NAME. + Return the position of this occurence, or #f if none was found." + (string-contains (call-with-input-file file-name get-string-all) + string)) + +(define (grep* string file-name) + "Find the first occurence of STRING in the file named FILE-NAME. + Return the position of this occurence, or #f if none was found. + If the file named FILE-NAME doesn't exist, return #f." + (catch 'system-error + (lambda () + (grep string file-name)) + (lambda args + #f))) + +(define* (build #:key (dub-build-flags '()) + #:allow-other-keys) + "Build a given DUB package." + (if (or (grep* "sourceLibrary" "package.json") + (grep* "sourceLibrary" "dub.sdl") ; note: format is different! + (grep* "sourceLibrary" "dub.json")) + #t + (let ((status (zero? (apply system* `("dub" "build" ,@dub-build-flags))))) + (system* "dub" "run") ; might fail for "targetType": "library" + status))) + +(define* (check #:key tests? #:allow-other-keys) + (if tests? + (zero? (system* "dub" "test")) + #t)) + +(define* (install #:key inputs outputs #:allow-other-keys) + "Install a given DUB package." + (let* ((out (assoc-ref outputs "out")) + (outbin (string-append out "/bin")) + (outlib (string-append out "/lib/dub/" (basename out)))) + (mkdir-p outbin) + ;; TODO remove "-test-application" + (copy-recursively "bin" outbin) + (mkdir-p outlib) + (copy-recursively "." (string-append outlib)) + #t)) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + +(define* (dub-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given DUB package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) -- cgit v1.2.3