From c40bf5816cb3ffb59920a61f71bd34b53cac3637 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 12:41:18 +0100 Subject: store: Add 'map/accumulate-builds'. * guix/store.scm (): New record type. (build-accumulator, map/accumulate-builds, mapm/accumulate-builds): New procedures. * tests/store.scm ("map/accumulate-builds", "mapm/accumulate-builds"): New tests. --- guix/store.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index fdaae27914..b3641ef95d 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 @@ -1263,6 +1265,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 things continuation) + unresolved? + (things unresolved-things) + (continuation unresolved-continuation)) + +(define (build-accumulator continue store things mode) + "This build handler accumulates THINGS and returns an 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)) @@ -1789,6 +1833,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. ;; -- cgit v1.2.3 From 1213ea9bd91c3051365637731c6baeca791e0f65 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 12:42:54 +0100 Subject: guix build: Use 'map/accumulate-builds'. * guix/scripts/build.scm (options->derivations): Use 'map/accumulate-builds' instead of 'append-map'. --- guix/scripts/build.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index af18d8b6f9..9f87febb56 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -920,8 +920,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) -- cgit v1.2.3 From 584dfdac3795541ff020aca3f488ceaf2ddd7fc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 12:43:49 +0100 Subject: gexp: 'lower-inputs' uses 'mapm/accumulate-builds'. This doesn't have an noticeable impact on the run time of 'guix system build desktop.tmp --no-grafts -d'. * guix/gexp.scm (lower-inputs): Use 'mapm/accumulate-builds' instead of 'mapm'. --- guix/gexp.scm | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 133e0f5679..3d21685460 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -683,22 +683,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 -- cgit v1.2.3 From 25af35fa32bf6c991510406a330d4a42bd5beba8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 12:45:12 +0100 Subject: profiles: Use 'mapm/accumulate-builds'. * guix/profiles.scm (check-for-collisions): Use 'mapm/accumulate-builds' to lower manifest entries. Call 'foldm' over the already-lowered entries. (profile-derivation): Use 'mapm/accumulate-builds' instead of 'mapm' when calling HOOKS. --- guix/profiles.scm | 59 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 3a6498993c..ad9878f370 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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver @@ -280,29 +280,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)) @@ -1521,10 +1529,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) -- cgit v1.2.3 From c70cf1a724fb15e108dc842413db15a0b9f4bc10 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Mar 2020 01:21:32 +0100 Subject: store: Add 'references/cached'. * guix/store.scm (references/cached): New procedure. --- guix/store.scm | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index b3641ef95d..ca8c0e5ef8 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -135,6 +135,7 @@ built-in-builders references + references/cached references/substitutes references* query-path-info* @@ -1393,6 +1394,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 -- cgit v1.2.3 From 710854304b1ab29332edcb76f3de532e0724c197 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 14:46:34 +0100 Subject: grafts: Don't rely on substitute info for missing store items. Fixes . * guix/grafts.scm (references-oracle)[references*]: Remove call to 'substitution-oracle' and to 'references/substitutes'. Use 'references/cached' and 'build-derivations' right away instead. --- guix/grafts.scm | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index adc7bfafae..5173a77e58 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -166,22 +166,14 @@ references. Call REFERENCES to get the list of references." (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." +references of that item. Build INPUT if it's not available." (define (references* items) + ;; Return the references of 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))) - + ;; ITEMS are not in store so build INPUT first. (and (build-derivations store (list input)) - (map (cut references store <>) items)))) - (references/substitutes store items))) + (map (cut references/cached store <>) items)))) + (map (cut references/cached store <>) items))) (let loop ((items (derivation-input-output-paths input)) (result vlist-null)) -- cgit v1.2.3 From 131f50cdc9dbb7183023f4dae759876a9e700bef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 15:05:15 +0100 Subject: '--dry-run' no longer implies '--no-grafts'. * guix/scripts/archive.scm (%options): "dry-run" option no longer adds 'graft? #f to RESULT. * guix/scripts/environment.scm (%options): Likewise. * guix/scripts/pack.scm (%options): Likewise. * guix/scripts/package.scm (%options): Likewise. * guix/scripts/pull.scm (%options): Likewise. * guix/scripts/system.scm (%options): Likewise. --- guix/scripts/archive.scm | 2 +- guix/scripts/build.scm | 2 +- guix/scripts/copy.scm | 2 +- guix/scripts/environment.scm | 2 +- guix/scripts/pack.scm | 2 +- guix/scripts/package.scm | 3 +-- guix/scripts/pull.scm | 2 +- guix/scripts/system.scm | 2 +- 8 files changed, 8 insertions(+), 9 deletions(-) (limited to 'guix') 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 9f87febb56..79bd84a1a0 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -778,7 +778,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))) 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/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/pack.scm b/guix/scripts/pack.scm index b6fb73838d..f641f535b9 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))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 110d4f2977..c7908ece6c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -489,8 +489,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/system.scm b/guix/scripts/system.scm index 61a3c95dbd..a178761203 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1041,7 +1041,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))) -- cgit v1.2.3 From 033df23680cce1b3ccd9c83b97d8c200176cdb0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Mar 2020 15:35:47 +0200 Subject: packages: Change 'guile-for-grafts' back to 2.0. This reverts 2b6fe60599d52b449bbf531cfdc4dbf18a14eb2c, due to reports of segfaults of Guile 3.0.2 during grafting. * guix/packages.scm (guile-for-grafts): Change back to GUILE-2.0. --- guix/packages.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 2552f8bf7c..e2578101ee 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2016 Alex Kost @@ -449,7 +449,7 @@ derivations." ;; Guile 2.2 would not work due to 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 -- cgit v1.2.3 From d089b233353f05440a97afc5c1e903b8c1891969 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Mar 2020 15:51:08 +0200 Subject: deploy: Factorize machine deployment. * guix/scripts/deploy.scm (deploy-machine*): New procedure. (guix-deploy): Call it in 'for-each'. --- guix/scripts/deploy.scm | 42 ++++++++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 5c871cd6ed..7a44b9a503 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,5 @@ 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?))) + (for-each (cut deploy-machine* store <>) machines))))))) -- cgit v1.2.3 From 18c8a4396bdb9e9c842ef386a2aecfac38943112 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Mar 2020 16:05:17 +0200 Subject: deploy: Use 'map/accumulate-builds'. * guix/scripts/deploy.scm (guix-deploy): Use 'map/accumulate-builds' instead of 'for-each'. --- guix/scripts/deploy.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 7a44b9a503..4466a0c632 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -152,4 +152,6 @@ Perform the deployment specified by FILE.\n")) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?)) (parameterize ((%graft? (assq-ref opts 'graft?))) - (for-each (cut deploy-machine* store <>) machines))))))) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines))))))) -- cgit v1.2.3 From 9f7855299604c496d2d2f12041974e33baa0d63b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Mar 2020 16:14:14 +0200 Subject: packages: 'package->bag' keys cache by replacement. * guix/packages.scm (package->bag): When GRAFT? is true, use PACKAGE's replacement as the cache key. Remove GRAFT? from the list of secondary cache keys. --- guix/packages.scm | 66 +++++++++++++++++++++++++++---------------------------- 1 file changed, 33 insertions(+), 33 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index e2578101ee..04d9b7824c 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1029,39 +1029,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 - ($ 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 + ($ 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 -- cgit v1.2.3 From 5a17b9b673c9509ac31401fa60aa0a010656e8ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Mar 2020 18:42:10 +0200 Subject: build-system/gnu: Optimize the package graph. With this change, the output of: guix graph -e '(@@ (gnu packages commencement) coreutils-final)' |grep 'label = ' | wc -l drops from 76 nodes to 68 nodes, and the "add-data-to-store-cache" hit rate for: guix build libreoffice -d --no-grafts drops from 3.9% to 2.6%. * guix/build-system/gnu.scm (package-with-explicit-inputs*)[cut?]: Adjust condition to exclude packages with build systems other than GNU-BUILD-SYSTEM, such as 'ld-wrapper-boot3'. --- guix/build-system/gnu.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès ;;; ;;; 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?)) -- cgit v1.2.3 From 190ddfe21e3d87719733d12fb9b5eb176125a49f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 21:48:51 +0200 Subject: guix package: 'transaction-upgrade-entry' uses 'lower-manifest-entry'. * guix/profiles.scm (lower-manifest-entry): Export. * guix/scripts/package.scm (transaction-upgrade-entry)[lower-manifest-entry*] [upgrade]: New procedures. Use 'lower-manifest-entry*' instead of 'package-derivation' to compute the output file name of PKG. --- guix/profiles.scm | 2 ++ guix/scripts/package.scm | 73 ++++++++++++++++++++++++++---------------------- 2 files changed, 41 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index ad9878f370..1362c4092a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -87,6 +87,7 @@ manifest-entry-search-paths manifest-entry-parent manifest-entry-properties + lower-manifest-entry manifest-pattern manifest-pattern? @@ -272,6 +273,7 @@ file name." (output -> (manifest-entry-output entry))) (return (manifest-entry (inherit entry) + ;; TODO: Lower dependencies, recursively. (item (derivation->output-path drv output)))))))) (define* (check-for-collisions manifest system #:key target) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c7908ece6c..be2e67997e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -199,6 +199,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 ." + (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 +215,41 @@ non-zero relevance score." (output (manifest-entry-output old))) transaction))) - (match (if (manifest-transaction-removal-candidate? entry transaction) - 'dismiss - entry) - ('dismiss - transaction) - (($ 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 + (($ 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))) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? (manifest-entry-item + (lower-manifest-entry* new)) + (manifest-entry-item entry)) + (null? (package-propagated-inputs pkg))) + 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))) ;;; -- cgit v1.2.3 From a187cc562890895ad41dfad00eb1d5c4a4b00936 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 22:11:54 +0200 Subject: guix package: 'transaction-upgrade-entry' swallows build requests. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes a regression introduced in 131f50cdc9dbb7183023f4dae759876a9e700bef whereby the install/upgrade message would not be displayed: $ guix upgrade -n 2.1 MB would be downloaded: /gnu/store/…-something-1.2 /gnu/store/…-its-dependency-2.3 This is because we'd directly abort from 'transaction-upgrade-entry' to the build handler of 'build-notifier'. * guix/scripts/package.scm (transaction-upgrade-entry): Call 'string=?' expression in 'with-build-handler'. * tests/packages.scm ("transaction-upgrade-entry, grafts"): New test. --- guix/scripts/package.scm | 14 +++++++++++--- tests/packages.scm | 24 ++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index be2e67997e..cafa62c3f3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -234,11 +234,19 @@ non-zero relevance score." 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. + ;; XXX: When there are propagated inputs, assume we need to ;; upgrade the whole entry. - (if (and (string=? (manifest-entry-item - (lower-manifest-entry* new)) - (manifest-entry-item entry)) + (if (and (with-build-handler (const #f) + (string=? (manifest-entry-item + (lower-manifest-entry* new)) + (manifest-entry-item entry))) (null? (package-propagated-inputs pkg))) transaction (manifest-transaction-install-entry diff --git a/tests/packages.scm b/tests/packages.scm index 1ff35ec9c4..c2ec1f2c24 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -148,6 +148,30 @@ (string=? (manifest-pattern-version pattern) "1") (string=? (manifest-pattern-output pattern) "out"))))))) +(test-assert "transaction-upgrade-entry, grafts" + ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't + ;; try to build stuff. + (with-build-handler (const 'failed!) + (parameterize ((%graft? #t)) + (let* ((old (dummy-package "foo" (version "1"))) + (bar (dummy-package "bar" (version "0") + (replacement old))) + (new (dummy-package "foo" (version "1") + (inputs `(("bar" ,bar))))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list new))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "foo" "1" "out" item)) + (eq? item new))) + (null? (manifest-transaction-remove tx))))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From 1a9a373eb445d21add006a46c18df0da11e52cbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 22:39:54 +0200 Subject: profiles: 'lower-manifest-entry' recurses on dependencies. * guix/profiles.scm (lower-manifest-entry)[recurse]: New procedure. Call it on dependencies and set the 'dependencies' field accordingly. --- guix/profiles.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 1362c4092a..e3bbc6dd6d 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -264,17 +264,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) - ;; TODO: Lower dependencies, recursively. - (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 -- cgit v1.2.3 From a357849f5b1314c2a35efeee237645b9b08c39f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 23:34:48 +0200 Subject: guix package: Do not misdiagnose upgrades when there are propagated inputs. Fixes . Reported by Andy Tai . * guix/profiles.scm (list=?, manifest-entry=?): New procedures. * guix/scripts/package.scm (transaction-upgrade-entry): In the '=' case, use 'manifest-entry=?' to determine whether it's an upgrade. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades, propagated inputs"): New test. --- guix/profiles.scm | 29 +++++++++++++++++++++++++++++ guix/scripts/package.scm | 11 +++-------- tests/packages.scm | 22 ++++++++++++++++++++++ 3 files changed, 54 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index e3bbc6dd6d..8aa76a3537 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -89,6 +89,8 @@ manifest-entry-properties lower-manifest-entry + manifest-entry=? + manifest-pattern manifest-pattern? manifest-pattern-name @@ -217,6 +219,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 + (($ name1 version1 output1 item1 dependencies1 paths1) + (match entry2 + (($ name2 version2 output2 item2 dependencies2 paths2) + (and (string=? name1 name2) + (string=? version1 version2) + (string=? output1 output2) + (equal? item1 item2) ;XXX: could be 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." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index cafa62c3f3..badb1dcd38 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -240,14 +240,9 @@ non-zero relevance score." ;; displaying the list of packages to install/upgrade ;; upfront. Thus, if lowering NEW triggers a build (due ;; to grafts), assume NEW differs from ENTRY. - - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (with-build-handler (const #f) - (string=? (manifest-entry-item - (lower-manifest-entry* new)) - (manifest-entry-item entry))) - (null? (package-propagated-inputs pkg))) + (if (with-build-handler (const #f) + (manifest-entry=? (lower-manifest-entry* new) + entry)) transaction (manifest-transaction-install-entry new transaction))))))))) diff --git a/tests/packages.scm b/tests/packages.scm index d0befbe45d..7a8b5e4a2d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -122,6 +122,28 @@ (manifest-transaction))))) (manifest-transaction-null? tx))) +(test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs" + ;; Properly detect equivalent packages even when they have propagated + ;; inputs. See . + (let* ((dep (dummy-package "dep" (version "2"))) + (old (dummy-package "foo" (version "1") + (propagated-inputs `(("dep" ,dep))))) + (drv (package-derivation %store old)) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list old))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (derivation->output-path drv)) + (dependencies + (list (manifest-entry + (inherit (package->manifest-entry dep)) + (item (derivation->output-path + (package-derivation %store dep))))))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + (test-assert "transaction-upgrade-entry, one upgrade" (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "foo" (version "2"))) -- cgit v1.2.3 From 2c33901fb1f580b50d9649d5e93928172c5d12b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 Mar 2020 12:30:21 +0200 Subject: ci: Fix 'evaluation-spec' binding. * guix/ci.scm ()[spec]: Add "specification", which is what the JSON field is actually called. --- guix/ci.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,7 +68,7 @@ (define-json-mapping 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) -- cgit v1.2.3 From ef4b5f2fed3ca13a0e15a821ba7e561cd4395aa6 Mon Sep 17 00:00:00 2001 From: Arne Babenhauserheide Date: Fri, 12 Jul 2019 23:42:45 +0200 Subject: profiles: Compute manual database entries in parallel. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This provides a 36% speedup on an SSD and 4 cores for the 1.5K man pages in the manual database derivation of: guix environment --ad-hoc jupyter python-ipython python-ipykernel * guix/profiles.scm (manual-database)[build]: Add 'print-string', 'print', and 'compute-entry'. Change 'compute-entries' to call 'compute-entry' in 'n-par-map'. Co-authored-by: Ludovic Courtès --- guix/profiles.scm | 40 ++++++++++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 8aa76a3537..47a7c92569 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1418,26 +1418,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")) -- cgit v1.2.3 From 4b75a7060058bc2e959dcb4145067f6bba3e34e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 1 Apr 2020 22:51:46 +0200 Subject: grafts: Simplify access to store item references. This is a followup to 710854304b1ab29332edcb76f3de532e0724c197. This also slightly reduces the number of 'query-references' RPCs, for instance from 176 to 166 from "guix build emacs -d". * guix/grafts.scm (references-oracle): Remove. (non-self-references): Remove 'references' parameter and add 'store'. Add 'references*' procedure and use it instead of 'references'. Adjust caller accordingly. (cumulative-grafts): Remove 'references' parameter and adjust caller accordingly. --- guix/grafts.scm | 60 +++++++++++++++------------------------------------------ 1 file changed, 15 insertions(+), 45 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index 5173a77e58..69d6fe4469 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -152,43 +152,23 @@ 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)) - (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. Build INPUT if it's not available." +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 input)) - (map (cut references/cached store <>) items)))) - (map (cut references/cached store <>) items))) + (and (build-derivations store (list drv)) + (append-map (cut references/cached store <>) items)))) + (append-map (cut references/cached 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)))))) + (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-syntax-rule (with-cache key exp ...) "Cache the value of monadic expression EXP under KEY." @@ -231,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." @@ -262,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))) @@ -270,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 @@ -307,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 -- cgit v1.2.3 From 5c83dd1d64783d4829e42714be41f4c4b0430dbd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 09:47:58 +0200 Subject: ui: Clarify "dependencies changed". Suggested by Leo Famulari . * guix/ui.scm (show-manifest-transaction): Change to "dependencies or package changed". --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 1e24fe5dca..1ccc80a000 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -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)) -- cgit v1.2.3 From 2ad6eb0568ed69127aea987c009138e03b5b8954 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 10:58:38 +0200 Subject: guix system: Use 'mapm/accumulate-builds'. * guix/scripts/system.scm (perform-action): Use 'mapm/accumulate-builds' instead of 'mapm'. --- guix/scripts/system.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a178761203..4937e68115 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -825,10 +825,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 . - (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)) -- cgit v1.2.3 From b34ead48dcd3f3aff27b21d7a326f9bdfd3b2235 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 10:59:15 +0200 Subject: gexp: 'lower-references' uses 'mapm/accumulate-builds'. * guix/gexp.scm (lower-references): Use 'mapm/accumulate-builds' instead of 'mapm'. --- guix/gexp.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 3d21685460..4ac0411da1 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -730,7 +730,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. -- cgit v1.2.3 From 3b4d7cdccce97dbffee538812c86bc03a6ae35d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 14:17:36 +0200 Subject: bournish: Prevent inlining of run-time support procedures. On Guile 3, those procedures could be inlined, leading to unbound-variable errors: scheme@(guile-user)> ,bournish Welcome to Bournish, a minimal Bourne-like shell! To switch back, type `,L scheme'. bournish@(guile-user)> ls ice-9/boot-9.scm:1669:16: In procedure raise-exception: Unbound variable: ls-command-implementation Reported by Ricardo Wurmus. * guix/build/bournish.scm (define-command-runtime): New macro. (ls-command-implementation, wc-command-implementation) (wc-l-command-implementation, wc-c-command-implementation): Use it instead of 'define'. --- guix/build/bournish.scm | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2016, 2017, 2020 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus ;;; @@ -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) -- cgit v1.2.3 From efa578ecaece67366b4b0e2266de7c2faaa4ae54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 21:33:48 +0200 Subject: git: Don't try to resolve tags with 'tag-lookup'. Fixes . Reported by Brice Waegeneire . * guix/git.scm (switch-to-ref): In the 'tag case, remove call to 'tag-lookup'. --- guix/git.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') 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)) -- cgit v1.2.3 From a6850f6827869cd20feb1d4cc5abf6744b6cc164 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 22:09:43 +0200 Subject: guix system: Do not import the user's (guix config). Previously, 'switch-to-system.drv' and 'install-bootloader.drv' would depend on the user's (guix config) module. This is no longer the case. * guix/scripts/system/reconfigure.scm (not-config?): New procedure. (switch-system-program): Do not import the user's (guix config). Use 'make-config.scm' instead. (install-bootloader-program): Likewise. --- guix/scripts/system/reconfigure.scm | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 77a72307b4..c8d1ed4a51 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe @@ -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) @@ -184,10 +195,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) @@ -197,6 +211,7 @@ BOOTLOADER-PACKAGE." (ice-9 binary-ports) (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. -- cgit v1.2.3 From 5517750344be05c91bc2979c1a0e2348a9ae902d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 22:46:18 +0200 Subject: reconfigure: Run the effect scripts as separate processes. Fixes . Reported by strypsteen@posteo.net. * guix/scripts/system/reconfigure.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Use 'system*' instead of 'primitive-load'. --- guix/scripts/system/reconfigure.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index c8d1ed4a51..21b472e0c5 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -100,7 +100,7 @@ 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 #~(system* #$(switch-system-program os profile)))) ;;; @@ -176,10 +176,10 @@ 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 #~(system* #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) ;;; @@ -252,9 +252,9 @@ 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 #~(system* #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) -- cgit v1.2.3 From 00a1ebb84a5664cae1fbe0a0845d65c99d9907f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 10:26:54 +0200 Subject: Revert "reconfigure: Run the effect scripts as separate processes." This reverts commit 5517750344be05c91bc2979c1a0e2348a9ae902d. That commit would remove all sorts of error checking when running those programs. --- guix/scripts/system/reconfigure.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 21b472e0c5..c8d1ed4a51 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -100,7 +100,7 @@ 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 #~(system* #$(switch-system-program os profile)))) + (eval #~(primitive-load #$(switch-system-program os profile)))) ;;; @@ -176,10 +176,10 @@ services as defined by OS." (map live-service-canonical-name live-services))) (service-files (map shepherd-service-file target-services))) - (eval #~(system* #$(upgrade-services-program service-files - to-start - to-unload - to-restart))))))) + (eval #~(primitive-load #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) ;;; @@ -252,9 +252,9 @@ 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 #~(system* #$(install-bootloader-program installer - package - bootcfg - bootcfg-file - device - target))))) + (eval #~(primitive-load #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) -- cgit v1.2.3 From 9fb3ff31c15f36545bad11c1d9b11eaf0333f831 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 10:48:32 +0200 Subject: reconfigure: Silence Guile warnings. Fixes . Reported by strypsteen@posteo.net. * guix/scripts/system/reconfigure.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Wrap 'primitive-load' call in 'parameterize'. --- guix/scripts/system/reconfigure.scm | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index c8d1ed4a51..074c48f58b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -100,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))))) ;;; @@ -176,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)))))))) ;;; @@ -252,9 +254,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)))))) -- cgit v1.2.3 From 4efbb079b5aac6a4eb53ef3f9a67a2849c3ebf1f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 11:22:46 +0200 Subject: guix system: Remove unused procedure. This procedure was unused since 5c8c8c455420af27189d6045b3599fe6e27ad012. * guix/scripts/system.scm (call-with-service-upgrade-info): Remove. --- guix/scripts/system.scm | 17 ----------------- 1 file changed, 17 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 4937e68115..b87f2bdd3b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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 () @@ -1294,7 +1278,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: -- cgit v1.2.3 From 73bfb14f8ff105bbc8a8836f475f72867297fe93 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 11:42:01 +0200 Subject: guix system: Mention 'herd restart' when reconfigure completes. * guix/scripts/system.scm (with-shepherd-error-handling): Use 'mbegin' instead of 'begin'. (perform-action): Print a message after 'upgrade-shepherd-services'. That message had disappeared in commit 5c8c8c455420af27189d6045b3599fe6e27ad012. --- guix/scripts/system.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b87f2bdd3b..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~%") @@ -837,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'...~%") -- cgit v1.2.3 From f7b5b8cd45b4560b3473dde2e6f6f20b4ff9daff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 21:51:12 +0200 Subject: pack: Pass the cross-compilation target to 'run-with-store'. This ensures '%current-target-system' is correctly bound upfront, which some packages rely on. * guix/scripts/pack.scm (guix-pack): Pass #:target to 'run-with-store'. --- guix/scripts/pack.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f641f535b9..6d63fb4b90 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1128,4 +1128,5 @@ to your package list."))) gc-root)) (return (format #t "~a~%" (derivation->output-path drv)))))) + #:target target #:system (assoc-ref opts 'system))))))))) -- cgit v1.2.3 From 8ed597f4a261fe188de82cd1f5daed83dba948eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2020 17:36:31 +0200 Subject: store: 'with-store' doesn't close the store upon abort. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Marius Bakke and 白い熊. Regression introduced with the first uses of 'with-build-handler' in commit 62195b9a8fd6846117c5d7698842748300d13e31 and subsequent. * guix/store.scm (call-with-store): Use 'catch #t' instead of 'dynamic-wind'. This ensures STORE remains open when a non-local exit other than an exception occurs, such as an abort to the build handler prompt. * tests/store.scm ("with-build-handler + with-store"): New test. --- guix/store.scm | 12 +++++++----- tests/store.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index ca8c0e5ef8..1dd5c9545b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -623,14 +623,16 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (dynamic-wind - (const #f) + (catch #t (lambda () (parameterize ((current-store-protocol-version (store-connection-version store))) - (proc store))) - (lambda () - (false-if-exception (close-connection store)))))) + (let ((result (proc store))) + (close-connection store) + result))) + (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; diff --git a/tests/store.scm b/tests/store.scm index 0458a34746..0e80ccc239 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -412,6 +412,33 @@ (build-derivations %store (list d2)) 'fail))) +(test-equal "with-build-handler + with-store" + 'success + ;; Check that STORE remains valid when the build handler invokes CONTINUE, + ;; even though 'with-build-handler' is outside the dynamic extent of + ;; 'with-store'. + (with-build-handler (lambda (continue store things mode) + (match things + ((drv) + (and (string-suffix? "thingie.drv" drv) + (not (port-closed? + (store-connection-socket store))) + (continue #t))))) + (with-store store + (let* ((b (add-text-to-store store "build" "echo $foo > $out" '())) + (s (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation store "thingie" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s)))) + (build-derivations store (list d)) + + ;; Here STORE's socket should still be open. + (and (valid-path? store (derivation->output-path d)) + 'success))))) + (test-assert "map/accumulate-builds" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" -- cgit v1.2.3 From 376ba0ce570993cf6cdbed19596a245826308382 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2020 23:58:05 +0200 Subject: store: 'with-store' uses 'with-exception-handler'. This ensures the stack is not unwound before the exception is re-thrown, as was the case since 8ed597f4a261fe188de82cd1f5daed83dba948eb, leading to '&store-protocol-error' being uncaught by 'with-error-handling' in (guix scripts build) & co. * guix/store.scm (call-with-store): Define 'thunk'. Add 'cond-expand' to use 'with-exception-handler' on 'guile-3' and 'catch' otherwise. --- guix/store.scm | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 1dd5c9545b..fb4b92e0c4 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -623,16 +623,25 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (catch #t - (lambda () - (parameterize ((current-store-protocol-version - (store-connection-version store))) - (let ((result (proc store))) - (close-connection store) - result))) - (lambda (key . args) - (close-connection store) - (apply throw key args))))) + (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; -- cgit v1.2.3 From b066c25026f21fb57677aa34692a5034338e7ee3 Mon Sep 17 00:00:00 2001 From: Carl Dong Date: Mon, 6 Apr 2020 14:02:42 -0400 Subject: gnu: Move PACKAGES-WITH-*PATCHES to (guix packages) * gnu/packages/cross-base.scm (package-with-extra-patches, package-with-patches): Move procedures from here... * guix/packages.scm (package-with-extra-patches, package-with-patches): ...to here, and export. --- gnu/packages/cross-base.scm | 12 ------------ guix/packages.scm | 14 ++++++++++++++ 2 files changed, 14 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index ae3ac210b7..b0eb7ab4ed 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.scm @@ -70,18 +70,6 @@ `(cons ,(string-append "--target=" target) ,flags)))))) -(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 (cross-binutils target) "Return a cross-Binutils for TARGET." (let ((binutils (package (inherit binutils) diff --git a/guix/packages.scm b/guix/packages.scm index 04d9b7824c..6c6a06e0ce 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -111,6 +111,8 @@ package-output package-grafts package-patched-vulnerabilities + package-with-patches + package-with-extra-patches package/inherit transitive-input-references @@ -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 -- cgit v1.2.3 From 42a87136f0c99c0f1956e053d92f23bf096bddb6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Apr 2020 23:21:43 +0200 Subject: channels: Call 'build-self.scm' procedure with a trivial build handler. Previously, "TESTS=installed-os guix build -m etc/system-tests.scm" would repeat the "Computing Guix derivation" phase ~5 times due to the fact that there were several call paths, within a build-accumulator, leading to (package-derivation store guix). * guix/channels.scm (with-trivial-build-handler): New procedure. (build-from-source): Wrap 'build' call in 'with-trivial-build-handler'. --- guix/channels.scm | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index f0261dc2da..785b97722e 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))) -- cgit v1.2.3 From 9ac6d3785f34d99034c27eb6f447b242d045b413 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 7 Apr 2020 17:58:05 +0200 Subject: lint: 'm4' is a native input. * guix/lint.scm (check-inputs-should-be-native): Add "m4". --- guix/lint.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 2be3cc3ee3..72582cfffb 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -308,6 +308,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" -- cgit v1.2.3 From 9f1b787120b1b81abffaf0fa13fdbdf4cca39f2d Mon Sep 17 00:00:00 2001 From: TomZ Date: Tue, 7 Apr 2020 21:39:04 +0200 Subject: Allow double-click select of URL in status Various places while downloading or compiling guix prints the source URL. This change makes the URL easier to use by placing a space between the URL and the trailing dots. Signed-off-by: Marius Bakke --- guix/status.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 4b2edc2f3c..45e441eac5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,16 +472,16 @@ 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 (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package..." - "building profile with ~a packages..." + (format port (info (N_ "building profile with ~a package ..." + "building profile with ~a packages ..." count)) count))) ('profile-hook @@ -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) -- cgit v1.2.3 From 1c86577d624b97a03138640b4d849823b504570e Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 7 Apr 2020 22:09:14 +0200 Subject: Revert "Allow double-click select of URL in status" As discussed on #guix, this should wait until 1.1.0 is branched off to avoid having to update translations. This reverts commit 9f1b787120b1b81abffaf0fa13fdbdf4cca39f2d. --- guix/status.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 45e441eac5..4b2edc2f3c 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,16 +472,16 @@ 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 (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package ..." - "building profile with ~a packages ..." + (format port (info (N_ "building profile with ~a package..." + "building profile with ~a packages..." count)) count))) ('profile-hook @@ -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) -- cgit v1.2.3 From 93add9bf7d73b6a6ed2d0cf85778b26aa38fd194 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Apr 2020 23:31:41 +0200 Subject: reconfigure: Correctly re-throw SRFI-34 exceptions on Guile 3. Previously, we'd just print an ugly backtrace when running on Guile 3 because the '%exception throw would not be caught anywhere. Reported by Arne Babenhauserheide in . * guix/scripts/system/reconfigure.scm (install-bootloader-program): In 'catch' handler, match '%exception and use 'raise-exception' instead of 'throw' to rethrow in that case. --- guix/scripts/system/reconfigure.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 074c48f58b..7885c33457 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -211,6 +211,7 @@ BOOTLOADER-PACKAGE." (guix store) (guix utils) (ice-9 binary-ports) + (ice-9 match) (srfi srfi-34) (srfi srfi-35)) @@ -235,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. -- cgit v1.2.3 From 041c3c22dc14d485ca58b3ae1436b62d4a39d0aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Apr 2020 23:48:54 +0200 Subject: compile: Run the load phase within 'with-target'. * guix/build/compile.scm (compile-files)[build]: Remove 'with-target'. Wrap body in 'with-target'. --- guix/build/compile.scm | 51 +++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 4b6472784c..3ce0ecede5 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -184,36 +184,35 @@ 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 , 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. - (compile #f) - - ;; XXX: Don't use too many workers to work around the insane memory - ;; requirements of the compiler in Guile 2.2.2: - ;; . - (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 , 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. + (compile #f) + + ;; XXX: Don't use too many workers to work around the insane + ;; memory requirements of the compiler in Guile 2.2.2: + ;; . + (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)) -- cgit v1.2.3 From a05ad011229cf3712d373918c2ed9ebdb5f5b2a2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Apr 2020 23:55:14 +0200 Subject: records: Have ABI check work well for cross-compilation. Reported by Jan (janneke) Nieuwenhuizen . * guix/records.scm (define-record-type*): Use 'target-most-positive-fixnum' on Guile 3 instead of 'most-positive-fixnum'. --- guix/records.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') 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 -- cgit v1.2.3 From c1d81df93d4b67671fc4a8e0a80c0f02c5821663 Mon Sep 17 00:00:00 2001 From: Diego Nicola Barbato Date: Mon, 16 Mar 2020 18:43:20 +0100 Subject: download: Use correct system and guile in 'url-fetch/tarbomb' and 'url-fetch/zipbomb'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Previously the result of `guix build -s $system $package' would depend on the system Guix was built for if $package or one of its dependencies used 'url-fetch/tarbomb' or 'url-fetch/zipbomb' as the origin method of its source (e.g. `guix build -s i686-linux ffmpeg' on i686-linux would build a different derivation than on x86_64-linux). This patch fixes this by explicitly passing the correct system and guile to 'gexp->derivation'. * guix/download.scm (url-fetch/tarbomb): Pass #:system system and #:guile-for-build guile to 'gexp->derivation', where guile is the derivation of guile for system. (url-fetch/zipbomb): Likewise. Signed-off-by: Ludovic Courtès --- guix/download.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') 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))) -- cgit v1.2.3 From d95252baf97adb261dd823d4e7a74a7522815c1c Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Fri, 10 Apr 2020 00:29:56 +0300 Subject: lint: Check for inappropriate inputs in propagated-inputs too. * guix/lint.scm (check-inputs-should-be-native): Also check the propagated inputs of the package. --- guix/lint.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 72582cfffb..bda5c0cd77 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Tobias Geerinckx-Rice -;;; Copyright © 2017, 2018 Efraim Flashner +;;; Copyright © 2017, 2018, 2020 Efraim Flashner ;;; Copyright © 2018, 2019 Arun Isaac ;;; ;;; 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" -- cgit v1.2.3 From 92587f8ed6b5217cf02cfdaf208a78491729da15 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Apr 2020 15:58:01 +0200 Subject: lint: 'check-patch-file-names' restricts to shorter file names. * guix/lint.scm (check-patch-file-names): Increase MARGIN. --- guix/lint.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index bda5c0cd77..e192f292a4 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -686,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) -- cgit v1.2.3 From 93d5cea57e6cbbbf99066aef65da65795cf51fd6 Mon Sep 17 00:00:00 2001 From: nixo Date: Fri, 17 Jan 2020 19:40:55 +0100 Subject: build: julia-build-system: Update for new Julia version. * guix/build/julia-build-system.scm (generate-load-path): Delete function. (install): Don't set JULIA_LOAD_PATH. (precompile): Set SOURCE_DATE_EPOCH. Update calculating the JULIA_LOAD_PATH. Adjust the 'invoke-julia' command. (check): Set SOURCE_DATE_EPOCH. Adjust JULIA_LOAD_PATH. Signed-off-by: Efraim Flashner --- guix/build/julia-build-system.scm | 51 +++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 29 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2019, 2020 Nicolò Balzarotti ;;; ;;; 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) -- cgit v1.2.3 From b36217c54dd92bdfa0984b9eded0765a3b388426 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Apr 2020 00:08:48 +0200 Subject: self: Prevent inlining of internal procedures used by 'doc/build.scm'. This allows 'doc/build.scm' to keep using '@@' for these. (This sets a bad example, don't follow it.) * guix/self.scm (prevent-inlining!): New macro. : Use it for 'file-append*', 'translate-texi-manuals', and 'info-manual'. --- guix/self.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 6b633f9bc0..1040c27a6b 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -489,6 +489,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." -- cgit v1.2.3 From 1ae7a9251b282a5f5e73a754dbc3b8bd4fe1da74 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Apr 2020 15:19:51 +0200 Subject: weather: Delete duplicate entries coming from '--manifest'. * guix/scripts/weather.scm (load-manifest): Call 'delete-duplicates'. --- guix/scripts/weather.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') 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?))) ;;; -- cgit v1.2.3 From 82d8959e5d137b2061a68878d78a8f74a238ac44 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Apr 2020 17:34:38 +0200 Subject: syscalls: 'readdir*' chooses between the Linux and Hurd code at run time. Partly fixes . Reported by Jan Nieuwenhuizen . Previously, we'd choose at expansion time whether to use the Hurd or the Linux variant, taking the cross-compilation target into account. This would lead to the wrong decision when (guix build syscalls) is evaluated while we're cross-compiling to GNU/Hurd. This is a followup to 1ab9e483391f8b62b873833ea71cb0074efa03e7. * guix/build/syscalls.scm (define-generic-identifier) (read-dirent-header, %struct-dirent-header, sizeof-dirent-header): Remove. (readdir*): Rename to... (readdir-procedure): ... this, and add parameters. (readdir*): Define as a call to 'readdir-procedure' as a function of %HOST-TYPE. --- guix/build/syscalls.scm | 50 +++++++++++++++---------------------------------- 1 file changed, 15 insertions(+), 35 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0938ec0ff1..7ef03417c1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -22,7 +22,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 +891,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 . (define DT_UNKNOWN 0) (define DT_FIFO 1) @@ -960,19 +929,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-suffix? "linux-gnu" %host-type) + (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 Date: Tue, 14 Apr 2020 17:23:33 +0200 Subject: import/print: Return license with prefix. * guix/import/print.scm (license->code): Prepend license: prefix. --- guix/import/print.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 4c2a91fa4f..b819e7cf90 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 +;;; Copyright © 2017, 2020 Ricardo Wurmus ;;; ;;; 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)) -- cgit v1.2.3 From 6269dd567e85c78a87be8d55f7ddc801a0ea870c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 17:24:09 +0200 Subject: import/print: package->code: Wrap build system value in module reference. * guix/import/print.scm (package->code): Return build system value with corresponding module. --- guix/import/print.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index b819e7cf90..4529a79b23 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -131,8 +131,9 @@ when evaluated." ,@(if replacement `((replacement ,replacement)) '()) - (build-system ,(symbol-append (build-system-name build-system) - '-build-system)) + (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))))) -- cgit v1.2.3 From 16dd764691d7f3ab954c82332f456bfa5f094514 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 18:01:11 +0200 Subject: import/json: Add json->scheme-file. * guix/import/json.scm (json->code, json->scheme-file): New procedures. --- guix/import/json.scm | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 8900724dcd..16dc2ad5cb 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014 David Thompson ;;; Copyright © 2015, 2016 Eric Bavier ;;; Copyright © 2018, 2019 Ludovic Courtès +;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,8 +23,12 @@ #:use-module (json) #:use-module (guix http-client) #:use-module (guix import utils) + #:use-module (guix import print) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-34) - #:export (json-fetch)) + #:export (json-fetch + json->scheme-file)) (define* (json-fetch url ;; Note: many websites returns 403 if we omit a @@ -42,3 +47,31 @@ the query." (result (json->scm port))) (close-port port) result))) + +(define (json->code file-name) + "Read FILE-NAME containing a JSON package definition and return an +S-expression, 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)))) + (package->code (alist->package json)))) + (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* ((json (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) + (write json port))) + file*)) -- cgit v1.2.3 From f87e56320198fecd81ce588f571578b6cda5ed08 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 18:01:49 +0200 Subject: scripts/build: options->things-to-build: Handle .json files. * guix/scripts/build.scm (options->things-to-build): Handle files that end on .json. --- guix/scripts/build.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 79bd84a1a0..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 ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2020 Marius Bakke +;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; 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) @@ -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 -- cgit v1.2.3 From 4f353c485dea4b549a0aabd1c87b0dd03fef4f1e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 18:02:26 +0200 Subject: scripts/package: Handle JSON files. * guix/scripts/package.scm (%options): Support loading from JSON files when "install-from-file" is used. --- guix/scripts/package.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index badb1dcd38..40445832aa 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2016 Benz Schenk ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2019 Tobias Geerinckx-Rice +;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; 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) @@ -418,7 +420,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 -- cgit v1.2.3 From c89343232065c50d196cd194073d2034eaedaf44 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:38:15 +0200 Subject: import/json: Use json->code. * guix/import/json.scm (json->code): Export procedure. * guix/scripts/import/json.scm (guix-import-json): Use json->code. --- guix/import/json.scm | 1 + guix/scripts/import/json.scm | 12 +++--------- 2 files changed, 4 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 16dc2ad5cb..8f8dbbd05d 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-34) #:export (json-fetch + json->code json->scheme-file)) (define* (json-fetch url 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 ...) -- cgit v1.2.3 From 86a3b540d08e0ece2a697f7caa6342a55394a6b3 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:39:45 +0200 Subject: import/print: package->code: Wrap S-expression in definition. * guix/import/print.scm (package->code): Return a definition, not just a package expression. --- guix/import/print.scm | 87 ++++++++++++++++++++++++++------------------------- 1 file changed, 44 insertions(+), 43 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 4529a79b23..08f3ec9c34 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -121,46 +121,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 (@ (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)))))) + `(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))))))) -- cgit v1.2.3 From 3532fc39fff41eabd061370ee36a1d42b9fac0e6 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:41:03 +0200 Subject: import/utils: alist->package: Ignore known inputs. * guix/import/utils.scm (alist->package): Accept optional list of known inputs, which are excluded from the specification lookup. * guix/import/print.scm (package->code)[package-lists->code]: Handle inputs which are just symbols. --- guix/import/print.scm | 2 ++ guix/import/utils.scm | 27 ++++++++++++++++----------- 2 files changed, 18 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 08f3ec9c34..471687c0ff 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -92,6 +92,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 diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 94c8cb040b..5fb1322535 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven -;;; Copyright © 2017, 2019 Ricardo Wurmus +;;; Copyright © 2017, 2019, 2020 Ricardo Wurmus ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2019 Robert Vollmert ;;; @@ -310,7 +310,18 @@ the expected fields of an 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)))) (package (name (assoc-ref meta "name")) (version (assoc-ref meta "version")) @@ -318,15 +329,9 @@ the expected fields of an 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") '#())))) + (native-inputs (process-inputs "native-inputs")) + (inputs (process-inputs "inputs")) + (propagated-inputs (process-inputs "propagated-inputs")) (home-page (assoc-ref meta "home-page")) (synopsis -- cgit v1.2.3 From 7cef499bb060aabf3d59cc4eca37350e5c79ff7d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:43:39 +0200 Subject: import/json: json->code: Handle files with more than one definition. * guix/import/json.scm (json->code): Convert JSON arrays to lists of package definitions. (json->scheme-file): Write all expressions to the target file. --- guix/import/json.scm | 35 ++++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 8f8dbbd05d..0c98bb25b8 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -24,8 +24,11 @@ #: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 json->code @@ -50,19 +53,41 @@ the query." result))) (define (json->code file-name) - "Read FILE-NAME containing a JSON package definition and return an -S-expression, or return #F when the JSON is invalid." + "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)))) - (package->code (alist->package json)))) + (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* ((json (json->code file)) + (and-let* ((sexprs (json->code file)) (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp")) (template (string-append tempdir "/guix-XXXXXX")) (port (mkstemp! template))) @@ -74,5 +99,5 @@ representation and return the new file name (or #F on error)." (guix) ((guix licenses) #:prefix license:)) port) - (write json port))) + (for-each (cut write <> port) sexprs))) file*)) -- cgit v1.2.3 From 3fd4c4c8394bca7aa9dd81c0ad81f2bb31989464 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 16 Apr 2020 21:44:21 +0200 Subject: import/utils: alist->package: Include arguments. * guix/import/utils.scm (alist->package): Process arguments field in input data and include it in the generated package. --- guix/import/utils.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 5fb1322535..3809c3d074 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -322,6 +322,11 @@ specifications to look up and replace them with plain symbols instead." 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")) @@ -329,6 +334,10 @@ specifications to look up and replace them with plain symbols instead." (build-system (lookup-build-system-by-name (string->symbol (assoc-ref meta "build-system")))) + (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")) -- cgit v1.2.3 From 3c0422b9be649e0a09caa0b893713a9f07855cd3 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 16 Apr 2020 22:09:41 +0200 Subject: import/print: Don't factorize URI if there's no version match. * guix/import/print.scm (package->code): If FACTORIZE-URI returns just the unmodified string use that as the URI. --- guix/import/print.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 471687c0ff..11cc218285 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -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)))) -- cgit v1.2.3 From 8fa4ac5be4d5f8a1e62635842b16486832ff49f1 Mon Sep 17 00:00:00 2001 From: TomZ Date: Tue, 7 Apr 2020 21:39:04 +0200 Subject: status: Allow double-click select of URLs. Various places while downloading or compiling guix prints the source URL. This change makes the URL easier to use by placing a space between the URL and the trailing dots. Signed-off-by: Marius Bakke --- guix/status.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 4b2edc2f3c..45e441eac5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,16 +472,16 @@ 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 (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package..." - "building profile with ~a packages..." + (format port (info (N_ "building profile with ~a package ..." + "building profile with ~a packages ..." count)) count))) ('profile-hook @@ -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) -- cgit v1.2.3 From 694e10af639da64cdf6f1c44cadf9a64f8a04fa6 Mon Sep 17 00:00:00 2001 From: Vincent Legoll Date: Thu, 16 Apr 2020 23:17:16 +0200 Subject: ui: Fix typos, 80-col & grammar in comments & docstrings. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ui.scm (load*): Fix comment line length. (leave-on-EPIPE): Fix typo in docstring. (substitutable-info): Fix typo in comment. (indented-string): Fix typo in docstring. (%package-metrics): Fix typo in comment. (run-guix): Fix grammar in docstring. Signed-off-by: Ludovic Courtès --- guix/ui.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 1ccc80a000..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? @@ -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 -- cgit v1.2.3 From aa78c596c9eaae946f779d8fa3c4125d08187648 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Fri, 17 Apr 2020 23:25:17 +0200 Subject: gnupg: Accept revoked keys. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit I (nckx) have revoked all RSA subkeys, in favour of my older and freshly-refreshed ECDSA ones. This was merely a precaution: to my knowledge all my RSA private keys have been carefully destroyed and were never compromised. This commit keeps ‘make authenticate’ happy. * guix/gnupg.scm (revkeysig-rx): New variable for revoked keys. (gnupg-verify): Parse it. (gnupg-status-good-signature?): Accept it as ‘good’ for our purposes. * build-aux/git-authenticate.scm (%committers): Clarify nckx's subkeys. Signed-off-by: Ludovic Courtès --- build-aux/git-authenticate.scm | 7 ++++--- guix/gnupg.scm | 11 ++++++++++- 2 files changed, 14 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/build-aux/git-authenticate.scm b/build-aux/git-authenticate.scm index 37e0c6800c..bb48dddc59 100644 --- a/build-aux/git-authenticate.scm +++ b/build-aux/git-authenticate.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -147,11 +148,11 @@ ("mthl" "F2A3 8D7E EB2B 6640 5761 070D 0ADE E100 9460 4D37") ("nckx" - ;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B" - "7E8F AED0 0944 78EF 72E6 4D16 D889 B0F0 18C5 493C") - ("nckx (2nd)" ;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B" "F5DA 2032 4B87 3D0B 7A38 7672 0DB0 FF88 4F55 6D79") + ("nckx (revoked; not compromised)" + ;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B" + "7E8F AED0 0944 78EF 72E6 4D16 D889 B0F0 18C5 493C") ("niedzejkob" "E576 BFB2 CF6E B13D F571 33B9 E315 A758 4613 1564") ("ngz" 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 ;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; 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))) (_ -- cgit v1.2.3 From 04594054d6cddb985cb1bfce1c84372c81f87636 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Apr 2020 23:21:34 +0200 Subject: status: Remove extra space before ellipsis. Extra space was introduced in 8fa4ac5be4d5f8a1e62635842b16486832ff49f1. * guix/status.scm (print-build-event): Remove extra space before ellipsis. --- guix/status.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 45e441eac5..f40d5d59b9 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -480,8 +480,8 @@ addition to build events." (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package ..." - "building profile with ~a packages ..." + (format port (info (N_ "building profile with ~a package..." + "building profile with ~a packages..." count)) count))) ('profile-hook -- cgit v1.2.3 From 3c91f003416c9fb79af2dc8766a7f449aa03f839 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Apr 2020 13:16:52 +0200 Subject: tests: Invoke 'git' with a custom '.gitconfig' and ignore the system config. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Gábor Boskovits . * guix/tests/git.scm (call-with-environment-variables): New procedure. (with-environment-variables): New macro. (populate-git-repository)[git]: Wrap (git-command) invocation in 'call-with-temporary-directory' and 'with-environment-variables'. --- guix/tests/git.scm | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; 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") -- cgit v1.2.3 From fd546bbbeee5237e29264791b61f9ba453ebff9f Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Mon, 20 Apr 2020 16:21:17 +0200 Subject: syscalls: Fix Linux detection in 'readdir*'. * guix/build/syscalls.scm (readdir*): Fix Linux detection for `arm-unknown-linux-gnueabihf'. --- guix/build/syscalls.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 7ef03417c1..73b439fb7d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Guillaume Le Vaillant +;;; Copyright © 2020 Julien Lepiller ;;; ;;; This file is part of GNU Guix. ;;; @@ -943,7 +944,7 @@ system to PUT-OLD." (define readdir* ;; Decide at run time which one must be used. - (if (string-suffix? "linux-gnu" %host-type) + (if (string-contains %host-type "linux-gnu") (readdir-procedure (c-struct-field-offset %struct-dirent-header/linux name) sizeof-dirent-header/linux -- cgit v1.2.3 From c8d8f6160e7b4d3df7b006b35ba0f4e74b9b90fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Apr 2020 23:37:05 +0200 Subject: packages: Recommend against the use of 'package-file'. * guix/packages.scm (package-file): Recommend against its use in the docstring. * doc/guix.texi (The Store Monad): Likewise. --- doc/guix.texi | 4 ++++ guix/packages.scm | 6 +++++- 2 files changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index d2cd11576f..a79bbfc4f7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7483,6 +7483,10 @@ value in the absolute file name of @var{file} within the @var{output} directory of @var{package}. When @var{file} is omitted, return the name of the @var{output} directory of @var{package}. When @var{target} is true, use it as a cross-compilation target triplet. + +Note that this procedure does @emph{not} build @var{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. @end deffn @deffn {Monadic Procedure} package->derivation @var{package} [@var{system}] diff --git a/guix/packages.scm b/guix/packages.scm index 6c6a06e0ce..2fa4fd05d7 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1340,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 -- cgit v1.2.3 From cc753650eccf3dcbf074999c458e42df8d3c0827 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 21 Apr 2020 21:50:34 +0200 Subject: self: translate-texi-manuals: Don't hardcode "guix.texi". * guix/self.scm (translate-texi-manuals)[build](translate-texi): Add 'prefix' and #:extras parameters and honor them. Adjust callers. --- guix/self.scm | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 1040c27a6b..93dcb9bee3 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -339,35 +339,35 @@ 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 (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)))) (for-each (lambda (po) (match (reverse (string-split po #\.)) ((_ lang _ ...) - (translate-texi po lang)))) + (translate-texi "guix" po lang + #:extras '("contributing"))))) (find-files "." "^guix-manual\\.[a-z]{2}(_[A-Z]{2})?\\.po$")) (for-each -- cgit v1.2.3 From 84c37e636804513f1fde1fe437784400d99e268e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 21 Apr 2020 22:23:54 +0200 Subject: self: translate-texi-manuals: Add 'available-translations'. * guix/self.scm (translate-texi-manuals)[build](available-translations): New procedure. Use it rather than directly calling 'find-files' & co. --- guix/self.scm | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 93dcb9bee3..3cc1003c3a 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -363,12 +363,25 @@ a list of extra files, such as '(\"contributing\")." translations)))))) (cons prefix extras)))) - (for-each (lambda (po) - (match (reverse (string-split po #\.)) - ((_ lang _ ...) - (translate-texi "guix" po lang - #:extras '("contributing"))))) - (find-files "." "^guix-manual\\.[a-z]{2}(_[A-Z]{2})?\\.po$")) + (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 (lambda (file) -- cgit v1.2.3 From e1e6491226347d9fb93ff484d78cef98848a510a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 21 Apr 2020 23:05:02 +0200 Subject: self: Build and install 'guix-cookbook.info' and its translations. * guix/self.scm (translate-texi-manuals)[build]: Translate and install guix-cookbook.texi. (info-manual)[build]: Handle "guix-cookbook*.texi". --- guix/self.scm | 39 ++++++++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 3cc1003c3a..4682cd221c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -383,12 +383,17 @@ a list of extra files, such as '(\"contributing\")." #:extras '("contributing")))) (available-translations "." "guix-manual")) - (for-each - (lambda (file) - (copy-file file (string-append #$output "/" file))) - (append - (find-files "." "contributing\\..*\\.texi$") - (find-files "." "guix\\..*\\.texi$")))))) + (for-each (match-lambda + ((language . po) + (translate-texi "guix-cookbook" po language))) + (available-translations "." "guix-cookbook")) + + (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)) @@ -415,7 +420,8 @@ a list of extra files, such as '(\"contributing\")." (define build (with-imported-modules '((guix build utils)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (ice-9 match)) (mkdir #$output) @@ -476,13 +482,13 @@ a list of extra files, such as '(\"contributing\")." #+(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 @@ -491,7 +497,10 @@ a list of extra files, such as '(\"contributing\")." (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" -- cgit v1.2.3 From 34faf63ebc9221f5cac460bc54237ea8436d5046 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Apr 2020 15:24:47 +0200 Subject: gexp: Add 'load-path?' field to . * guix/gexp.scm ()[load-path?]: New field. (scheme-file): Add #:set-load-path? and honor it. (scheme-file-compiler): Pass #:set-load-path? to 'gexp->file'. * doc/guix.texi (G-Expressions): Document it. --- doc/guix.texi | 3 ++- guix/gexp.scm | 12 +++++++----- 2 files changed, 9 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a79bbfc4f7..990703c4a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7955,7 +7955,8 @@ The resulting file holds references to all the dependencies of @var{exp} or a subset thereof. @end deffn -@deffn {Scheme Procedure} scheme-file @var{name} @var{exp} [#:splice? #f] +@deffn {Scheme Procedure} scheme-file @var{name} @var{exp} @ + [#:splice? #f] [#:set-load-path? #t] Return an object representing the Scheme file @var{name} that contains @var{exp}. diff --git a/guix/gexp.scm b/guix/gexp.scm index 4ac0411da1..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 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 ) system target) ;; Compile FILE by returning a derivation that builds the file. (match file - (($ name gexp splice?) + (($ name gexp splice? set-load-path?) (gexp->file name gexp + #:set-load-path? set-load-path? #:splice? splice? #:system system #:target target)))) -- cgit v1.2.3 From 416f7f4f144569fa66772e0cf43cf785d9a408af Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Apr 2020 15:35:36 +0200 Subject: profiles: Add #:name parameter to 'profile-derivation'. * guix/profiles.scm (profile-derivation): Add #:name and pass it to 'gexp->derivation'. --- guix/profiles.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 47a7c92569..88606fa4ce 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1547,6 +1547,7 @@ MANIFEST." (define* (profile-derivation manifest #:key + (name "profile") (hooks %default-profile-hooks) (locales? #t) (allow-collisions? #f) @@ -1634,7 +1635,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 -- cgit v1.2.3 From bbf6bc1acc9bbdebf7ee7b68c0fa091733a5f6e1 Mon Sep 17 00:00:00 2001 From: Jakub Kądziołka Date: Wed, 15 Apr 2020 17:12:29 +0200 Subject: git-version: Handle invalid arguments gracefully * guix/git-download.scm (git-version): Add a check for commit ID length. --- guix/git-download.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 1eae035fc4..ef0bb2e281 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 ;;; Copyright © 2017 Mathieu Lirzin ;;; Copyright © 2017 Christopher Baines +;;; Copyright © 2020 Jakub Kądziołka ;;; ;;; 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,13 @@ 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) + (error "git-version: commit ID unexpectedly short")) (string-append version "-" revision "." (string-take commit 7))) (define (git-file-name name version) -- cgit v1.2.3 From e84d9dcd5b80fbacc2853bde53cf0e2da572beb5 Mon Sep 17 00:00:00 2001 From: Jakub Kądziołka Date: Thu, 23 Apr 2020 14:21:00 +0200 Subject: git-version: Raise a condition instead of an error. * guix/git-download.scm (git-version): Replace ERROR with RAISE and CONDITION. This is a follow-up to commit bbf6bc1acc9bbdebf7ee7b68c0fa091733a5f6e1. --- guix/git-download.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index ef0bb2e281..a1c1adf760 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -179,7 +179,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; can happen, for example, when the user swapped the revision and commit ;; arguments by mistake. (when (< (string-length commit) 7) - (error "git-version: commit ID unexpectedly short")) + (raise + (condition + (&message (message "git-version: commit ID unexpectedly short"))))) (string-append version "-" revision "." (string-take commit 7))) (define (git-file-name name version) -- cgit v1.2.3 From f0779922ff260df2404c90504986aa59553154fb Mon Sep 17 00:00:00 2001 From: zimoun Date: Thu, 23 Apr 2020 16:09:00 +0200 Subject: licenses: Export license record. * guix/licenses.scm (): Export it. Signed-off-by: Mathieu Othacehe --- guix/licenses.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index ab2ad3f169..f9bcd96df6 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -32,7 +32,7 @@ (define-module (guix licenses) #:use-module (srfi srfi-9) - #:export (license? license-name license-uri license-comment + #:export (license license? license-name license-uri license-comment agpl1 agpl3 agpl3+ asl1.1 asl2.0 boost1.0 -- cgit v1.2.3 From 12da5162e49ea3b0f2e5e46f7aa5e410ebf30845 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 Apr 2020 23:10:19 +0200 Subject: compile: Pre-load the compiler outside 'with-target'. * guix/build/compile.scm (compile-files): Move call to 'compile' before 'with-target'. Failing to do that, if the target has a different word size than the host, the first call to 'compile-file' fails with: ice-9/eval.scm:293:34: In procedure load-thunk-from-memory: ELF file does not have native word size while attempting loading 'language/spec.go'. --- guix/build/compile.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 3ce0ecede5..c4dbb6e34c 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -194,6 +194,11 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory (with-fluids ((*current-warning-prefix* "")) + ;; 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) + (with-target host (lambda () ;; FIXME: To work around , we first @@ -202,10 +207,6 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." #:report-load report-load #:debug-port debug-port) - ;; Make sure compilation related modules are loaded 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: ;; . -- cgit v1.2.3 From 1597613488d328c7987a18c088cf6e47467223b9 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 24 Apr 2020 09:10:35 +0200 Subject: Revert "licenses: Export license record." This reverts commit f0779922ff260df2404c90504986aa59553154fb. We do not want to export the license record, see: https://lists.gnu.org/archive/html/guix-commits/2020-04/msg01923.html. --- guix/licenses.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index f9bcd96df6..ab2ad3f169 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -32,7 +32,7 @@ (define-module (guix licenses) #:use-module (srfi srfi-9) - #:export (license license? license-name license-uri license-comment + #:export (license? license-name license-uri license-comment agpl1 agpl3 agpl3+ asl1.1 asl2.0 boost1.0 -- cgit v1.2.3 From 962554ddcf86675362486a683acd94863ba68d8a Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Fri, 24 Apr 2020 15:15:50 +0200 Subject: guix package: Export 'search-path-environment-variables'. ...because Emacs-Guix uses it. * guix/scripts/package.scm (search-path-environment-variables): Export. --- guix/scripts/package.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 40445832aa..2eb18919cc 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -63,6 +63,8 @@ delete-matching-generations guix-package + search-path-environment-variables + transaction-upgrade-entry ;mostly for testing (%options . %package-options) -- cgit v1.2.3 From 121191f23ae89415dfbbd3052c7342188cded135 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 2 Mar 2020 20:13:39 +0000 Subject: substitute: Use the same port for multiple request batches. In http-multiple-get. * guix/scripts/substitute.scm (http-multiple-get): Switch port to p in one occurrence. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 95b47a7816..2cb240c2a0 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -538,7 +538,7 @@ initial connection on which HTTP requests are sent." (() (reverse result)) (remainder - (connect port remainder result)))) + (connect p remainder result)))) ((head tail ...) (let* ((resp (read-response p)) (body (response-body-port resp)) -- cgit v1.2.3 From d5abb3049ee4e97865f691eba4c59f5b51de3271 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 2 Mar 2020 20:17:18 +0000 Subject: substitute: Make http-multiple-get batch size configurable. * guix/scripts/substitute.scm (http-multiple-get): Add batch-size parameter. --- guix/scripts/substitute.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 2cb240c2a0..0777aa3d3e 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)) -- cgit v1.2.3 From 928dc1bb1c1e96e6dfbe03dac2185ecf41a7b4f5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 2 Mar 2020 20:20:40 +0000 Subject: substitute: Close port at the end of http-multiple-get. * guix/scripts/substitute.scm (http-multiple-get): Add close-port call. --- guix/scripts/substitute.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 0777aa3d3e..ba2b2d2d4e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -537,6 +537,7 @@ initial connection on which HTTP requests are sent." (() (match (drop requests processed) (() + (close-port p) (reverse result)) (remainder (connect p remainder result)))) -- cgit v1.2.3 From ef674a24c527eaf54801707d34dbf5d12ec139cb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Apr 2020 15:43:43 +0200 Subject: profiles: Add lowerable record type. * guix/profiles.scm (): New record type. * tests/profiles.scm (""): New test. --- guix/profiles.scm | 36 ++++++++++++++++++++++++++++++++++++ tests/profiles.scm | 13 ++++++++++++- 2 files changed, 48 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 88606fa4ce..ab265cce62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -125,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 @@ -1656,6 +1665,33 @@ are cross-built for TARGET." . ,(length (manifest-entries manifest)))))))) +;; Declarative profile. +(define-record-type* profile make-profile + profile? + (name profile-name (default "profile")) ;string + (content profile-content) ; + (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 ) system target) + "Compile PROFILE to a derivation." + (match 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/tests/profiles.scm b/tests/profiles.scm index 21c912a532..055924ba3e 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -223,6 +223,17 @@ (string=? (dirname (readlink bindir)) (derivation->output-path guile)))))) +(test-assertm "" + (mlet* %store-monad + ((entry -> (package->manifest-entry %bootstrap-guile)) + (profile -> (profile (hooks '()) (locales? #f) + (content (manifest (list entry))))) + (drv (lower-object profile)) + (profile -> (derivation->output-path drv)) + (bindir -> (string-append profile "/bin")) + (_ (built-derivations (list drv)))) + (return (file-exists? (string-append bindir "/guile"))))) + (test-assertm "profile-derivation relative symlinks, one entry" (mlet* %store-monad ((entry -> (package->manifest-entry %bootstrap-guile)) -- cgit v1.2.3 From 45c84c8f6f979c84d08b205ed3fb3d6769c4ae3f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Apr 2020 16:11:25 +0200 Subject: pack: Use a declarative profile. * guix/scripts/pack.scm (guix-pack): Use a declarative profile instead of 'profile-derivation'. --- guix/scripts/pack.scm | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6d63fb4b90..f3d1b41c6f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -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 + ;; ). + (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 - ;; ). - #: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 -- cgit v1.2.3 From ccbc427f9ac8f63478f1692686b042a22c4df2c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Apr 2020 22:12:32 +0200 Subject: channels: Use a declarative profile. * guix/channels.scm (package-cache-file): Use 'profile' instead of 'profile-derivation'. --- guix/channels.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 785b97722e..041fae2a9c 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -568,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)) -- cgit v1.2.3 From 5fbc753ab524809cd81e3e5c54b3d0acbe33792d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Apr 2020 22:17:53 +0200 Subject: import: crate: Gracefully handle non-existent crates. Fixes . Reported by Hartmut Goebel . * guix/import/crate.scm (crate->guix-package): Wrap value of 'version-number' and 'version*' in (and crate ...). --- guix/import/crate.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') 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*)) -- cgit v1.2.3 From 47f82b310e320ed6c0282c89748485d1f9212d2c Mon Sep 17 00:00:00 2001 From: Raghav Gururajan Date: Wed, 22 Apr 2020 20:55:40 -0400 Subject: guix: edit: Make nano the default editor. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/edit.scm: Make nano the default editor. Nano is sensible default, as it is installed by base system. For development, user can set custom value for $EDITOR. Signed-off-by: Ludovic Courtès --- guix/scripts/edit.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') 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." -- cgit v1.2.3