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 ++++++++++++++++++++++++++++----------------- 1 file changed, 99 insertions(+), 62 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 9ab4fbe2a..f14e931d7 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 -- cgit v1.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/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index c495e39f4..fa07aba5a 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 f14e931d7..815bb789c 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.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/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ccb4c275f..551275e89 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.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/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 55657ec81..bf9dbaa72 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 551275e89..8326d64f4 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.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/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8326d64f4..d7d71b7ab 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 1d3be6a84..a08367d1b 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 2b3bbfe03..911594912 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.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/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9b991786c..afc1369ad 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.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. * 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/scripts') diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index 10e70568c..d6d267daf 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.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. * 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/scripts') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 9ae204e6c..624ef73e9 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.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/scripts') diff --git a/.dir-locals.el b/.dir-locals.el index adcc50c56..917fd3004 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 c13d0df8a..360c356f1 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 f55c294a1..ec2473422 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 dd922c3ae..7cde51fff 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 f6df183da..f05ddf91f 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 d4d3d28f2..bfe0eca9f 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 9e4689ba9..11cad62cc 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 b712c508e..056b1163b 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 e4151c652..05ea19236 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 463a25514..40cdea029 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 96cf5bbae..c0b0c415c 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 000000000..d64f60fe9 --- /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 24f613ff4..2ff94007b 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 d7d71b7ab..68402fda1 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 79ce503a2..8c82d8978 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 afc1369ad..cb64dc8b2 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 7152a5556..491cd5ac0 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 ee06e47fe..8aa2cb734 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.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/scripts') diff --git a/gnu/packages.scm b/gnu/packages.scm index ec2473422..0aa289d56 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 7cde51fff..c8d94c830 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 f05ddf91f..730e638c8 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 bfe0eca9f..383e8cb64 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 056b1163b..47a783f42 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 05ea19236..012f58752 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 2ff94007b..8c63f21a9 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 8c82d8978..9804d4192 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 cb64dc8b2..0b38aac31 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 491cd5ac0..cb3fbed91 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 8aa2cb734..72dc0687a 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.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 * 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/scripts') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index a08367d1b..8a3a935a1 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.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/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 0b38aac31..776e7332c 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.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/scripts') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index fa56853fd..b2721f238 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 24e61c3ea..bceea4133 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 8a3a935a1..0a1205d08 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.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/scripts') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 708d53d0a..7011a279d 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 0a1205d08..44f490043 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.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/scripts') diff --git a/Makefile.am b/Makefile.am index 360c356f1..18501bddf 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 21082aece..eca2d9948 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 9af78ea88..4d01ed23e 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 000000000..542b71808 --- /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 4d07e0fd6..8c2f70573 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 000000000..cf47bff25 --- /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 0dd7eee97..4d3c695aa 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.3