diff options
Diffstat (limited to 'guix')
40 files changed, 900 insertions, 542 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 3cc89f8852..7266fa0009 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, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -151,8 +151,8 @@ so that they use INPUTS (a thunk) instead of implicit inputs." p)) (define (cut? p) - (and (eq? (package-build-system p) gnu-build-system) - (memq #:implicit-inputs? (package-arguments p)))) + (or (not (eq? (package-build-system p) gnu-build-system)) + (memq #:implicit-inputs? (package-arguments p)))) (package-mapping add-explicit-inputs cut?)) diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index 247a687d80..31fc493b09 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; @@ -83,7 +83,21 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (newline) (loop (map 1+ indexes))))) -(define ls-command-implementation +(define-syntax define-command-runtime + (syntax-rules () + "Define run-time support of a Bournish command. This macro ensures that +the implementation is not subject to inlining, which would prevent compiled +code from referring to it via '@@'." + ((_ (command . args) body ...) + (define-command-runtime command (lambda args body ...))) + ((_ command exp) + (begin + (define command exp) + + ;; Prevent inlining of COMMAND. + (set! command command))))) + +(define-command-runtime ls-command-implementation ;; Run-time support procedure. (case-lambda (() @@ -173,13 +187,13 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (call-with-input-file file lines+chars))) (format #t "~a ~a~%" chars file))) -(define (wc-command-implementation . files) +(define-command-runtime (wc-command-implementation . files) (for-each wc-print (filter file-exists?* files))) -(define (wc-l-command-implementation . files) +(define-command-runtime (wc-l-command-implementation . files) (for-each wc-l-print (filter file-exists?* files))) -(define (wc-c-command-implementation . files) +(define-command-runtime (wc-c-command-implementation . files) (for-each wc-c-print (filter file-exists?* files))) (define (wc-command . args) diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 4b6472784c..c4dbb6e34c 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -184,36 +184,36 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." ;; Exit as soon as something goes wrong. (exit-on-exception file - (with-target host - (lambda () - (let ((relative (relative-file source-directory file))) - (compile-file file - #:output-file (string-append build-directory "/" - (scm->go relative)) - #:opts (append warning-options - (optimization-options relative)))))))) + (let ((relative (relative-file source-directory file))) + (compile-file file + #:output-file (string-append build-directory "/" + (scm->go relative)) + #:opts (append warning-options + (optimization-options relative)))))) (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory (with-fluids ((*current-warning-prefix* "")) - - ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all - ;; of FILES. - (load-files source-directory files - #:report-load report-load - #:debug-port debug-port) - - ;; Make sure compilation related modules are loaded before starting to - ;; compile files in parallel. + ;; Make sure the compiler's modules are loaded before 'with-target' + ;; (since 'with-target' influences the .go loader), and before + ;; starting to compile files in parallel. (compile #f) - ;; XXX: Don't use too many workers to work around the insane memory - ;; requirements of the compiler in Guile 2.2.2: - ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>. - (n-par-for-each (min workers 8) build files) - - (unless (zero? total) - (report-compilation #f total total)))))) + (with-target host + (lambda () + ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first + ;; load all of FILES. + (load-files source-directory files + #:report-load report-load + #:debug-port debug-port) + + ;; XXX: Don't use too many workers to work around the insane + ;; memory requirements of the compiler in Guile 2.2.2: + ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>. + (n-par-for-each (min workers 8) build files) + + (unless (zero? total) + (report-compilation #f total total)))))))) (eval-when (eval load) (when (and (string=? "2" (major-version)) diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index ff6fcf5fe3..e8ebcf8ba0 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,53 +37,46 @@ ;; subpath where we store the package content (define %package-path "/share/julia/packages/") -(define (generate-load-path inputs outputs) - (string-append - (string-join (map (match-lambda - ((_ . path) - (string-append path %package-path))) - ;; Restrict to inputs beginning with "julia-". - (filter (match-lambda - ((name . _) - (string-prefix? "julia-" name))) - inputs)) - ":") - (string-append ":" (assoc-ref outputs "out") %package-path) - ;; stdlib is always required to find Julia's standard libraries. - ;; usually there are other two paths in this variable: - ;; "@" and "@v#.#" - ":@stdlib")) - (define* (install #:key source inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (package-dir (string-append out %package-path - (string-append - (strip-store-file-name source))))) - (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + (strip-store-file-name source)))) (mkdir-p package-dir) - (copy-recursively source package-dir)) + (copy-recursively (getcwd) package-dir)) #t) -;; TODO: Precompilation is working, but I don't know how to tell -;; julia to use use it. If (on rantime) we set HOME to -;; store path, julia tries to write files there (failing) (define* (precompile #:key source inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (builddir (string-append out "/share/julia/")) (package (strip-store-file-name source))) (mkdir-p builddir) + ;; With a patch, SOURCE_DATE_EPOCH is honored + (setenv "SOURCE_DATE_EPOCH" "1") (setenv "JULIA_DEPOT_PATH" builddir) - (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) - ;; Actual precompilation - (invoke-julia (string-append "using " package))) + ;; Add new package dir to the load path. + (setenv "JULIA_LOAD_PATH" + (string-append builddir "packages/" ":" + (or (getenv "JULIA_LOAD_PATH") + ""))) + ;; Actual precompilation: + (invoke-julia + ;; When using Julia as a user, Julia writes precompile cache to the first + ;; entry of the DEPOT_PATH list (by default, the home dir). We want to + ;; write it to the store, so let's push the store path as the first + ;; element of DEPOT_PATH. Once the cache file exists, this hack is not + ;; needed anymore (like in the check phase). If the user install new + ;; packages, those will be installed and precompiled in the home dir. + (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package))) #t) (define* (check #:key source inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (package (strip-store-file-name source)) (builddir (string-append out "/share/julia/"))) + ;; With a patch, SOURCE_DATE_EPOCH is honored + (setenv "SOURCE_DATE_EPOCH" "1") (setenv "JULIA_DEPOT_PATH" builddir) - (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + (setenv "JULIA_LOAD_PATH" (string-append builddir "packages/")) (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")"))) #t) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0938ec0ff1..73b439fb7d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +23,6 @@ (define-module (guix build syscalls) #:use-module (system foreign) - #:use-module (system base target) ;for cross-compilation support #:use-module (rnrs bytevectors) #:autoload (ice-9 binary-ports) (get-bytevector-n) #:use-module (srfi srfi-1) @@ -892,36 +892,6 @@ system to PUT-OLD." (namelen uint8) (name uint8)) -(define-syntax define-generic-identifier - (syntax-rules (gnu/linux gnu/hurd =>) - "Define a generic identifier that adjust to the current GNU variant." - ((_ id (gnu/linux => linux) (gnu/hurd => hurd)) - (define-syntax id - (lambda (s) - (syntax-case s () - ((_ args (... ...)) - (if (string-contains (or (target-type) %host-type) - "linux") - #'(linux args (... ...)) - #'(hurd args (... ...)))) - (_ - (if (string-contains (or (target-type) %host-type) - "linux") - #'linux - #'hurd)))))))) - -(define-generic-identifier read-dirent-header - (gnu/linux => read-dirent-header/linux) - (gnu/hurd => read-dirent-header/hurd)) - -(define-generic-identifier %struct-dirent-header - (gnu/linux => %struct-dirent-header/linux) - (gnu/hurd => %struct-dirent-header/hurd)) - -(define-generic-identifier sizeof-dirent-header - (gnu/linux => sizeof-dirent-header/linux) - (gnu/hurd => sizeof-dirent-header/hurd)) - ;; Constants for the 'type' field, from <dirent.h>. (define DT_UNKNOWN 0) (define DT_FIFO 1) @@ -960,19 +930,30 @@ system to PUT-OLD." "closedir: ~A" (list (strerror err)) (list err))))))) -(define readdir* +(define (readdir-procedure name-field-offset sizeof-dirent-header + read-dirent-header) (let ((proc (syscall->procedure '* "readdir64" '(*)))) (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) (let ((ptr (proc directory))) (and (not (null-pointer? ptr)) (cons (pointer->string - (make-pointer (+ (pointer-address ptr) - (c-struct-field-offset - %struct-dirent-header name))) + (make-pointer (+ (pointer-address ptr) name-field-offset)) -1) (read-dirent-header (pointer->bytevector ptr sizeof-dirent-header)))))))) +(define readdir* + ;; Decide at run time which one must be used. + (if (string-contains %host-type "linux-gnu") + (readdir-procedure (c-struct-field-offset %struct-dirent-header/linux + name) + sizeof-dirent-header/linux + read-dirent-header/linux) + (readdir-procedure (c-struct-field-offset %struct-dirent-header/hurd + name) + sizeof-dirent-header/hurd + read-dirent-header/hurd))) + (define* (scandir* name #:optional (select? (const #t)) (entry<? (lambda (entry1 entry2) diff --git a/guix/channels.scm b/guix/channels.scm index f0261dc2da..041fae2a9c 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -349,6 +349,15 @@ to '%package-module-path'." (((predicate . guile) rest ...) (if (predicate source) (guile) (loop rest)))))) +(define (with-trivial-build-handler mvalue) + "Run MVALUE, a monadic value, with a \"trivial\" build handler installed +that unconditionally resumes the continuation." + (lambda (store) + (with-build-handler (lambda (continue . _) + (continue #t)) + (values (run-with-store store mvalue) + store)))) + (define* (build-from-source name source #:key core verbose? commit (dependencies '())) @@ -381,8 +390,14 @@ package modules under SOURCE using CORE, an instance of Guix." (mbegin %store-monad (mwhen guile (set-guile-for-build guile)) - (build source #:verbose? verbose? #:version commit - #:pull-version %pull-version))) + + ;; BUILD is usually quite costly. Install a "trivial" build handler + ;; so we don't bounce an outer build-accumulator handler that could + ;; cause us to redo half of the BUILD computation several times just + ;; to realize it gives the same result. + (with-trivial-build-handler + (build source #:verbose? verbose? #:version commit + #:pull-version %pull-version)))) ;; Build a set of modules that extend Guix using the standard method. (standard-module-derivation name source core dependencies))) @@ -553,9 +568,7 @@ channel instances." (define (package-cache-file manifest) "Build a package cache file for the instance in MANIFEST. This is meant to be used as a profile hook." - (mlet %store-monad ((profile (profile-derivation manifest - #:hooks '()))) - + (let ((profile (profile (content manifest) (hooks '())))) (define build #~(begin (use-modules (gnu packages)) diff --git a/guix/ci.scm b/guix/ci.scm index 9e21996023..8fd05668f2 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,7 +68,7 @@ (define-json-mapping <evaluation> make-evaluation evaluation? json->evaluation (id evaluation-id) ;integer - (spec evaluation-spec) ;string + (spec evaluation-spec "specification") ;string (complete? evaluation-complete? "in-progress" (match-lambda (0 #t) diff --git a/guix/download.scm b/guix/download.scm index 91a2b4ce5f..c3dc5a208c 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -531,7 +531,8 @@ own. This helper makes it easier to deal with \"tar bombs\"." (string-append "tarbomb-" (or name file-name)) #:system system - #:guile guile))) + #:guile guile)) + (guile (package->derivation guile system))) ;; Take the tar bomb, and simply unpack it as a directory. ;; Use ungrafted tar/gzip so that the resulting tarball doesn't depend on ;; whether grafts are enabled. @@ -544,6 +545,8 @@ own. This helper makes it easier to deal with \"tar bombs\"." (chdir #$output) (invoke (string-append #$tar "/bin/tar") "xf" #$drv))) + #:system system + #:guile-for-build guile #:graft? #f #:local-build? #t))) @@ -566,7 +569,8 @@ own. This helper makes it easier to deal with \"zip bombs\"." (string-append "zipbomb-" (or name file-name)) #:system system - #:guile guile))) + #:guile guile)) + (guile (package->derivation guile system))) ;; Take the zip bomb, and simply unpack it as a directory. ;; Use ungrafted unzip so that the resulting tarball doesn't depend on ;; whether grafts are enabled. @@ -578,6 +582,8 @@ own. This helper makes it easier to deal with \"zip bombs\"." (chdir #$output) (invoke (string-append #$unzip "/bin/unzip") #$drv))) + #:system system + #:guile-for-build guile #:graft? #f #:local-build? #t))) diff --git a/guix/gexp.scm b/guix/gexp.scm index 133e0f5679..c320065546 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -472,24 +472,26 @@ This is the declarative counterpart of 'gexp->script'." #:target target)))) (define-record-type <scheme-file> - (%scheme-file name gexp splice?) + (%scheme-file name gexp splice? load-path?) scheme-file? (name scheme-file-name) ;string (gexp scheme-file-gexp) ;gexp - (splice? scheme-file-splice?)) ;Boolean + (splice? scheme-file-splice?) ;Boolean + (load-path? scheme-file-set-load-path?)) ;Boolean -(define* (scheme-file name gexp #:key splice?) +(define* (scheme-file name gexp #:key splice? (set-load-path? #t)) "Return an object representing the Scheme file NAME that contains GEXP. This is the declarative counterpart of 'gexp->file'." - (%scheme-file name gexp splice?)) + (%scheme-file name gexp splice? set-load-path?)) (define-gexp-compiler (scheme-file-compiler (file <scheme-file>) system target) ;; Compile FILE by returning a derivation that builds the file. (match file - (($ <scheme-file> name gexp splice?) + (($ <scheme-file> name gexp splice? set-load-path?) (gexp->file name gexp + #:set-load-path? set-load-path? #:splice? splice? #:system system #:target target)))) @@ -683,22 +685,22 @@ When TARGET is true, use it as the cross-compilation target triplet." (and (string? obj) (store-path? obj))) (with-monad %store-monad - (mapm %store-monad - (match-lambda - (((? struct? thing) sub-drv ...) - (mlet %store-monad ((obj (lower-object - thing system #:target target))) - (return (match obj - ((? derivation? drv) - (let ((outputs (if (null? sub-drv) - '("out") - sub-drv))) - (derivation-input drv outputs))) - ((? store-item? item) - item))))) - (((? store-item? item)) - (return item))) - inputs))) + (mapm/accumulate-builds + (match-lambda + (((? struct? thing) sub-drv ...) + (mlet %store-monad ((obj (lower-object + thing system #:target target))) + (return (match obj + ((? derivation? drv) + (let ((outputs (if (null? sub-drv) + '("out") + sub-drv))) + (derivation-input drv outputs))) + ((? store-item? item) + item))))) + (((? store-item? item)) + (return item))) + inputs))) (define* (lower-reference-graphs graphs #:key system target) "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a @@ -730,7 +732,7 @@ names and file names suitable for the #:allowed-references argument to #:target target))) (return (derivation->output-path drv)))))) - (mapm %store-monad lower lst))) + (mapm/accumulate-builds lower lst))) (define default-guile-derivation ;; Here we break the abstraction by talking to the higher-level layer. diff --git a/guix/git-download.scm b/guix/git-download.scm index 1eae035fc4..a1c1adf760 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (git-reference git-reference? git-reference-url @@ -170,6 +173,15 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define (git-version version revision commit) "Return the version string for packages using git-download." + ;; git-version is almost exclusively executed while modules are being loaded. + ;; This makes any errors hide their backtrace. Avoid the mysterious error + ;; "Value out of range 0 to N: 7" when the commit ID is too short, which + ;; can happen, for example, when the user swapped the revision and commit + ;; arguments by mistake. + (when (< (string-length commit) 7) + (raise + (condition + (&message (message "git-version: commit ID unexpectedly short"))))) (string-append version "-" revision "." (string-take commit 7))) (define (git-file-name name version) diff --git a/guix/git.scm b/guix/git.scm index b1ce3ea451..5fffd429bd 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -182,11 +182,10 @@ OID (roughly the commit hash) corresponding to REF." (('tag . tag) (let ((oid (reference-name->oid repository (string-append "refs/tags/" tag)))) - ;; Get the commit that the tag at OID refers to. This is not - ;; strictly needed, but it's more consistent to always return the - ;; OID of a commit. - (object-lookup repository - (tag-target-id (tag-lookup repository oid)))))))) + ;; OID may point to a "tag" object, but it can also point directly + ;; to a "commit" object, as surprising as it may seem. Return that + ;; object, whatever that is. + (object-lookup repository oid)))))) (reset repository obj RESET_HARD) (object-id obj)) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index bf0283f8fe..5fae24b325 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -71,6 +72,8 @@ "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) (define expkeysig-rx ; good signature, but expired key (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) +(define revkeysig-rx ; good signature, but revoked key + (make-regexp "^\\[GNUPG:\\] REVKEYSIG ([[:xdigit:]]+) (.*)$")) (define errsig-rx ;; Note: The fingeprint part (the last element of the line) appeared in ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing. @@ -114,6 +117,11 @@ revoked. Return a status s-exp if GnuPG failed." (lambda (match) `(expired-key-signature ,(match:substring match 1) ; fingerprint ,(match:substring match 2)))) ; user name + ((regexp-exec revkeysig-rx line) + => + (lambda (match) + `(revoked-key-signature ,(match:substring match 1) ; fingerprint + ,(match:substring match 2)))) ; user name ((regexp-exec errsig-rx line) => (lambda (match) @@ -157,7 +165,8 @@ a fingerprint/user pair; return #f otherwise." (match (assq 'valid-signature status) (('valid-signature fingerprint date timestamp) (match (or (assq 'good-signature status) - (assq 'expired-key-signature status)) + (assq 'expired-key-signature status) + (assq 'revoked-key-signature status)) ((_ key-id user) (cons fingerprint user)) (_ #f))) (_ diff --git a/guix/grafts.scm b/guix/grafts.scm index adc7bfafae..69d6fe4469 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -152,52 +152,24 @@ are not recursively applied to dependencies of DRV." #:properties properties))))) -(define (non-self-references references drv outputs) +(define (non-self-references store drv outputs) "Return the list of references of the OUTPUTS of DRV, excluding self -references. Call REFERENCES to get the list of references." - (let ((refs (append-map (compose references - (cut derivation->output-path drv <>)) - outputs)) +references." + (define (references* items) + ;; Return the references of ITEMS. + (guard (c ((store-protocol-error? c) + ;; ITEMS are not in store so build INPUT first. + (and (build-derivations store (list drv)) + (append-map (cut references/cached store <>) items)))) + (append-map (cut references/cached store <>) items))) + + (let ((refs (references* (map (cut derivation->output-path drv <>) + outputs))) (self (match (derivation->output-paths drv) (((names . items) ...) items)))) (remove (cut member <> self) refs))) -(define (references-oracle store input) - "Return a one-argument procedure that, when passed the output file names of -INPUT, a derivation input, or their dependencies, returns the list of -references of that item. Use either local info or substitute info; build -INPUT if no information is available." - (define (references* items) - (guard (c ((store-protocol-error? c) - ;; As a last resort, build DRV and query the references of the - ;; build result. - - ;; Warm up the narinfo cache, otherwise each derivation build - ;; will result in one HTTP request to get one narinfo, which is - ;; much less efficient than fetching them all upfront. - (substitution-oracle store - (list (derivation-input-derivation input))) - - (and (build-derivations store (list input)) - (map (cut references store <>) items)))) - (references/substitutes store items))) - - (let loop ((items (derivation-input-output-paths input)) - (result vlist-null)) - (match items - (() - (lambda (item) - (match (vhash-assoc item result) - ((_ . refs) refs) - (#f #f)))) - (_ - (let* ((refs (references* items)) - (result (fold vhash-cons result items refs))) - (loop (remove (cut vhash-assoc <> result) - (delete-duplicates (concatenate refs) string=?)) - result)))))) - (define-syntax-rule (with-cache key exp ...) "Cache the value of monadic expression EXP under KEY." (mlet %state-monad ((cache (current-state))) @@ -239,15 +211,12 @@ of DRV." (set-insert drv visited))))))))) (define* (cumulative-grafts store drv grafts - references #:key (outputs (derivation-output-names drv)) (guile (%guile-for-build)) (system (%current-system))) "Augment GRAFTS with additional grafts resulting from the application of -GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure -that returns the list of references of the store item it is given. Return the -resulting list of grafts. +GRAFTS to the dependencies of DRV. Return the resulting list of grafts. This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping derivations to the corresponding set of grafts." @@ -270,7 +239,7 @@ derivations to the corresponding set of grafts." ;; If GRAFTS already contains a graft from DRV, do not override it. (if (find (cut graft-origin? drv <>) grafts) (state-return grafts) - (cumulative-grafts store drv grafts references + (cumulative-grafts store drv grafts #:outputs (list output) #:guile guile #:system system))) @@ -278,7 +247,7 @@ derivations to the corresponding set of grafts." (state-return grafts)))) (with-cache (cons (derivation-file-name drv) outputs) - (match (non-self-references references drv outputs) + (match (non-self-references store drv outputs) (() ;no dependencies (return grafts)) (deps ;one or more dependencies @@ -315,15 +284,8 @@ derivations to the corresponding set of grafts." "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 - ;; info or when building DRV. - (define references - (references-oracle store (derivation-input drv outputs))) - (match (run-with-state - (cumulative-grafts store drv grafts references + (cumulative-grafts store drv grafts #:outputs outputs #:guile guile #:system system) vlist-null) ;the initial cache diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 0b4482e876..e3ec11d7f8 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -201,14 +201,16 @@ latest version of CRATE-NAME." (lookup-crate crate-name)) (define version-number - (or version - (crate-latest-version crate))) + (and crate + (or version + (crate-latest-version crate)))) (define version* - (find (lambda (version) - (string=? (crate-version-number version) - version-number)) - (crate-versions crate))) + (and crate + (find (lambda (version) + (string=? (crate-version-number version) + version-number)) + (crate-versions crate)))) (and crate version* (let* ((dependencies (crate-version-dependencies version*)) diff --git a/guix/import/json.scm b/guix/import/json.scm index 8900724dcd..0c98bb25b8 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,8 +23,16 @@ #:use-module (json) #:use-module (guix http-client) #:use-module (guix import utils) + #:use-module (guix import print) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) - #:export (json-fetch)) + #:export (json-fetch + json->code + json->scheme-file)) (define* (json-fetch url ;; Note: many websites returns 403 if we omit a @@ -42,3 +51,53 @@ the query." (result (json->scm port))) (close-port port) result))) + +(define (json->code file-name) + "Read FILE-NAME containing one ore more JSON package definitions and return +a list of S-expressions, or return #F when the JSON is invalid." + (catch 'json-invalid + (lambda () + (let ((json (json-string->scm + (with-input-from-file file-name read-string)))) + (match json + (#(packages ...) + ;; To allow definitions to refer to one another, collect references + ;; to local definitions and tell alist->package to ignore them. + (second + (memq #:result + (fold + (lambda (pkg names+result) + (match names+result + ((#:names names #:result result) + (list #:names + (cons (assoc-ref pkg "name") names) + #:result + (append result + (list + (package->code (alist->package pkg names)) + (string->symbol (assoc-ref pkg "name")))))))) + (list #:names '() + #:result '()) + packages)))) + (package + (list (package->code (alist->package json)) + (string->symbol (assoc-ref json "name"))))))) + (const #f))) + +(define (json->scheme-file file) + "Convert the FILE containing a JSON package definition to a Scheme +representation and return the new file name (or #F on error)." + (and-let* ((sexprs (json->code file)) + (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp")) + (template (string-append tempdir "/guix-XXXXXX")) + (port (mkstemp! template))) + (close-port port) + template))) + (call-with-output-file file* + (lambda (port) + (write '(use-modules (gnu) + (guix) + ((guix licenses) #:prefix license:)) + port) + (for-each (cut write <> port) sexprs))) + file*)) diff --git a/guix/import/print.scm b/guix/import/print.scm index 4c2a91fa4f..11cc218285 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,7 @@ when evaluated." ;; Print either license variable name or the code for a license object (define (license->code lic) (let ((var (variable-name lic '(guix licenses)))) - (or var + (or (symbol-append 'license: var) `(license (name ,(license-name lic)) (uri ,(license-uri lic)) @@ -79,7 +79,9 @@ when evaluated." (patches (origin-patches source))) `(origin (method ,(procedure-name method)) - (uri (string-append ,@(factorize-uri uri version))) + (uri (string-append ,@(match (factorize-uri uri version) + ((? string? uri) (list uri)) + (factorized factorized)))) (sha256 (base32 ,(format #f "~a" (bytevector->nix-base32-string sha256)))) @@ -92,6 +94,8 @@ when evaluated." (define (package-lists->code lsts) (list 'quasiquote (map (match-lambda + ((? symbol? s) + (list (symbol->string s) (list 'unquote s))) ((label pkg . out) (let ((mod (package-module-name pkg))) (cons* label @@ -121,45 +125,47 @@ when evaluated." (home-page (package-home-page package)) (supported-systems (package-supported-systems package)) (properties (package-properties package))) - `(package - (name ,name) - (version ,version) - (source ,(source->code source version)) - ,@(match properties - (() '()) - (_ `((properties ,properties)))) - ,@(if replacement - `((replacement ,replacement)) - '()) - (build-system ,(symbol-append (build-system-name build-system) - '-build-system)) - ,@(match arguments - (() '()) - (args `((arguments ,(list 'quasiquote args))))) - ,@(match outputs - (("out") '()) - (outs `((outputs (list ,@outs))))) - ,@(match native-inputs - (() '()) - (pkgs `((native-inputs ,(package-lists->code pkgs))))) - ,@(match inputs - (() '()) - (pkgs `((inputs ,(package-lists->code pkgs))))) - ,@(match propagated-inputs - (() '()) - (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) - ,@(if (lset= string=? supported-systems %supported-systems) - '() - `((supported-systems (list ,@supported-systems)))) - ,@(match (map search-path-specification->code native-search-paths) - (() '()) - (paths `((native-search-paths (list ,@paths))))) - ,@(match (map search-path-specification->code search-paths) - (() '()) - (paths `((search-paths (list ,@paths))))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,description) - (license ,(if (list? license) - `(list ,@(map license->code license)) - (license->code license)))))) + `(define-public ,(string->symbol name) + (package + (name ,name) + (version ,version) + (source ,(source->code source version)) + ,@(match properties + (() '()) + (_ `((properties ,properties)))) + ,@(if replacement + `((replacement ,replacement)) + '()) + (build-system (@ (guix build-system ,(build-system-name build-system)) + ,(symbol-append (build-system-name build-system) + '-build-system))) + ,@(match arguments + (() '()) + (args `((arguments ,(list 'quasiquote args))))) + ,@(match outputs + (("out") '()) + (outs `((outputs (list ,@outs))))) + ,@(match native-inputs + (() '()) + (pkgs `((native-inputs ,(package-lists->code pkgs))))) + ,@(match inputs + (() '()) + (pkgs `((inputs ,(package-lists->code pkgs))))) + ,@(match propagated-inputs + (() '()) + (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + ,@(if (lset= string=? supported-systems %supported-systems) + '() + `((supported-systems (list ,@supported-systems)))) + ,@(match (map search-path-specification->code native-search-paths) + (() '()) + (paths `((native-search-paths (list ,@paths))))) + ,@(match (map search-path-specification->code search-paths) + (() '()) + (paths `((search-paths (list ,@paths))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(if (list? license) + `(list ,@(map license->code license)) + (license->code license))))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 94c8cb040b..3809c3d074 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; @@ -310,7 +310,23 @@ the expected fields of an <origin> object." (uri (assoc-ref orig "uri")) (sha256 sha)))))) -(define (alist->package meta) +(define* (alist->package meta #:optional (known-inputs '())) + "Return a package value generated from the alist META. If the list of +strings KNOWN-INPUTS is provided, do not treat the mentioned inputs as +specifications to look up and replace them with plain symbols instead." + (define (process-inputs which) + (let-values (((regular known) + (lset-diff+intersection + string=? + (vector->list (or (assoc-ref meta which) #())) + known-inputs))) + (append (specs->package-lists regular) + (map string->symbol known)))) + (define (process-arguments arguments) + (append-map (match-lambda + ((key . value) + (list (symbol->keyword (string->symbol key)) value))) + arguments)) (package (name (assoc-ref meta "name")) (version (assoc-ref meta "version")) @@ -318,15 +334,13 @@ the expected fields of an <origin> object." (build-system (lookup-build-system-by-name (string->symbol (assoc-ref meta "build-system")))) - (native-inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "native-inputs") '#())))) - (inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "inputs") '#())))) - (propagated-inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "propagated-inputs") '#())))) + (arguments + (or (and=> (assoc-ref meta "arguments") + process-arguments) + '())) + (native-inputs (process-inputs "native-inputs")) + (inputs (process-inputs "inputs")) + (propagated-inputs (process-inputs "propagated-inputs")) (home-page (assoc-ref meta "home-page")) (synopsis diff --git a/guix/lint.scm b/guix/lint.scm index 2be3cc3ee3..e192f292a4 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. @@ -286,7 +286,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (define (check-inputs-should-be-native package) ;; Emit a warning if some inputs of PACKAGE are likely to belong to its ;; native inputs. - (let ((inputs (package-inputs package)) + (let ((inputs (append (package-inputs package) + (package-propagated-inputs package))) (input-names '("pkg-config" "autoconf" @@ -308,6 +309,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "intltool" "itstool" "libtool" + "m4" "qttools" "yasm" "nasm" "fasm" "python-coverage" "python2-coverage" @@ -684,7 +686,7 @@ patch could not be found." ;; Check whether we're reaching tar's maximum file name length. (let ((prefix (string-length (%distro-directory))) - (margin (string-length "guix-0.13.0-10-123456789/")) + (margin (string-length "guix-2.0.0rc3-10000-1234567890/")) (max 99)) (filter-map (match-lambda ((? string? patch) diff --git a/guix/packages.scm b/guix/packages.scm index 2552f8bf7c..2fa4fd05d7 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, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> @@ -111,6 +111,8 @@ package-output package-grafts package-patched-vulnerabilities + package-with-patches + package-with-extra-patches package/inherit transitive-input-references @@ -449,7 +451,7 @@ derivations." ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when ;; grafting packages. (let ((distro (resolve-interface '(gnu packages guile)))) - (module-ref distro 'guile-3.0))) + (module-ref distro 'guile-2.0))) (define* (default-guile-derivation #:optional (system (%current-system))) "Return the derivation for SYSTEM of the default Guile package used to run @@ -654,6 +656,18 @@ specifies modules in scope when evaluating SNIPPET." #:properties `((type . origin) (patches . ,(length patches))))))) +(define (package-with-patches original patches) + "Return package ORIGINAL with PATCHES applied." + (package (inherit original) + (source (origin (inherit (package-source original)) + (patches patches))))) + +(define (package-with-extra-patches original patches) + "Return package ORIGINAL with all PATCHES appended to its list of patches." + (package-with-patches original + (append (origin-patches (package-source original)) + patches))) + (define (transitive-inputs inputs) "Return the closure of INPUTS when considering the 'propagated-inputs' edges. Omit duplicate inputs, except for those already present in INPUTS @@ -1029,39 +1043,39 @@ information in exceptions." #:key (graft? (%graft?))) "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, and return it." - (cached (=> %bag-cache) - package (list system target graft?) - ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked - ;; field values can refer to it. - (parameterize ((%current-system system) - (%current-target-system target)) - (match (if graft? - (or (package-replacement package) package) - package) - ((and self - ($ <package> name version source build-system - args inputs propagated-inputs native-inputs - outputs)) - ;; Even though we prefer to use "@" to separate the package - ;; name from the package version in various user-facing parts - ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) - ;; prohibits the use of "@", so use "-" instead. - (or (make-bag build-system (string-append name "-" version) - #:system system - #:target target - #:source source - #:inputs (append (inputs self) - (propagated-inputs self)) - #:outputs outputs - #:native-inputs (native-inputs self) - #:arguments (args self)) - (raise (if target - (condition - (&package-cross-build-system-error - (package package))) - (condition - (&package-error - (package package))))))))))) + (let ((package (or (and graft? (package-replacement package)) + package))) + (cached (=> %bag-cache) + package (list system target) + ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked + ;; field values can refer to it. + (parameterize ((%current-system system) + (%current-target-system target)) + (match package + ((and self + ($ <package> name version source build-system + args inputs propagated-inputs native-inputs + outputs)) + ;; Even though we prefer to use "@" to separate the package + ;; name from the package version in various user-facing parts + ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) + ;; prohibits the use of "@", so use "-" instead. + (or (make-bag build-system (string-append name "-" version) + #:system system + #:target target + #:source source + #:inputs (append (inputs self) + (propagated-inputs self)) + #:outputs outputs + #:native-inputs (native-inputs self) + #:arguments (args self)) + (raise (if target + (condition + (&package-cross-build-system-error + (package package))) + (condition + (&package-error + (package package)))))))))))) (define %graft-cache ;; 'eq?' cache mapping package objects to a graft corresponding to their @@ -1326,7 +1340,11 @@ code of derivations to GUILE, a package object." "Return as a monadic value the absolute file name of FILE within the OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the OUTPUT directory of PACKAGE. When TARGET is true, use it as a -cross-compilation target triplet." +cross-compilation target triplet. + +Note that this procedure does _not_ build PACKAGE. Thus, the result might or +might not designate an existing file. We recommend not using this procedure +unless you know what you are doing." (lambda (store) (define compute-derivation (if target diff --git a/guix/profiles.scm b/guix/profiles.scm index 3a6498993c..ab265cce62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -87,6 +87,9 @@ manifest-entry-search-paths manifest-entry-parent manifest-entry-properties + lower-manifest-entry + + manifest-entry=? manifest-pattern manifest-pattern? @@ -122,6 +125,15 @@ profile-derivation profile-search-paths + profile + profile? + profile-name + profile-content + profile-hooks + profile-locales? + profile-allow-collisions? + profile-relative-symlinks? + generation-number generation-profile generation-numbers @@ -216,6 +228,33 @@ (output manifest-pattern-output ; string | #f (default "out"))) +(define (list=? = lst1 lst2) + "Return true if LST1 and LST2 have the same length and their elements are +pairwise equal per =." + (match lst1 + (() + (null? lst2)) + ((head1 . tail1) + (match lst2 + ((head2 . tail2) + (and (= head1 head2) (list=? = tail1 tail2))) + (() + #f))))) + +(define (manifest-entry=? entry1 entry2) + "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties' +field." + (match entry1 + (($ <manifest-entry> name1 version1 output1 item1 dependencies1 paths1) + (match entry2 + (($ <manifest-entry> name2 version2 output2 item2 dependencies2 paths2) + (and (string=? name1 name2) + (string=? version1 version2) + (string=? output1 output2) + (equal? item1 item2) ;XXX: could be <package> vs. store item + (equal? paths1 paths2) + (list=? manifest-entry=? dependencies1 dependencies2))))))) + (define (manifest-transitive-entries manifest) "Return the entries of MANIFEST along with their propagated inputs, recursively." @@ -263,16 +302,24 @@ procedure takes two arguments: the entry name and output." (define* (lower-manifest-entry entry system #:key target) "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store file name." + (define (recurse entry) + (mapm/accumulate-builds (lambda (entry) + (lower-manifest-entry entry system + #:target target)) + (manifest-entry-dependencies entry))) + (let ((item (manifest-entry-item entry))) (if (string? item) (with-monad %store-monad (return entry)) (mlet %store-monad ((drv (lower-object item system #:target target)) + (dependencies (recurse entry)) (output -> (manifest-entry-output entry))) (return (manifest-entry (inherit entry) - (item (derivation->output-path drv output)))))))) + (item (derivation->output-path drv output)) + (dependencies dependencies))))))) (define* (check-for-collisions manifest system #:key target) "Check whether the entries of MANIFEST conflict with one another; raise a @@ -280,29 +327,37 @@ file name." (define lookup (manifest-entry-lookup manifest)) - (with-monad %store-monad + (define candidates + (filter-map (lambda (entry) + (let ((other (lookup (manifest-entry-name entry) + (manifest-entry-output entry)))) + (and other (list entry other)))) + (manifest-transitive-entries manifest))) + + (define lower-pair + (match-lambda + ((first second) + (mlet %store-monad ((first (lower-manifest-entry first system + #:target target)) + (second (lower-manifest-entry second system + #:target target))) + (return (list first second)))))) + + ;; Start by lowering CANDIDATES "in parallel". + (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates))) (foldm %store-monad - (lambda (entry result) - (match (lookup (manifest-entry-name entry) - (manifest-entry-output entry)) - ((? manifest-entry? second) ;potential conflict - (mlet %store-monad ((first (lower-manifest-entry entry system - #:target - target)) - (second (lower-manifest-entry second system - #:target - target))) - (if (string=? (manifest-entry-item first) - (manifest-entry-item second)) - (return result) - (raise (condition - (&profile-collision-error - (entry first) - (conflict second))))))) - (#f ;no conflict - (return result)))) + (lambda (entries result) + (match entries + ((first second) + (if (string=? (manifest-entry-item first) + (manifest-entry-item second)) + (return result) + (raise (condition + (&profile-collision-error + (entry first) + (conflict second)))))))) #t - (manifest-transitive-entries manifest)))) + lst))) (define* (package->manifest-entry package #:optional (output "out") #:key (parent (delay #f)) @@ -1372,26 +1427,38 @@ the entries in MANIFEST." #~(begin (use-modules (guix man-db) (guix build utils) + (ice-9 threads) (srfi srfi-1) (srfi srfi-19)) + (define (print-string msg) + (display msg) + (force-output)) + + (define-syntax-rule (print fmt args ...) + ;; Build up the string and display it at once. + (print-string (format #f fmt args ...))) + + (define (compute-entry directory count total) + (print "\r[~3d/~3d] building list of man-db entries..." + count total) + (let ((man (string-append directory "/share/man"))) + (if (directory-exists? man) + (mandb-entries man) + '()))) + (define (compute-entries) ;; This is the most expensive part (I/O and CPU, due to ;; decompression), so report progress as we traverse INPUTS. - (let* ((inputs '#$(manifest-inputs manifest)) - (total (length inputs))) - (append-map (lambda (directory count) - (format #t "\r[~3d/~3d] building list of \ -man-db entries..." - count total) - (force-output) - (let ((man (string-append directory - "/share/man"))) - (if (directory-exists? man) - (mandb-entries man) - '()))) - inputs - (iota total 1)))) + ;; Cap at 4 threads because we don't see any speedup beyond that + ;; on an SSD laptop. + (let* ((inputs '#$(manifest-inputs manifest)) + (total (length inputs)) + (threads (min (parallel-job-count) 4))) + (concatenate + (n-par-map threads compute-entry inputs + (iota total 1) + (make-list total total))))) (define man-directory (string-append #$output "/share/man")) @@ -1489,6 +1556,7 @@ MANIFEST." (define* (profile-derivation manifest #:key + (name "profile") (hooks %default-profile-hooks) (locales? #t) (allow-collisions? #f) @@ -1521,10 +1589,9 @@ are cross-built for TARGET." #:target target))) (extras (if (null? (manifest-entries manifest)) (return '()) - (mapm %store-monad - (lambda (hook) - (hook manifest)) - hooks)))) + (mapm/accumulate-builds (lambda (hook) + (hook manifest)) + hooks)))) (define inputs (append (filter-map (lambda (drv) (and (derivation? drv) @@ -1577,7 +1644,7 @@ are cross-built for TARGET." #:manifest '#$(manifest->gexp manifest) #:search-paths search-paths)))) - (gexp->derivation "profile" builder + (gexp->derivation name builder #:system system #:target target @@ -1598,6 +1665,33 @@ are cross-built for TARGET." . ,(length (manifest-entries manifest)))))))) +;; Declarative profile. +(define-record-type* <profile> profile make-profile + profile? + (name profile-name (default "profile")) ;string + (content profile-content) ;<manifest> + (hooks profile-hooks ;list of procedures + (default %default-profile-hooks)) + (locales? profile-locales? ;Boolean + (default #t)) + (allow-collisions? profile-allow-collisions? ;Boolean + (default #f)) + (relative-symlinks? profile-relative-symlinks? ;Boolean + (default #f))) + +(define-gexp-compiler (profile-compiler (profile <profile>) system target) + "Compile PROFILE to a derivation." + (match profile + (($ <profile> name manifest hooks + locales? allow-collisions? relative-symlinks?) + (profile-derivation manifest + #:name name + #:hooks hooks + #:locales? locales? + #:allow-collisions? allow-collisions? + #:relative-symlinks? relative-symlinks? + #:system system #:target target)))) + (define* (profile-search-paths profile #:optional (manifest (profile-manifest profile)) #:key (getenv (const #f))) diff --git a/guix/records.scm b/guix/records.scm index 4bda5426a3..3d54a51956 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:autoload (system base target) (target-most-positive-fixnum) #:export (define-record-type* this-record @@ -360,7 +361,9 @@ inherited." (((field get properties ...) ...) (string-hash (object->string (syntax->datum #'((field properties ...) ...))) - most-positive-fixnum)))) + (cond-expand + (guile-3 (target-most-positive-fixnum)) + (else most-positive-fixnum)))))) (syntax-case s () ((_ type syntactic-ctor ctor pred diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 80f3b704d7..41a2a42c21 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -183,7 +183,7 @@ Export/import one or more packages from/to the store.\n")) (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) %standard-build-options)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index af18d8b6f9..8ff2fd1910 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (guix scripts build) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix import json) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) @@ -778,7 +780,7 @@ must be one of 'package', 'all', or 'transitive'~%") (alist-cons 'manifest arg result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -834,7 +836,10 @@ build---packages, gexps, derivations, and so on." (else (list (specification->package spec))))) (('file . file) - (ensure-list (load* file (make-user-module '())))) + (let ((file (or (and (string-suffix? ".json" file) + (json->scheme-file file)) + file))) + (ensure-list (load* file (make-user-module '()))))) (('manifest . manifest) (map manifest-entry-item (manifest-entries @@ -920,8 +925,10 @@ build." (with-unbound-variable-handling (parameterize ((%graft? graft?)) (append-map (lambda (system) - (append-map (cut compute-derivation <> system) - things-to-build)) + (concatenate + (map/accumulate-builds store + (cut compute-derivation <> system) + things-to-build))) systems)))) (define (show-build-log store file urls) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 2fa31ecf45..f6f64d0a11 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -135,7 +135,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\h "help") #f #f (lambda args diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 5c871cd6ed..4466a0c632 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -30,6 +30,7 @@ #:use-module (guix status) #:use-module (ice-9 format) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) @@ -114,6 +115,27 @@ Perform the deployment specified by FILE.\n")) (current-error-port)) (display "\n\n" (current-error-port)))) +(define (deploy-machine* store machine) + "Deploy MACHINE, taking care of error handling." + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine)) + + (info (G_ "successfully deployed ~a~%") + (machine-display-name machine)))) + + (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) @@ -129,21 +151,7 @@ Perform the deployment specified by FILE.\n")) (set-build-options-from-command-line store opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?)) - (for-each (lambda (machine) - (info (G_ "deploying to ~a...~%") - (machine-display-name machine)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) - ((deploy-error? c) - (when (deploy-error-should-roll-back c) - (info (G_ "rolling back ~a...~%") - (machine-display-name machine)) - (run-with-store store (roll-back-machine machine))) - (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine)) - (info (G_ "successfully deployed ~a~%") - (machine-display-name machine))))) - machines)))))) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines))))))) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index a6fd1d2751..43f3011869 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -56,10 +56,9 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (show-bug-report-information)) (define %editor - ;; XXX: It would be better to default to something more likely to be - ;; pre-installed on an average GNU system. Since Nano is not suited for - ;; editing Scheme, Emacs is used instead. - (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") "emacs"))) + ;; Nano is sensible default, as it is installed by base system. + ;; For development, user can set custom value for $EDITOR. + (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") "nano"))) (define (search-path* path file) "Like 'search-path' but exit if FILE is not found." diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index ca12346815..bfc4039c2b 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -256,7 +256,7 @@ use '--preserve' instead~%")) (alist-cons 'ad-hoc? #t result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm index c9daf65479..778e5f4bc5 100644 --- a/guix/scripts/import/json.scm +++ b/guix/scripts/import/json.scm @@ -23,7 +23,7 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import utils) - #:use-module (guix import print) + #:use-module (guix import json) #:use-module (guix scripts import) #:use-module (guix packages) #:use-module (srfi srfi-1) @@ -88,14 +88,8 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n")) (reverse opts)))) (match args ((file-name) - (catch 'json-invalid - (lambda () - (let ((json (json-string->scm - (with-input-from-file file-name read-string)))) - ;; TODO: also print define-module boilerplate - (package->code (alist->package json)))) - (lambda _ - (leave (G_ "invalid JSON in file '~a'~%") file-name)))) + (or (json->code file-name) + (leave (G_ "invalid JSON in file '~a'~%") file-name))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index b6fb73838d..f3d1b41c6f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -823,7 +823,7 @@ last resort for relocation." (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\d "derivation") #f #f (lambda (opt name arg result) (alist-cons 'derivation-only? #t result))) @@ -1071,7 +1071,21 @@ Create a bundle of PACKAGE.\n")) (localstatedir? (assoc-ref opts 'localstatedir?)) (entry-point (assoc-ref opts 'entry-point)) (profile-name (assoc-ref opts 'profile-name)) - (gc-root (assoc-ref opts 'gc-root))) + (gc-root (assoc-ref opts 'gc-root)) + (profile (profile + (content manifest) + + ;; Always produce relative symlinks for + ;; Singularity (see + ;; <https://bugs.gnu.org/34913>). + (relative-symlinks? + (or relocatable? + (eq? 'squashfs pack-format))) + + (hooks (if bootstrap? + '() + %default-profile-hooks)) + (locales? (not bootstrap?))))) (define (lookup-package package) (manifest-lookup manifest (manifest-pattern (name package)))) @@ -1085,22 +1099,7 @@ Create a bundle of PACKAGE.\n")) to your package list."))) (run-with-store store - (mlet* %store-monad ((profile (profile-derivation - manifest - - ;; Always produce relative - ;; symlinks for Singularity (see - ;; <https://bugs.gnu.org/34913>). - #:relative-symlinks? - (or relocatable? - (eq? 'squashfs pack-format)) - - #:hooks (if bootstrap? - '() - %default-profile-hooks) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile + (mlet* %store-monad ((drv (build-image name profile #:target target #:compressor @@ -1128,4 +1127,5 @@ to your package list."))) gc-root)) (return (format #t "~a~%" (derivation->output-path drv)))))) + #:target target #:system (assoc-ref opts 'system))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 110d4f2977..2eb18919cc 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +34,7 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix search-paths) + #:use-module (guix import json) #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) @@ -61,6 +63,8 @@ delete-matching-generations guix-package + search-path-environment-variables + transaction-upgrade-entry ;mostly for testing (%options . %package-options) @@ -199,6 +203,10 @@ non-zero relevance score." (define (transaction-upgrade-entry store entry transaction) "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a <manifest-entry>." + (define (lower-manifest-entry* entry) + (run-with-store store + (lower-manifest-entry entry (%current-system)))) + (define (supersede old new) (info (G_ "package '~a' has been superseded by '~a'~%") (manifest-entry-name old) (package-name new)) @@ -211,40 +219,44 @@ non-zero relevance score." (output (manifest-entry-output old))) transaction))) - (match (if (manifest-transaction-removal-candidate? entry transaction) - 'dismiss - entry) - ('dismiss - transaction) - (($ <manifest-entry> name version output (? string? path)) - (match (find-best-packages-by-name name #f) - ((pkg . rest) - (let ((candidate-version (package-version pkg))) - (match (package-superseded pkg) - ((? package? new) - (supersede entry new)) - (#f - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation store pkg)))) - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (string=? path candidate-path) - (null? (package-propagated-inputs pkg))) - transaction - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction))))))))) - (() - (warning (G_ "package '~a' no longer exists~%") name) - transaction))))) + (define (upgrade entry) + (match entry + (($ <manifest-entry> name version output (? string? path)) + (match (find-best-packages-by-name name #f) + ((pkg . rest) + (let ((candidate-version (package-version pkg))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction)) + ((<) + transaction) + ((=) + (let* ((new (package->manifest-entry* pkg output))) + ;; Here we want to determine whether the NEW actually + ;; differs from ENTRY, but we need to intercept + ;; 'build-things' calls because they would prevent us from + ;; displaying the list of packages to install/upgrade + ;; upfront. Thus, if lowering NEW triggers a build (due + ;; to grafts), assume NEW differs from ENTRY. + (if (with-build-handler (const #f) + (manifest-entry=? (lower-manifest-entry* new) + entry)) + transaction + (manifest-transaction-install-entry + new transaction))))))))) + (() + (warning (G_ "package '~a' no longer exists~%") name) + transaction))))) + + (if (manifest-transaction-removal-candidate? entry transaction) + transaction + (upgrade entry))) ;;; @@ -410,7 +422,10 @@ Install, remove, or upgrade packages in a single transaction.\n")) (option '(#\f "install-from-file") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'install - (load* arg (make-user-module '())) + (let ((file (or (and (string-suffix? ".json" arg) + (json->scheme-file arg)) + arg))) + (load* file (make-user-module '()))) result) #f))) (option '(#\r "remove") #f #t @@ -489,8 +504,7 @@ kind of search path~%") #f))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result arg-handler) - (values (alist-cons 'dry-run? #t - (alist-cons 'graft? #f result)) + (values (alist-cons 'dry-run? #t result) #f))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result arg-handler) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index b7e0a4a416..42c9956136 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -168,7 +168,7 @@ Download and deploy the latest version of Guix.\n")) (alist-delete 'system result eq?)))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 95b47a7816..ba2b2d2d4e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -494,7 +494,8 @@ MAX-LENGTH first elements." (loop (+ 1 len) tail (cons head result))))))) (define* (http-multiple-get base-uri proc seed requests - #:key port (verify-certificate? #t)) + #:key port (verify-certificate? #t) + (batch-size 1000)) "Send all of REQUESTS to the server at BASE-URI. Call PROC for each response, passing it the request object, the response, a port from which to read the response body, and the previous result, starting with SEED, à la @@ -504,7 +505,7 @@ initial connection on which HTTP requests are sent." (requests requests) (result seed)) (define batch - (at-most 1000 requests)) + (at-most batch-size requests)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) @@ -536,9 +537,10 @@ initial connection on which HTTP requests are sent." (() (match (drop requests processed) (() + (close-port p) (reverse result)) (remainder - (connect port remainder result)))) + (connect p remainder result)))) ((head tail ...) (let* ((resp (read-response p)) (body (response-body-port resp)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 61a3c95dbd..2664c66a30 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -258,7 +258,7 @@ expression in %STORE-MONAD." (lambda () (guard (c ((shepherd-error? c) (values (report-shepherd-error c) store))) - (values (run-with-store store (begin mbody ...)) + (values (run-with-store store (mbegin %store-monad mbody ...)) store))) (lambda (key proc format-string format-args errno . rest) (warning (G_ "while talking to shepherd: ~a~%") @@ -290,22 +290,6 @@ on service '~a':~%") ((not error) ;not an error #t))) -(define (call-with-service-upgrade-info new-services mproc) - "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of -names of services to load (upgrade), and the list of names of services to -unload." - (match (current-services) - ((services ...) - (let-values (((to-unload to-restart) - (shepherd-service-upgrade services new-services))) - (mproc to-restart - (map (compose first live-service-provision) - to-unload)))) - (#f - (with-monad %store-monad - (warning (G_ "failed to obtain list of shepherd services~%")) - (return #f))))) - (define-syntax-rule (unless-file-not-found exp) (catch 'system-error (lambda () @@ -825,10 +809,10 @@ static checks." ;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; --no-bootloader is passed, because we then use it as a GC root. ;; See <http://bugs.gnu.org/21068>. - (drvs (mapm %store-monad lower-object - (if (memq action '(init reconfigure)) - (list sys bootcfg) - (list sys)))) + (drvs (mapm/accumulate-builds lower-object + (if (memq action '(init reconfigure)) + (list sys bootcfg) + (list sys)))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) @@ -853,7 +837,10 @@ static checks." (info (G_ "bootloader successfully installed on '~a'~%") (bootloader-configuration-target bootloader)))) (with-shepherd-error-handling - (upgrade-shepherd-services local-eval os)))) + (upgrade-shepherd-services local-eval os) + (return (format #t (G_ "\ +To complete the upgrade, run 'herd restart SERVICE' to stop, +upgrade, and restart each service that was not automatically restarted.\n")))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") @@ -1041,7 +1028,7 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) @@ -1294,7 +1281,6 @@ argument list and OPTS is the option alist." (process-command command args opts)))))) ;;; Local Variables: -;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) ;;; eval: (put 'with-store* 'scheme-indent-function 1) ;;; End: diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 77a72307b4..7885c33457 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -33,6 +33,7 @@ #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix store) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -60,6 +61,14 @@ ;;; Profile creation. ;;; +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (_ #f))) + (define* (switch-system-program os #:optional profile) "Return an executable store item that, upon being evaluated, will create a new generation of PROFILE pointing to the directory of OS, switch to it @@ -67,9 +76,11 @@ atomically, and run OS's activation script." (program-file "switch-to-system.scm" (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((guix config) - (guix profiles) - (guix utils))) + (with-imported-modules `(,@(source-module-closure + '((guix profiles) + (guix utils)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) #~(begin (use-modules (guix config) (guix profiles) @@ -89,7 +100,8 @@ atomically, and run OS's activation script." "Using EVAL, a monadic procedure taking a single G-Expression as an argument, create a new generation of PROFILE pointing to the directory of OS, switch to it atomically, and run OS's activation script." - (eval #~(primitive-load #$(switch-system-program os profile)))) + (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) + (primitive-load #$(switch-system-program os profile))))) ;;; @@ -165,10 +177,11 @@ services as defined by OS." (map live-service-canonical-name live-services))) (service-files (map shepherd-service-file target-services))) - (eval #~(primitive-load #$(upgrade-services-program service-files - to-start - to-unload - to-restart))))))) + (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) + (primitive-load #$(upgrade-services-program service-files + to-start + to-unload + to-restart)))))))) ;;; @@ -184,10 +197,13 @@ BOOTLOADER-PACKAGE." (program-file "install-bootloader.scm" (with-extensions (list guile-gcrypt) - (with-imported-modules (source-module-closure '((gnu build bootloader) - (gnu build install) - (guix store) - (guix utils))) + (with-imported-modules `(,@(source-module-closure + '((gnu build bootloader) + (gnu build install) + (guix store) + (guix utils)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) #~(begin (use-modules (gnu build bootloader) (gnu build install) @@ -195,8 +211,10 @@ BOOTLOADER-PACKAGE." (guix store) (guix utils) (ice-9 binary-ports) + (ice-9 match) (srfi srfi-34) (srfi srfi-35)) + (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg")) (new-gc-root (string-append gc-root ".new"))) ;; #$bootcfg has dependencies. @@ -218,7 +236,11 @@ BOOTLOADER-PACKAGE." (#$installer #$bootloader-package #$device #$target)) (lambda args (delete-file new-gc-root) - (apply throw args)))) + (match args + (('%exception exception) ;Guile 3 SRFI-34 or similar + (raise-exception exception)) + ((key . args) + (apply throw key args)))))) ;; We are sure that the installation of the bootloader ;; succeeded, so we can replace the old GC root by the new ;; GC root now. @@ -237,9 +259,10 @@ additional configurations specified by MENU-ENTRIES can be selected." (package (bootloader-package bootloader)) (device (bootloader-configuration-target configuration)) (bootcfg-file (bootloader-configuration-file bootloader))) - (eval #~(primitive-load #$(install-bootloader-program installer - package - bootcfg - bootcfg-file - device - target))))) + (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) + (primitive-load #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target)))))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index eb76771452..475d989357 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -339,8 +339,9 @@ Report the availability of substitutes.\n")) "Load the manifest from FILE and return the list of packages it refers to." (let* ((user-module (make-user-module '((guix profiles) (gnu)))) (manifest (load* file user-module))) - (map manifest-entry-item - (manifest-transitive-entries manifest)))) + (delete-duplicates (map manifest-entry-item + (manifest-transitive-entries manifest)) + eq?))) ;;; diff --git a/guix/self.scm b/guix/self.scm index 6b633f9bc0..4682cd221c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -339,43 +339,61 @@ TRANSLATIONS, an alist of msgid and msgstr." #f regexp1 content 'pre "ref{" msgstr "," 'post) 'pre "ref{" msgstr "}" 'post)))))) content translations)) - - (define (translate-texi po lang) - "Translate the manual for one language LANG using the PO file." + + (define* (translate-texi prefix po lang + #:key (extras '())) + "Translate the manual for one language LANG using the PO file. +PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'. EXTRAS is +a list of extra files, such as '(\"contributing\")." (let ((translations (call-with-input-file po read-po-file))) - (translate-tmp-texi po "guix.texi" - (string-append "guix." lang ".texi.tmp")) - (translate-tmp-texi po "contributing.texi" - (string-append "contributing." lang ".texi.tmp")) - (let* ((texi-name (string-append "guix." lang ".texi")) - (tmp-name (string-append texi-name ".tmp"))) - (with-output-to-file texi-name - (lambda _ - (format #t "~a" - (translate-cross-references - (call-with-input-file tmp-name get-string-all) - translations))))) - (let* ((texi-name (string-append "contributing." lang ".texi")) - (tmp-name (string-append texi-name ".tmp"))) - (with-output-to-file texi-name - (lambda _ - (format #t "~a" - (translate-cross-references - (call-with-input-file tmp-name get-string-all) - translations))))))) - - (for-each (lambda (po) - (match (reverse (string-split po #\.)) - ((_ lang _ ...) - (translate-texi po lang)))) - (find-files "." "^guix-manual\\.[a-z]{2}(_[A-Z]{2})?\\.po$")) + (for-each (lambda (file) + (translate-tmp-texi po (string-append file ".texi") + (string-append file "." lang + ".texi.tmp"))) + (cons prefix extras)) + + (for-each (lambda (file) + (let* ((texi (string-append file "." lang ".texi")) + (tmp (string-append texi ".tmp"))) + (with-output-to-file texi + (lambda () + (display + (translate-cross-references + (call-with-input-file tmp get-string-all) + translations)))))) + (cons prefix extras)))) + + (define (available-translations directory domain) + ;; Return the list of available translations under DIRECTORY for + ;; DOMAIN, a gettext domain such as "guix-manual". The result is + ;; a list of language/PO file pairs. + (filter-map (lambda (po) + (let ((base (basename po))) + (and (string-prefix? (string-append domain ".") + base) + (match (string-split base #\.) + ((_ ... lang "po") + (cons lang po)))))) + (find-files directory + "\\.[a-z]{2}(_[A-Z]{2})?\\.po$"))) + + (for-each (match-lambda + ((language . po) + (translate-texi "guix" po language + #:extras '("contributing")))) + (available-translations "." "guix-manual")) + + (for-each (match-lambda + ((language . po) + (translate-texi "guix-cookbook" po language))) + (available-translations "." "guix-cookbook")) - (for-each - (lambda (file) - (copy-file file (string-append #$output "/" file))) - (append - (find-files "." "contributing\\..*\\.texi$") - (find-files "." "guix\\..*\\.texi$")))))) + (for-each (lambda (file) + (install-file file #$output)) + (append + (find-files "." "contributing\\..*\\.texi$") + (find-files "." "guix\\..*\\.texi$") + (find-files "." "guix-cookbook\\..*\\.texi$")))))) (computed-file "guix-translated-texinfo" build)) @@ -402,7 +420,8 @@ TRANSLATIONS, an alist of msgid and msgstr." (define build (with-imported-modules '((guix build utils)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (ice-9 match)) (mkdir #$output) @@ -463,13 +482,13 @@ TRANSLATIONS, an alist of msgid and msgstr." #+(file-append glibc-utf8-locales "/lib/locale")) (for-each (lambda (texi) - (unless (string=? "guix.texi" texi) - ;; Create 'version-LL.texi'. - (let* ((base (basename texi ".texi")) - (dot (string-index base #\.)) - (tag (string-drop base (+ 1 dot)))) - (symlink "version.texi" - (string-append "version-" tag ".texi")))) + (match (string-split (basename texi) #\.) + (("guix" language "texi") + ;; Create 'version-LL.texi'. + (symlink "version.texi" + (string-append "version-" language + ".texi"))) + (_ #f)) (invoke #+(file-append texinfo "/bin/makeinfo") texi "-I" #$documentation @@ -478,7 +497,10 @@ TRANSLATIONS, an alist of msgid and msgstr." (basename texi ".texi") ".info"))) (cons "guix.texi" - (find-files "." "^guix\\.[a-z]{2}(_[A-Z]{2})?\\.texi$"))) + (append (find-files "." + "^guix\\.[a-z]{2}(_[A-Z]{2})?\\.texi$") + (find-files "." + "^guix-cookbook.*\\.texi$")))) ;; Compress Info files. (setenv "PATH" @@ -489,6 +511,13 @@ TRANSLATIONS, an alist of msgid and msgstr." (computed-file "guix-manual" build)) +(define-syntax-rule (prevent-inlining! identifier ...) + (begin (set! identifier identifier) ...)) + +;; XXX: These procedures are actually used by 'doc/build.scm'. Protect them +;; from inlining on Guile 3. +(prevent-inlining! file-append* translate-texi-manuals info-manual) + (define* (guile-module-union things #:key (name "guix-module-union")) "Return the union of the subset of THINGS (packages, computed files, etc.) that provide Guile modules." diff --git a/guix/status.scm b/guix/status.scm index 4b2edc2f3c..f40d5d59b9 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,8 +472,8 @@ addition to build events." (let ((count (match (assq-ref properties 'graft) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "applying ~a graft for ~a..." - "applying ~a grafts for ~a..." + (format port (info (N_ "applying ~a graft for ~a ..." + "applying ~a grafts for ~a ..." count)) count drv))) ('profile @@ -525,7 +525,7 @@ addition to build events." (newline port))) (('download-started item uri _ ...) (erase-current-line*) - (format port (info (G_ "downloading from ~a...")) uri) + (format port (info (G_ "downloading from ~a ...")) uri) (newline port)) (('download-progress item uri (= string->number size) diff --git a/guix/store.scm b/guix/store.scm index fdaae27914..fb4b92e0c4 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -105,6 +105,8 @@ add-file-tree-to-store binary-file with-build-handler + map/accumulate-builds + mapm/accumulate-builds build-things build query-failed-paths @@ -133,6 +135,7 @@ built-in-builders references + references/cached references/substitutes references* query-path-info* @@ -620,14 +623,25 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (dynamic-wind - (const #f) - (lambda () - (parameterize ((current-store-protocol-version - (store-connection-version store))) - (proc store))) - (lambda () - (false-if-exception (close-connection store)))))) + (define (thunk) + (parameterize ((current-store-protocol-version + (store-connection-version store))) + (let ((result (proc store))) + (close-connection store) + result))) + + (cond-expand + (guile-3 + (with-exception-handler (lambda (exception) + (close-connection store) + (raise-exception exception)) + thunk)) + (else ;Guile 2.2 + (catch #t + thunk + (lambda (key . args) + (close-connection store) + (apply throw key args))))))) (define-syntax-rule (with-store store exp ...) "Bind STORE to an open connection to the store and evaluate EXPs; @@ -1263,6 +1277,48 @@ deals with \"dynamic dependencies\" such as grafts---derivations that depend on the build output of a previous derivation." (call-with-build-handler handler (lambda () exp ...))) +;; Unresolved dynamic dependency. +(define-record-type <unresolved> + (unresolved things continuation) + unresolved? + (things unresolved-things) + (continuation unresolved-continuation)) + +(define (build-accumulator continue store things mode) + "This build handler accumulates THINGS and returns an <unresolved> object." + (if (= mode (build-mode normal)) + (unresolved things continue) + (continue #t))) + +(define (map/accumulate-builds store proc lst) + "Apply PROC over each element of LST, accumulating 'build-things' calls and +coalescing them into a single call." + (define result + (map (lambda (obj) + (with-build-handler build-accumulator + (proc obj))) + lst)) + + (match (append-map (lambda (obj) + (if (unresolved? obj) + (unresolved-things obj) + '())) + result) + (() + result) + (to-build + ;; We've accumulated things TO-BUILD. Actually build them and resume the + ;; corresponding continuations. + (build-things store (delete-duplicates to-build)) + (map/accumulate-builds store + (lambda (obj) + (if (unresolved? obj) + ;; Pass #f because 'build-things' is now + ;; unnecessary. + ((unresolved-continuation obj) #f) + obj)) + result)))) + (define build-things (let ((build (operation (build-things (string-list things) (integer mode)) @@ -1349,6 +1405,13 @@ error if there is no such root." ;; would use a cache associated with the daemon connection instead (XXX). (make-hash-table 100)) +(define (references/cached store item) + "Like 'references', but cache results." + (or (hash-ref %reference-cache item) + (let ((references (references store item))) + (hash-set! %reference-cache item references) + references))) + (define (references/substitutes store items) "Return the list of list of references of ITEMS; the result has the same length as ITEMS. Query substitute information for any item missing from the @@ -1789,6 +1852,18 @@ taking the store as its first argument." (lambda (store . args) (run-with-store store (apply proc args))))) +(define (mapm/accumulate-builds mproc lst) + "Like 'mapm' in %STORE-MONAD, but accumulate 'build-things' calls and +coalesce them into a single call." + (lambda (store) + (values (map/accumulate-builds store + (lambda (obj) + (run-with-store store + (mproc obj))) + lst) + store))) + + ;; ;; Store monad operators. ;; diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 21573ac14e..566660e85e 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +30,24 @@ (define git-command (make-parameter "git")) +(define (call-with-environment-variables variables thunk) + "Call THUNK with the environment VARIABLES set." + (let ((environment (environ))) + (dynamic-wind + (lambda () + (for-each (match-lambda + ((variable value) + (setenv variable value))) + variables)) + thunk + (lambda () + (environ environment))))) + +(define-syntax-rule (with-environment-variables variables exp ...) + "Evaluate EXP with the given environment VARIABLES set." + (call-with-environment-variables variables + (lambda () exp ...))) + (define (populate-git-repository directory directives) "Initialize a new Git checkout and repository in DIRECTORY and apply DIRECTIVES. Each element of DIRECTIVES is an sexp like: @@ -41,8 +59,21 @@ Return DIRECTORY on success." ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do ;; all this, so resort to the "git" command. (define (git command . args) - (apply invoke (git-command) "-C" directory - command args)) + ;; Make sure Git doesn't rely on the user's config. + (call-with-temporary-directory + (lambda (home) + (call-with-output-file (string-append home "/.gitconfig") + (lambda (port) + (display "[user] + email = charlie@example.org\n name = Charlie Guix\n" + port))) + + (with-environment-variables + `(("GIT_CONFIG_NOSYSTEM" "1") + ("GIT_ATTR_NOSYSTEM" "1") + ("HOME" ,home)) + (apply invoke (git-command) "-C" directory + command args))))) (mkdir-p directory) (git "init") diff --git a/guix/ui.scm b/guix/ui.scm index 1e24fe5dca..ea5f460865 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -234,8 +234,8 @@ information, or #f if it could not be found." ;; Give 'load' an absolute file name so that it doesn't try to ;; search for FILE in %LOAD-PATH. Note: use 'load', not - ;; 'primitive-load', so that FILE is compiled, which then allows us - ;; to provide better error reporting with source line numbers. + ;; 'primitive-load', so that FILE is compiled, which then allows + ;; us to provide better error reporting with source line numbers. (load (canonicalize-path file))) (const #f)))))) (lambda _ @@ -796,7 +796,7 @@ directories:~{ ~a~}~%") (apply format #f format-string format-args)))))) (define-syntax-rule (leave-on-EPIPE exp ...) - "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' + "Run EXP... in a context where EPIPE errors are caught and lead to 'exit' with successful exit code. This is useful when writing to the standard output may lead to EPIPE, because the standard output is piped through 'head' or similar." @@ -925,7 +925,7 @@ download." drv)) (define substitutable-info - ;; Call 'substitutation-oracle' upfront so we don't end up launching the + ;; Call 'substitution-oracle' upfront so we don't end up launching the ;; substituter many times. This makes a big difference, especially when ;; DRV is a long list as is the case with 'guix environment'. (if use-substitutes? @@ -1164,7 +1164,7 @@ separator between subsequent columns." names outputs) (map (lambda (old new) (if (string=? old new) - (G_ "(dependencies changed)") + (G_ "(dependencies or package changed)") (string-append old " " → " " new))) old-version new-version)) #:initial-indent 3)) @@ -1251,7 +1251,7 @@ separator between subsequent columns." (define* (indented-string str indent #:key (initial-indent? #t)) - "Return STR with each newline preceded by IDENT spaces. When + "Return STR with each newline preceded by INDENT spaces. When INITIAL-INDENT? is true, the first line is also indented." (define indent-string (make-list indent #\space)) @@ -1534,7 +1534,7 @@ score, the more relevant OBJ is to REGEXPS." (,(lambda (package) (filter (lambda (output) (not (member output - ;; Some common outpus shared by many packages. + ;; Some common outputs shared by many packages. '("out" "doc" "debug" "lib" "include" "bin")))) (package-outputs package))) . 1) @@ -1942,7 +1942,7 @@ found." (define (run-guix . args) "Run the 'guix' command defined by command line ARGS. Unlike 'guix-main', this procedure assumes that locale, i18n support, -and signal handling has already been set up." +and signal handling have already been set up." (define option? (cut string-prefix? "-" <>)) ;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the |