summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <marius@gnu.org>2020-11-07 21:33:32 +0100
committerMarius Bakke <marius@gnu.org>2020-11-07 21:33:32 +0100
commit32787d652460871a79f99b63230f92759e2e0de2 (patch)
treece883cac0d602b10b7c005755d035a08197e73a9 /guix
parent052939c2f6e36de00a5e756ea29a4cc96884a55d (diff)
parentc2396ceb6eb30ac87755eb8b39583403b35fbd12 (diff)
downloadguix-patches-32787d652460871a79f99b63230f92759e2e0de2.tar
guix-patches-32787d652460871a79f99b63230f92759e2e0de2.tar.gz
Merge branch 'master' into staging
Conflicts: gnu/local.mk gnu/packages/gdb.scm gnu/packages/lisp-xyz.scm gnu/packages/web-browsers.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/build/maven-build-system.scm3
-rw-r--r--guix/build/maven/pom.scm12
-rw-r--r--guix/download.scm14
-rw-r--r--guix/gexp.scm61
-rw-r--r--guix/git.scm142
-rw-r--r--guix/graph.scm4
-rw-r--r--guix/import/crate.scm2
-rw-r--r--guix/import/print.scm11
-rw-r--r--guix/import/stackage.scm21
-rw-r--r--guix/packages.scm63
-rw-r--r--guix/profiles.scm42
-rw-r--r--guix/scripts/build.scm518
-rw-r--r--guix/scripts/environment.scm5
-rw-r--r--guix/scripts/graph.scm18
-rw-r--r--guix/scripts/install.scm3
-rw-r--r--guix/scripts/lint.scm60
-rw-r--r--guix/scripts/offload.scm28
-rw-r--r--guix/scripts/pack.scm51
-rw-r--r--guix/scripts/package.scm7
-rw-r--r--guix/scripts/publish.scm106
-rwxr-xr-xguix/scripts/substitute.scm2
-rw-r--r--guix/scripts/system.scm3
-rw-r--r--guix/scripts/system/reconfigure.scm17
-rw-r--r--guix/scripts/upgrade.scm3
-rw-r--r--guix/tests.scm10
-rw-r--r--guix/transformations.scm620
26 files changed, 1087 insertions, 739 deletions
diff --git a/guix/build/maven-build-system.scm b/guix/build/maven-build-system.scm
index 914298d584..534b4ebcee 100644
--- a/guix/build/maven-build-system.scm
+++ b/guix/build/maven-build-system.scm
@@ -100,7 +100,8 @@
inputs local-packages excludes)))))))
(define* (fix-pom-files #:key inputs local-packages exclude #:allow-other-keys)
- (fix-pom "pom.xml" inputs local-packages exclude))
+ (fix-pom "pom.xml" inputs local-packages exclude)
+ #t)
(define* (build #:key outputs #:allow-other-keys)
"Build the given package."
diff --git a/guix/build/maven/pom.scm b/guix/build/maven/pom.scm
index aa60af2afa..c92d409d2b 100644
--- a/guix/build/maven/pom.scm
+++ b/guix/build/maven/pom.scm
@@ -59,7 +59,7 @@ represents a @file{.pom} file content, or parts of it."
(pom-ref content "parent"))
(define* (find-parent content inputs #:optional local-packages)
- "Find the parent pom for the pom file whith @var{content} in a package's
+ "Find the parent pom for the pom file with @var{content} in a package's
@var{inputs}. When the parent pom cannot be found in @var{inputs}, but
@var{local-packages} is defined, the parent pom is looked up in it.
@@ -246,14 +246,14 @@ to re-declare the namespaces in the top-level element."
"Open @var{pom-file}, and override its content, rewritting its dependencies
to set their version to the latest version available in the @var{inputs}.
-@var{#:with-plugins?} controls whether plugins are also overiden.
+@var{#:with-plugins?} controls whether plugins are also overridden.
@var{#:with-build-dependencies?} controls whether build dependencies (whose
-scope is not empty) are also overiden. By default build dependencies and
-plugins are not overiden.
+scope is not empty) are also overridden. By default build dependencies and
+plugins are not overridden.
@var{#:excludes} is an association list of groupID to a list of artifactIDs.
When a pair (groupID, artifactID) is present in the list, its entry is
-removed instead of being overiden. If the entry is ignored because of the
+removed instead of being overridden. If the entry is ignored because of the
previous arguments, the entry is not removed.
@var{#:local-packages} is an association list that contains additional version
@@ -262,7 +262,7 @@ not found in @var{inputs}, information from this list is used instead to determi
the latest version of the package. This is an association list of group IDs
to another association list of artifact IDs to a version number.
-Returns nothing, but overides the @var{pom-file} as a side-effect."
+Returns nothing, but overrides the @var{pom-file} as a side-effect."
(define pom (get-pom pom-file))
(define (ls dir)
diff --git a/guix/download.scm b/guix/download.scm
index 6622e252b4..c24e0132c7 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -463,17 +463,17 @@ download by itself using its own dependencies."
#:key (system (%current-system))
(guile (default-guile))
executable?)
- "Return a fixed-output derivation that fetches URL (a string, or a list of
-strings denoting alternate URLs), which is expected to have hash HASH of type
-HASH-ALGO (a symbol). By default, the file name is the base name of URL;
-optionally, NAME can specify a different file name. When EXECUTABLE? is true,
-make the downloaded file executable.
+ "Return a fixed-output derivation that fetches data from URL (a string, or a
+list of strings denoting alternate URLs), which is expected to have hash HASH
+of type HASH-ALGO (a symbol). By default, the file name is the base name of
+URL; optionally, NAME can specify a different file name. When EXECUTABLE? is
+true, make the downloaded file executable.
When one of the URL starts with mirror://, then its host part is
interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
-Alternately, when URL starts with file://, return the corresponding file name
-in the store."
+Alternatively, when URL starts with file://, return the corresponding file
+name in the store."
(define file-name
(match url
((head _ ...)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9339b226b7..051831238e 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -35,6 +35,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (gexp
gexp?
@@ -146,12 +147,17 @@
;; "G expressions".
(define-record-type <gexp>
- (make-gexp references modules extensions proc)
+ (make-gexp references modules extensions proc location)
gexp?
(references gexp-references) ;list of <gexp-input>
(modules gexp-self-modules) ;list of module names
(extensions gexp-self-extensions) ;list of lowerable things
- (proc gexp-proc)) ;procedure
+ (proc gexp-proc) ;procedure
+ (location %gexp-location)) ;location alist
+
+(define (gexp-location gexp)
+ "Return the source code location of GEXP."
+ (and=> (%gexp-location gexp) source-properties->location))
(define (write-gexp gexp port)
"Write GEXP on PORT."
@@ -164,6 +170,11 @@
(write (apply (gexp-proc gexp)
(gexp-references gexp))
port))
+
+ (let ((loc (gexp-location gexp)))
+ (when loc
+ (format port " ~a" (location->string loc))))
+
(format port " ~a>"
(number->string (object-address gexp) 16)))
@@ -737,22 +748,26 @@ whether this should be considered a \"native\" input or not."
(set-record-type-printer! <gexp-output> write-gexp-output)
-(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?))
+(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?)
+ #:key (validate (const #t)))
"Recurse on GEXP and the expressions it refers to, summing the items
returned by SELF-ATTRIBUTE, a procedure that takes a gexp. Use EQUAL? as the
-second argument to 'delete-duplicates'."
+second argument to 'delete-duplicates'. Pass VALIDATE every gexp and
+attribute that is traversed."
(if (gexp? gexp)
(delete-duplicates
- (append (self-attribute gexp)
+ (append (let ((attribute (self-attribute gexp)))
+ (validate gexp attribute)
+ attribute)
(append-map (match-lambda
(($ <gexp-input> (? gexp? exp))
- (gexp-attribute exp self-attribute))
+ (gexp-attribute exp self-attribute
+ #:validate validate))
(($ <gexp-input> (lst ...))
(append-map (lambda (item)
- (if (gexp? item)
- (gexp-attribute item
- self-attribute)
- '()))
+ (gexp-attribute item self-attribute
+ #:validate
+ validate))
lst))
(_
'()))
@@ -778,7 +793,25 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
(_
(equal? m1 m2))))
- (gexp-attribute gexp gexp-self-modules module=?))
+ (define (validate-modules gexp modules)
+ ;; Warn if MODULES, imported by GEXP, contains modules that in general
+ ;; should not be imported from the host because they vary from user to
+ ;; user and may thus be a source of non-reproducibility. This includes
+ ;; (guix config) as well as modules that come with Guile.
+ (match (filter (match-lambda
+ ((or ('guix 'config) ('ice-9 . _)) #t)
+ (_ #f))
+ modules)
+ (() #t)
+ (suspects
+ (warning (gexp-location gexp)
+ (N_ "importing module~{ ~a~} from the host~%"
+ "importing modules~{ ~a~} from the host~%"
+ (length suspects))
+ suspects))))
+
+ (gexp-attribute gexp gexp-self-modules module=?
+ #:validate validate-modules))
(define (gexp-extensions gexp)
"Return the list of Guile extensions (packages) GEXP relies on. If (gexp?
@@ -1084,7 +1117,8 @@ The other arguments are as for 'derivation'."
(make-gexp (gexp-references exp)
(append modules (gexp-self-modules exp))
(gexp-self-extensions exp)
- (gexp-proc exp))))
+ (gexp-proc exp)
+ (gexp-location exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
@@ -1414,7 +1448,8 @@ execution environment."
current-imported-modules
current-imported-extensions
(lambda #,formals
- #,sexp)))))))
+ #,sexp)
+ (current-source-location)))))))
;;;
diff --git a/guix/git.scm b/guix/git.scm
index 637936c16a..364b4997ae 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -20,6 +20,7 @@
(define-module (guix git)
#:use-module (git)
#:use-module (git object)
+ #:use-module (git submodule)
#:use-module (guix i18n)
#:use-module (guix base32)
#:use-module (gcrypt hash)
@@ -30,7 +31,9 @@
#:use-module (guix gexp)
#:use-module (guix sets)
#:use-module ((guix diagnostics) #:select (leave))
+ #:use-module (guix progress)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -116,9 +119,61 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
(string-append "R:" url)
url))))))
-;; Authentication appeared in Guile-Git 0.3.0, check if it is available.
-(define auth-supported?
- (false-if-exception (resolve-interface '(git auth))))
+(define (show-progress progress)
+ "Display a progress bar as we fetch Git code. PROGRESS is an
+<indexer-progress> record from (git)."
+ (define total
+ (indexer-progress-total-objects progress))
+
+ (define hundredth
+ (match (quotient (indexer-progress-total-objects progress) 100)
+ (0 1)
+ (x x)))
+
+ (define-values (done label)
+ (if (< (indexer-progress-received-objects progress) total)
+ (values (indexer-progress-received-objects progress)
+ (G_ "receiving objects"))
+ (values (indexer-progress-indexed-objects progress)
+ (G_ "indexing objects"))))
+
+ (define %
+ (* 100. (/ done total)))
+
+ (when (and (< % 100) (zero? (modulo done hundredth)))
+ (erase-current-line (current-error-port))
+ (let ((width (max (- (current-terminal-columns)
+ (string-length label) 7)
+ 3)))
+ (format (current-error-port) "~a ~3,d% ~a"
+ label (inexact->exact (round %))
+ (progress-bar % width)))
+ (force-output (current-error-port)))
+
+ (when (= % 100.)
+ ;; We're done, erase the line.
+ (erase-current-line (current-error-port))
+ (force-output (current-error-port)))
+
+ ;; Return true to indicate that we should go on.
+ #t)
+
+(define (make-default-fetch-options)
+ "Return the default fetch options."
+ (let ((auth-method (%make-auth-ssh-agent)))
+ ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git
+ ;; 0.4.0. Omit them when using an older version.
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (make-fetch-options auth-method
+ ;; Guile-Git doesn't distinguish between these.
+ #:proxy-url (or (getenv "http_proxy")
+ (getenv "https_proxy"))
+ #:transfer-progress
+ (and (isatty? (current-error-port))
+ show-progress)))
+ (lambda args
+ (make-fetch-options auth-method)))))
(define (clone* url directory)
"Clone git repository at URL into DIRECTORY. Upon failure,
@@ -127,18 +182,10 @@ make sure no empty directory is left behind."
(lambda ()
(mkdir-p directory)
- ;; Note: Explicitly pass options to work around the invalid default
- ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
- (if (module-defined? (resolve-interface '(git))
- 'clone-init-options)
- (let ((auth-method (and auth-supported?
- (%make-auth-ssh-agent))))
- (clone url directory
- (if auth-supported?
- (make-clone-options
- #:fetch-options (make-fetch-options auth-method))
- (clone-init-options))))
- (clone url directory)))
+ (let ((auth-method (%make-auth-ssh-agent)))
+ (clone url directory
+ (make-clone-options
+ #:fetch-options (make-default-fetch-options)))))
(lambda _
(false-if-exception (rmdir directory)))))
@@ -167,12 +214,7 @@ corresponding Git object."
;; read out-of-bounds when passed a string shorter than 40 chars,
;; which is why we delay calls to it below.
(if (< len 40)
- (if (module-defined? (resolve-interface '(git object))
- 'object-lookup-prefix)
- (object-lookup-prefix repository (string->oid commit) len)
- (raise (condition
- (&message
- (message "long Git object ID is required")))))
+ (object-lookup-prefix repository (string->oid commit) len)
(object-lookup repository (string->oid commit)))))
(('tag-or-commit . str)
(if (or (> (string-length str) 40)
@@ -234,40 +276,23 @@ dynamic extent of EXP."
(lambda (key err)
(report-git-error err))))
-(define (load-git-submodules)
- "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0.
-Return true on success, false on failure."
- (match (false-if-exception (resolve-interface '(git submodule)))
- (#f
- (set! load-git-submodules (const #f))
- #f)
- (iface
- (module-use! (resolve-module '(guix git)) iface)
- (set! load-git-submodules (const #t))
- #t)))
-
(define* (update-submodules repository
#:key (log-port (current-error-port)))
"Update the submodules of REPOSITORY, a Git repository object."
- ;; Guile-Git < 0.2.0 did not have (git submodule).
- (if (load-git-submodules)
- (for-each (lambda (name)
- (let ((submodule (submodule-lookup repository name)))
- (format log-port (G_ "updating submodule '~a'...~%")
- name)
- (submodule-update submodule)
-
- ;; Recurse in SUBMODULE.
- (let ((directory (string-append
- (repository-working-directory repository)
- "/" (submodule-path submodule))))
- (with-repository directory repository
- (update-submodules repository
- #:log-port log-port)))))
- (repository-submodules repository))
- (format (current-error-port)
- (G_ "Support for submodules is missing; \
-please upgrade Guile-Git.~%"))))
+ (for-each (lambda (name)
+ (let ((submodule (submodule-lookup repository name)))
+ (format log-port (G_ "updating submodule '~a'...~%")
+ name)
+ (submodule-update submodule)
+
+ ;; Recurse in SUBMODULE.
+ (let ((directory (string-append
+ (repository-working-directory repository)
+ "/" (submodule-path submodule))))
+ (with-repository directory repository
+ (update-submodules repository
+ #:log-port log-port)))))
+ (repository-submodules repository)))
(define-syntax-rule (false-if-git-not-found exp)
"Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
@@ -331,12 +356,9 @@ it unchanged."
;; Only fetch remote if it has not been cloned just before.
(when (and cache-exists?
(not (reference-available? repository ref)))
- (if auth-supported?
- (let ((auth-method (and auth-supported?
- (%make-auth-ssh-agent))))
- (remote-fetch (remote-lookup repository "origin")
- #:fetch-options (make-fetch-options auth-method)))
- (remote-fetch (remote-lookup repository "origin"))))
+ (let ((auth-method (%make-auth-ssh-agent)))
+ (remote-fetch (remote-lookup repository "origin")
+ #:fetch-options (make-default-fetch-options))))
(when recursive?
(update-submodules repository #:log-port log-port))
@@ -359,9 +381,7 @@ it unchanged."
;; Reclaim file descriptors and memory mappings associated with
;; REPOSITORY as soon as possible.
- (when (module-defined? (resolve-interface '(git repository))
- 'repository-close!)
- (repository-close! repository))
+ (repository-close! repository)
(values cache-directory (oid->string oid) relation)))))
diff --git a/guix/graph.scm b/guix/graph.scm
index b695ca4306..93ff9ef81a 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -142,7 +142,7 @@ typically returned by 'node-edges' or 'node-back-edges'."
nodes node-edges))
(define (shortest-path node1 node2 type)
- "Return as a monadic value the shorted path, represented as a list, from
+ "Return as a monadic value the shortest path, represented as a list, from
NODE1 to NODE2 of the given TYPE. Return #f when there is no path."
(define node-edges
(node-type-edges type))
@@ -238,7 +238,7 @@ NODE1 to NODE2 of the given TYPE. Return #f when there is no path."
(define (emit-epilogue port)
(display "\n}\n" port))
(define (emit-node id label port)
- (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
+ (format port " \"~a\" [label = \"~a\", shape = box, fontname = sans];~%"
id label))
(define (emit-edge id1 id2 port)
(format port " \"~a\" -> \"~a\" [color = ~a];~%"
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index f87c89163c..8c2b76cab4 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -167,7 +167,7 @@ and LICENSE."
(maybe-cargo-development-inputs
cargo-development-inputs)))
(home-page ,(match home-page
- (() "")
+ ('null "")
(_ home-page)))
(synopsis ,synopsis)
(description ,(beautify-description description))
diff --git a/guix/import/print.scm b/guix/import/print.scm
index 11cc218285..d21ce57aeb 100644
--- a/guix/import/print.scm
+++ b/guix/import/print.scm
@@ -74,7 +74,7 @@ when evaluated."
(define (source->code source version)
(let ((uri (origin-uri source))
(method (origin-method source))
- (sha256 (origin-sha256 source))
+ (hash (origin-hash source))
(file-name (origin-file-name source))
(patches (origin-patches source)))
`(origin
@@ -82,9 +82,12 @@ when evaluated."
(uri (string-append ,@(match (factorize-uri uri version)
((? string? uri) (list uri))
(factorized factorized))))
- (sha256
- (base32
- ,(format #f "~a" (bytevector->nix-base32-string sha256))))
+ ,(if (equal? (content-hash-algorithm hash) 'sha256)
+ `(sha256 (base32 ,(bytevector->nix-base32-string
+ (content-hash-value hash))))
+ `(hash (content-hash ,(bytevector->nix-base32-string
+ (content-hash-value hash))
+ ,(content-hash-algorithm hash))))
;; FIXME: in order to be able to throw away the directory prefix,
;; we just assume that the patch files can be found with
;; "search-patches".
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index ee12108815..93cf214127 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -39,12 +39,10 @@
;;; Stackage info fetcher and access functions
;;;
-(define %stackage-url "http://www.stackage.org")
+(define %stackage-url "https://www.stackage.org")
-(define (lts-info-ghc-version lts-info)
- "Returns the version of the GHC compiler contained in LTS-INFO."
- (and=> (assoc-ref lts-info "snapshot")
- (cut assoc-ref <> "ghc")))
+;; Latest LTS version compatible with GHC 8.6.5.
+(define %default-lts-version "14.27")
(define (lts-info-packages lts-info)
"Returns the alist of packages contained in LTS-INFO."
@@ -57,9 +55,10 @@
;; "Retrieve the information about the LTS Stackage release VERSION."
(memoize
(lambda* (#:optional (version ""))
- (let* ((url (if (string=? "" version)
- (string-append %stackage-url "/lts")
- (string-append %stackage-url "/lts-" version)))
+ (let* ((url (string-append %stackage-url
+ "/lts-" (if (string-null? version)
+ %default-lts-version
+ version)))
(lts-info (json-fetch url)))
(if lts-info
(reverse lts-info)
@@ -90,7 +89,7 @@
(lambda* (package-name ; upstream name
#:key
(include-test-dependencies? #t)
- (lts-version "")
+ (lts-version %default-lts-version)
(packages-info
(lts-info-packages
(stackage-lts-info-fetch lts-version))))
@@ -119,7 +118,9 @@ included in the Stackage LTS release."
;;;
(define latest-lts-release
- (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch)))))
+ (let ((pkgs-info
+ (mlambda () (lts-info-packages
+ (stackage-lts-info-fetch %default-lts-version)))))
(lambda* (package)
"Return an <upstream-source> for the latest Stackage LTS release of
PACKAGE or #f if the package is not included in the Stackage LTS release."
diff --git a/guix/packages.scm b/guix/packages.scm
index 24d6417065..6fa761f569 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1015,8 +1015,7 @@ applied to implicit inputs as well."
(define (rewrite input)
(match input
((label (? package? package) outputs ...)
- (let ((proc (if (cut? package) proc replace)))
- (cons* label (proc package) outputs)))
+ (cons* label (replace package) outputs))
(_
input)))
@@ -1027,28 +1026,44 @@ applied to implicit inputs as well."
(define replace
(mlambdaq (p)
;; If P is the result of a previous call, return it.
- (if (assq-ref (package-properties p) mapping-property)
- p
-
- ;; Return a variant of P with PROC applied to P and its explicit
- ;; dependencies, recursively. Memoize the transformations. Failing
- ;; to do that, we would build a huge object graph with lots of
- ;; duplicates, which in turns prevents us from benefiting from
- ;; memoization in 'package-derivation'.
- (let ((p (proc p)))
- (package
- (inherit p)
- (location (package-location p))
- (build-system (if deep?
- (build-system-with-package-mapping
- (package-build-system p) rewrite)
- (package-build-system p)))
- (inputs (map rewrite (package-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))
- (replacement (and=> (package-replacement p) replace))
- (properties `((,mapping-property . #t)
- ,@(package-properties p))))))))
+ (cond ((assq-ref (package-properties p) mapping-property)
+ p)
+
+ ((cut? p)
+ ;; Since P's propagated inputs are really inputs of its dependents,
+ ;; rewrite them as well, unless we're doing a "shallow" rewrite.
+ (let ((p (proc p)))
+ (if (or (not deep?)
+ (null? (package-propagated-inputs p)))
+ p
+ (package
+ (inherit p)
+ (location (package-location p))
+ (replacement (package-replacement p))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p)))))))
+
+ (else
+ ;; Return a variant of P with PROC applied to P and its explicit
+ ;; dependencies, recursively. Memoize the transformations. Failing
+ ;; to do that, we would build a huge object graph with lots of
+ ;; duplicates, which in turns prevents us from benefiting from
+ ;; memoization in 'package-derivation'.
+ (let ((p (proc p)))
+ (package
+ (inherit p)
+ (location (package-location p))
+ (build-system (if deep?
+ (build-system-with-package-mapping
+ (package-build-system p) rewrite)
+ (package-build-system p)))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (replacement (and=> (package-replacement p) replace))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p)))))))))
replace)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 856a05eed1..1b15257210 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1301,31 +1301,43 @@ entries. It's used to query the MIME type of a given file."
(define shared-mime-info ; lazy reference
(module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
- (mlet %store-monad ((glib
- (manifest-lookup-package
- manifest "glib")))
+ (mlet %store-monad ((glib (manifest-lookup-package manifest "glib")))
(define build
(with-imported-modules '((guix build utils)
(guix build union))
#~(begin
- (use-modules (srfi srfi-26)
- (guix build utils)
- (guix build union))
+ (use-modules (guix build utils)
+ (guix build union)
+ (srfi srfi-26)
+ (ice-9 match))
+
(let* ((datadir (string-append #$output "/share"))
(destdir (string-append datadir "/mime"))
(pkgdirs (filter file-exists?
(map (cut string-append <>
"/share/mime/packages")
(cons #+shared-mime-info
- '#$(manifest-inputs manifest)))))
- (update-mime-database (string-append
- #+shared-mime-info
- "/bin/update-mime-database")))
- (mkdir-p destdir)
- (union-build (string-append destdir "/packages") pkgdirs
- #:log-port (%make-void-port "w"))
- (setenv "XDG_DATA_HOME" datadir)
- (exit (zero? (system* update-mime-database destdir)))))))
+ '#$(manifest-inputs manifest))))))
+
+ (match pkgdirs
+ ((shared-mime-info)
+ ;; PKGDIRS contains nothing but 'shared-mime-info', which
+ ;; already contains its database, so nothing to do.
+ (mkdir-p datadir)
+ (symlink #$(file-append shared-mime-info "/share/mime")
+ destdir))
+ (_
+ ;; PKGDIRS contains additional packages providing
+ ;; 'share/mime/packages' (very few packages do so) so rebuild
+ ;; the database. TODO: Find a way to avoid reprocessing
+ ;; 'shared-mime-info', which is the most expensive one.
+ (mkdir-p destdir)
+ (union-build (string-append destdir "/packages") pkgdirs
+ #:log-port (%make-void-port "w"))
+ (setenv "XDG_DATA_HOME" datadir)
+ (invoke #+(file-append shared-mime-info
+ "/bin/update-mime-database")
+ destdir)))))))
;; Don't run the hook when there are no GLib based applications.
(if glib
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index e59e0ee67f..e9de97c881 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -31,11 +31,6 @@
#:use-module (guix utils)
- ;; Use the procedure that destructures "NAME-VERSION" forms.
- #:use-module ((guix build utils)
- #:select ((package-name->name+version
- . hyphen-package-name->name+version)))
-
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix profiles)
@@ -45,28 +40,22 @@
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
- #:autoload (guix download) (download-to-store)
- #:autoload (guix git-download) (git-reference? git-reference-url)
- #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix progress) #:select (current-terminal-columns))
#:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module (guix transformations)
#:export (%standard-build-options
set-build-options-from-command-line
set-build-options-from-command-line*
show-build-options-help
- %transformation-options
- options->transformation
- manifest-entry-with-transformations
- show-transformation-options-help
-
guix-build
register-root
register-root*))
@@ -151,493 +140,6 @@ found. Return #f if no build log was found."
(define register-root*
(store-lift register-root))
-(define (numeric-extension? file-name)
- "Return true if FILE-NAME ends with digits."
- (string-every char-set:hex-digit (file-extension file-name)))
-
-(define (tarball-base-name file-name)
- "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
-extensions."
- ;; TODO: Factorize.
- (cond ((not (file-extension file-name))
- file-name)
- ((numeric-extension? file-name)
- file-name)
- ((string=? (file-extension file-name) "tar")
- (file-sans-extension file-name))
- ((file-extension file-name)
- =>
- (match-lambda
- ("scm" file-name)
- (else (tarball-base-name (file-sans-extension file-name)))))
- (else
- file-name)))
-
-(define* (package-with-source store p uri #:optional version)
- "Return a package based on P but with its source taken from URI. Extract
-the new package's version number from URI."
- (let ((base (tarball-base-name (basename uri))))
- (let-values (((_ version*)
- (hyphen-package-name->name+version base)))
- (package (inherit p)
- (version (or version version*
- (package-version p)))
-
- ;; Use #:recursive? #t to allow for directories.
- (source (download-to-store store uri
- #:recursive? #t))
-
- ;; Override the replacement, otherwise '--with-source' would
- ;; have no effect.
- (replacement #f)))))
-
-
-;;;
-;;; Transformations.
-;;;
-
-(define (transform-package-source sources)
- "Return a transformation procedure that replaces package sources with the
-matching URIs given in SOURCES."
- (define new-sources
- (map (lambda (uri)
- (match (string-index uri #\=)
- (#f
- ;; Determine the package name and version from URI.
- (call-with-values
- (lambda ()
- (hyphen-package-name->name+version
- (tarball-base-name (basename uri))))
- (lambda (name version)
- (list name version uri))))
- (index
- ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
- (call-with-values
- (lambda ()
- (package-name->name+version (string-take uri index)))
- (lambda (name version)
- (list name version
- (string-drop uri (+ 1 index))))))))
- sources))
-
- (lambda (store obj)
- (let loop ((sources new-sources)
- (result '()))
- (match obj
- ((? package? p)
- (match (assoc-ref sources (package-name p))
- ((version source)
- (package-with-source store p source version))
- (#f
- p)))
- (_
- obj)))))
-
-(define (evaluate-replacement-specs specs proc)
- "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
-of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
-PROC is called with the package to be replaced and its replacement according
-to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
-package it refers to could not be found."
- (define not-equal
- (char-set-complement (char-set #\=)))
-
- (map (lambda (spec)
- (match (string-tokenize spec not-equal)
- ((spec new)
- (cons spec
- (let ((new (specification->package new)))
- (lambda (old)
- (proc old new)))))
- (x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
- specs))
-
-(define (transform-package-inputs replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile=guile@2.1\" meaning that, any dependency on a package
-called \"guile\" must be replaced with a dependency on a version 2.1 of
-\"guile\"."
- (let* ((replacements (evaluate-replacement-specs replacement-specs
- (lambda (old new)
- new)))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-inputs/graft replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
-current 'gnutls' package, after which version 3.5.4 is grafted onto them."
- (define (set-replacement old new)
- (package (inherit old) (replacement new)))
-
- (let* ((replacements (evaluate-replacement-specs replacement-specs
- set-replacement))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define %not-equal
- (char-set-complement (char-set #\=)))
-
-(define (package-git-url package)
- "Return the URL of the Git repository for package, or raise an error if
-the source of PACKAGE is not fetched from a Git repository."
- (let ((source (package-source package)))
- (cond ((and (origin? source)
- (git-reference? (origin-uri source)))
- (git-reference-url (origin-uri source)))
- ((git-checkout? source)
- (git-checkout-url source))
- (else
- (leave (G_ "the source of ~a is not a Git reference~%")
- (package-full-name package))))))
-
-(define (evaluate-git-replacement-specs specs proc)
- "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
-of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
-replacement package. Raise an error if an element of SPECS uses invalid
-syntax, or if a package it refers to could not be found."
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec branch-or-commit)
- (define (replace old)
- (let* ((source (package-source old))
- (url (package-git-url old)))
- (proc old url branch-or-commit)))
-
- (cons spec replace))
- (x
- (leave (G_ "invalid replacement specification: ~s~%") spec))))
- specs))
-
-(define (transform-package-source-branch replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile-next=stable-3.0\" meaning that packages are built using
-'guile-next' from the latest commit on its 'stable-3.0' branch."
- (define (replace old url branch)
- (package
- (inherit old)
- (version (string-append "git." (string-map (match-lambda
- (#\/ #\-)
- (chr chr))
- branch)))
- (source (git-checkout (url url) (branch branch)
- (recursive? #t)))))
-
- (let* ((replacements (evaluate-git-replacement-specs replacement-specs
- replace))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-source-commit replacement-specs)
- "Return a procedure that, when passed a package, replaces its direct
-dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
-strings like \"guile-next=cabba9e\" meaning that packages are built using
-'guile-next' from commit 'cabba9e'."
- (define (replace old url commit)
- (package
- (inherit old)
- (version (if (and (> (string-length commit) 1)
- (string-prefix? "v" commit)
- (char-set-contains? char-set:digit
- (string-ref commit 1)))
- (string-drop commit 1) ;looks like a tag like "v1.0"
- (string-append "git."
- (if (< (string-length commit) 7)
- commit
- (string-take commit 7)))))
- (source (git-checkout (url url) (commit commit)
- (recursive? #t)))))
-
- (let* ((replacements (evaluate-git-replacement-specs replacement-specs
- replace))
- (rewrite (package-input-rewriting/spec replacements)))
- (lambda (store obj)
- (if (package? obj)
- (rewrite obj)
- obj))))
-
-(define (transform-package-source-git-url replacement-specs)
- "Return a procedure that, when passed a package, replaces its dependencies
-according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
-\"guile-json=https://gitthing.com/…\" meaning that packages are built using
-a checkout of the Git repository at the given URL."
- (define replacements
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec url)
- (cons spec
- (lambda (old)
- (package
- (inherit old)
- (source (git-checkout (url url)
- (recursive? #t)))))))
- (_
- (leave (G_ "~a: invalid Git URL replacement specification~%")
- spec))))
- replacement-specs))
-
- (define rewrite
- (package-input-rewriting/spec replacements))
-
- (lambda (store obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define (package-dependents/spec top bottom)
- "Return the list of dependents of BOTTOM, a spec string, that are also
-dependencies of TOP, a package."
- (define-values (name version)
- (package-name->name+version bottom))
-
- (define dependent?
- (mlambda (p)
- (and (package? p)
- (or (and (string=? name (package-name p))
- (or (not version)
- (version-prefix? version (package-version p))))
- (match (bag-direct-inputs (package->bag p))
- (((labels dependencies . _) ...)
- (any dependent? dependencies)))))))
-
- (filter dependent? (package-closure (list top))))
-
-(define (package-toolchain-rewriting p bottom toolchain)
- "Return a procedure that, when passed a package that's either BOTTOM or one
-of its dependents up to P so, changes it so it is built with TOOLCHAIN.
-TOOLCHAIN must be an input list."
- (define rewriting-property
- (gensym " package-toolchain-rewriting"))
-
- (match (package-dependents/spec p bottom)
- (() ;P does not depend on BOTTOM
- identity)
- (set
- ;; SET is the list of packages "between" P and BOTTOM (included) whose
- ;; toolchain needs to be changed.
- (package-mapping (lambda (p)
- (if (or (assq rewriting-property
- (package-properties p))
- (not (memq p set)))
- p
- (let ((p (package-with-c-toolchain p toolchain)))
- (package/inherit p
- (properties `((,rewriting-property . #t)
- ,@(package-properties p)))))))
- (lambda (p)
- (or (assq rewriting-property (package-properties p))
- (not (memq p set))))
- #:deep? #t))))
-
-(define (transform-package-toolchain replacement-specs)
- "Return a procedure that, when passed a package, changes its toolchain or
-that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
-a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
-the left of the equal sign must be built with the toolchain to the right of
-the equal sign."
- (define split-on-commas
- (cute string-tokenize <> (char-set-complement (char-set #\,))))
-
- (define (specification->input spec)
- (let ((package (specification->package spec)))
- (list (package-name package) package)))
-
- (define replacements
- (map (lambda (spec)
- (match (string-tokenize spec %not-equal)
- ((spec (= split-on-commas toolchain))
- (cons spec (map specification->input toolchain)))
- (_
- (leave (G_ "~a: invalid toolchain replacement specification~%")
- spec))))
- replacement-specs))
-
- (lambda (store obj)
- (if (package? obj)
- (or (any (match-lambda
- ((bottom . toolchain)
- ((package-toolchain-rewriting obj bottom toolchain) obj)))
- replacements)
- obj)
- obj)))
-
-(define (transform-package-tests specs)
- "Return a procedure that, when passed a package, sets #:tests? #f in its
-'arguments' field."
- (define (package-without-tests p)
- (package/inherit p
- (arguments
- (substitute-keyword-arguments (package-arguments p)
- ((#:tests? _ #f) #f)))))
-
- (define rewrite
- (package-input-rewriting/spec (map (lambda (spec)
- (cons spec package-without-tests))
- specs)))
-
- (lambda (store obj)
- (if (package? obj)
- (rewrite obj)
- obj)))
-
-(define %transformations
- ;; Transformations that can be applied to things to build. The car is the
- ;; key used in the option alist, and the cdr is the transformation
- ;; procedure; it is called with two arguments: the store, and a list of
- ;; things to build.
- `((with-source . ,transform-package-source)
- (with-input . ,transform-package-inputs)
- (with-graft . ,transform-package-inputs/graft)
- (with-branch . ,transform-package-source-branch)
- (with-commit . ,transform-package-source-commit)
- (with-git-url . ,transform-package-source-git-url)
- (with-c-toolchain . ,transform-package-toolchain)
- (without-tests . ,transform-package-tests)))
-
-(define (transformation-procedure key)
- "Return the transformation procedure associated with KEY, a symbol such as
-'with-source', or #f if there is none."
- (any (match-lambda
- ((k . proc)
- (and (eq? k key) proc)))
- %transformations))
-
-(define %transformation-options
- ;; The command-line interface to the above transformations.
- (let ((parser (lambda (symbol)
- (lambda (opt name arg result . rest)
- (apply values
- (alist-cons symbol arg result)
- rest)))))
- (list (option '("with-source") #t #f
- (parser 'with-source))
- (option '("with-input") #t #f
- (parser 'with-input))
- (option '("with-graft") #t #f
- (parser 'with-graft))
- (option '("with-branch") #t #f
- (parser 'with-branch))
- (option '("with-commit") #t #f
- (parser 'with-commit))
- (option '("with-git-url") #t #f
- (parser 'with-git-url))
- (option '("with-c-toolchain") #t #f
- (parser 'with-c-toolchain))
- (option '("without-tests") #t #f
- (parser 'without-tests)))))
-
-(define (show-transformation-options-help)
- (display (G_ "
- --with-source=[PACKAGE=]SOURCE
- use SOURCE when building the corresponding package"))
- (display (G_ "
- --with-input=PACKAGE=REPLACEMENT
- replace dependency PACKAGE by REPLACEMENT"))
- (display (G_ "
- --with-graft=PACKAGE=REPLACEMENT
- graft REPLACEMENT on packages that refer to PACKAGE"))
- (display (G_ "
- --with-branch=PACKAGE=BRANCH
- build PACKAGE from the latest commit of BRANCH"))
- (display (G_ "
- --with-commit=PACKAGE=COMMIT
- build PACKAGE from COMMIT"))
- (display (G_ "
- --with-git-url=PACKAGE=URL
- build PACKAGE from the repository at URL"))
- (display (G_ "
- --with-c-toolchain=PACKAGE=TOOLCHAIN
- build PACKAGE and its dependents with TOOLCHAIN"))
- (display (G_ "
- --without-tests=PACKAGE
- build PACKAGE without running its tests")))
-
-
-(define (options->transformation opts)
- "Return a procedure that, when passed an object to build (package,
-derivation, etc.), applies the transformations specified by OPTS."
- (define applicable
- ;; List of applicable transformations as symbol/procedure pairs in the
- ;; order in which they appear on the command line.
- (filter-map (match-lambda
- ((key . value)
- (match (transformation-procedure key)
- (#f
- #f)
- (transform
- ;; XXX: We used to pass TRANSFORM a list of several
- ;; arguments, but we now pass only one, assuming that
- ;; transform composes well.
- (list key value (transform (list value)))))))
- (reverse opts)))
-
- (define (package-with-transformation-properties p)
- (package/inherit p
- (properties `((transformations
- . ,(map (match-lambda
- ((key value _)
- (cons key value)))
- applicable))
- ,@(package-properties p)))))
-
- (lambda (store obj)
- (define (tagged-object new)
- (if (and (not (eq? obj new))
- (package? new) (not (null? applicable)))
- (package-with-transformation-properties new)
- new))
-
- (tagged-object
- (fold (match-lambda*
- (((name value transform) obj)
- (let ((new (transform store obj)))
- (when (eq? new obj)
- (warning (G_ "transformation '~a' had no effect on ~a~%")
- name
- (if (package? obj)
- (package-full-name obj)
- obj)))
- new)))
- obj
- applicable))))
-
-(define (package-transformations package)
- "Return the transformations applied to PACKAGE according to its properties."
- (match (assq-ref (package-properties package) 'transformations)
- (#f '())
- (transformations transformations)))
-
-(define (manifest-entry-with-transformations entry)
- "Return ENTRY with an additional 'transformations' property if it's not
-already there."
- (let ((properties (manifest-entry-properties entry)))
- (if (assq 'transformations properties)
- entry
- (let ((item (manifest-entry-item entry)))
- (manifest-entry
- (inherit entry)
- (properties
- (match (and (package? item)
- (package-transformations item))
- ((or #f '())
- properties)
- (transformations
- `((transformations . ,transformations)
- ,@properties)))))))))
-
;;;
;;; Standard command-line build options.
@@ -678,6 +180,8 @@ options handled by 'set-build-options-from-command-line', and listed in
(display (G_ "
-M, --max-jobs=N allow at most N build jobs"))
(display (G_ "
+ --help-transform list package transformation options not shown here"))
+ (display (G_ "
--debug=LEVEL produce debugging output at LEVEL")))
(define (set-build-options-from-command-line store opts)
@@ -813,7 +317,14 @@ use '--no-offload' instead~%")))
(if c
(apply values (alist-cons 'max-jobs c result) rest)
(leave (G_ "not a number: '~a' option argument: ~a~%")
- name arg)))))))
+ name arg)))))
+ (option '("help-transform") #f #f
+ (lambda _
+ (format #t
+ (G_ "Available package transformation options:~%"))
+ (show-transformation-options-help)
+ (newline)
+ (exit 0)))))
;;;
@@ -870,8 +381,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(newline)
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
@@ -1053,8 +562,7 @@ build."
(systems systems)))
(define things-to-build
- (map (cut transform store <>)
- (options->things-to-build opts)))
+ (map transform (options->things-to-build opts)))
(define (compute-derivation obj system)
;; Compute the derivation of OBJ for SYSTEM.
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 085f11a9d4..2328df98b8 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -32,6 +32,7 @@
#:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (gnu build linux-container)
#:use-module (gnu build accounts)
#:use-module ((guix build syscalls) #:select (set-network-interface-up))
@@ -179,8 +180,6 @@ COMMAND or an interactive shell in that environment.\n"))
(newline)
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
@@ -322,7 +321,7 @@ for the corresponding packages."
(manifest-entry-output e2))))
(define transform
- (cut (options->transformation opts) store <>))
+ (options->transformation opts))
(define* (package->manifest-entry* package #:optional (output "out"))
(package->manifest-entry (transform package) output))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index d7a08a4fe1..6874904deb 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -34,11 +34,11 @@
#:use-module (guix sets)
#:use-module ((guix diagnostics)
#:select (location-file formatted-message))
- #:use-module ((guix scripts build)
- #:select (show-transformation-options-help
- options->transformation
- %standard-build-options
+ #:use-module ((guix transformations)
+ #:select (options->transformation
%transformation-options))
+ #:use-module ((guix scripts build)
+ #:select (%standard-build-options))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@@ -546,8 +546,6 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(display (G_ "
-L, --load-path=DIR prepend DIR to the package module search path"))
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
@@ -585,11 +583,11 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(('argument . (? store-path? item))
item)
(('argument . spec)
- (transform store
- (specification->package spec)))
+ (transform
+ (specification->package spec)))
(('expression . exp)
- (transform store
- (read/eval-package-expression exp)))
+ (transform
+ (read/eval-package-expression exp)))
(_ #f))
opts)))
(run-with-store store
diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm
index 894e60f9da..82f5875dd1 100644
--- a/guix/scripts/install.scm
+++ b/guix/scripts/install.scm
@@ -20,6 +20,7 @@
#:use-module (guix ui)
#:use-module (guix scripts package)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -38,8 +39,6 @@ This is an alias for 'guix package -i'.\n"))
(newline)
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 979d4f8363..18cd167537 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -9,7 +9,7 @@
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
-;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2019, 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -98,6 +98,12 @@ run the checkers on all packages.\n"))
(display (G_ "
-c, --checkers=CHECKER1,CHECKER2...
only run the specified checkers"))
+ (display (G_ "
+ -x, --exclude=CHECKER1,CHECKER2...
+ exclude the specified checkers"))
+ (display (G_ "
+ -n, --no-network only run checkers that do not access the network"))
+
(display (G_ "
-L, --load-path=DIR prepend DIR to the package module search path"))
(newline)
@@ -110,32 +116,37 @@ run the checkers on all packages.\n"))
(newline)
(show-bug-report-information))
+(define (option-checker short-long)
+ ;; Factorize the creation of the two options -c/--checkers and -x/--exclude,
+ ;; see %options. The parameter SHORT-LONG is the list containing the short
+ ;; and long name. The alist uses the long name as symbol.
+ (option short-long #t #f
+ (lambda (opt name arg result)
+ (let ((names (map string->symbol (string-split arg #\,)))
+ (checker-names (map lint-checker-name %all-checkers))
+ (option-name (string->symbol (match short-long
+ ((short long) long)))))
+ (for-each (lambda (c)
+ (unless (memq c checker-names)
+ (leave (G_ "~a: invalid checker~%") c)))
+ names)
+ (alist-cons option-name
+ (filter (lambda (checker)
+ (member (lint-checker-name checker)
+ names))
+ %all-checkers)
+ result)))))
(define %options
;; Specification of the command-line options.
;; TODO: add some options:
;; * --certainty=[low,medium,high]: only run checkers that have at least this
;; 'certainty'.
- (list (option '(#\c "checkers") #t #f
- (lambda (opt name arg result)
- (let ((names (map string->symbol (string-split arg #\,)))
- (checker-names (map lint-checker-name %all-checkers)))
- (for-each (lambda (c)
- (unless (memq c checker-names)
- (leave (G_ "~a: invalid checker~%") c)))
- names)
- (alist-cons 'checkers
- (filter (lambda (checker)
- (member (lint-checker-name checker)
- names))
- %all-checkers)
- result))))
+ (list (option-checker '(#\c "checkers"))
+ (option-checker '(#\x "exclude"))
(option '(#\n "no-network") #f #f
(lambda (opt name arg result)
- (alist-cons 'checkers
- %local-checkers
- (alist-delete 'checkers
- result))))
+ (alist-cons 'no-network? #t result)))
(find (lambda (option)
(member "load-path" (option-names option)))
%standard-build-options)
@@ -172,7 +183,16 @@ run the checkers on all packages.\n"))
value)
(_ #f))
(reverse opts)))
- (checkers (or (assoc-ref opts 'checkers) %all-checkers)))
+ (no-checkers (or (assoc-ref opts 'exclude) '()))
+ (the-checkers (filter (lambda (checker)
+ (not (member checker no-checkers)))
+ (or (assoc-ref opts 'checkers) %all-checkers)))
+ (checkers
+ (if (assoc-ref opts 'no-network?)
+ (filter (lambda (checker)
+ (member checker %local-checkers))
+ the-checkers)
+ the-checkers)))
(when (assoc-ref opts 'list?)
(list-checkers-and-exit checkers))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index a5fe98b675..6366556647 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -53,7 +53,22 @@
#:use-module (ice-9 format)
#:use-module (ice-9 binary-ports)
#:export (build-machine
+ build-machine?
+ build-machine-name
+ build-machine-port
+ build-machine-systems
+ build-machine-user
+ build-machine-private-key
+ build-machine-host-key
+ build-machine-compression
+ build-machine-daemon-socket
+ build-machine-overload-threshold
+ build-machine-systems
+ build-machine-features
+
build-requirements
+ build-requirements?
+
guix-offload))
;;; Commentary:
@@ -182,8 +197,10 @@ can interpret meaningfully."
private key from '~a': ~a")
file str)))))
-(define* (open-ssh-session machine #:optional (max-silent-time -1))
- "Open an SSH session for MACHINE and return it. Throw an error on failure."
+(define* (open-ssh-session machine #:optional max-silent-time)
+ "Open an SSH session for MACHINE and return it. Throw an error on failure.
+When MAX-SILENT-TIME is true, it must be a positive integer denoting the
+number of seconds after which the connection times out."
(let ((private (private-key-from-file* (build-machine-private-key machine)))
(public (public-key-from-file
(string-append (build-machine-private-key machine)
@@ -220,9 +237,10 @@ private key from '~a': ~a")
(leave (G_ "SSH public key authentication failed for '~a': ~a~%")
(build-machine-name machine) (get-error session))))
- ;; From then on use MAX-SILENT-TIME as the absolute timeout when
- ;; reading from or write to a channel for this session.
- (session-set! session 'timeout max-silent-time)
+ (when max-silent-time
+ ;; From then on use MAX-SILENT-TIME as the absolute timeout when
+ ;; reading from or write to a channel for this session.
+ (session-set! session 'timeout max-silent-time))
session)
(x
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0b66da01f9..06509ace2d 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -42,6 +43,7 @@
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
@@ -135,9 +137,11 @@ dependencies are registered."
(define build
(with-extensions gcrypt-sqlite3&co
- (with-imported-modules (source-module-closure
- '((guix build store-copy)
- (guix store database)))
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ '((guix build store-copy)
+ (guix store database))
+ #:select? not-config?))
#~(begin
(use-modules (guix store database)
(guix build store-copy)
@@ -748,12 +752,13 @@ last resort for relocation."
(guix elf)))
#~(begin
(use-modules (guix build utils)
- ((guix build union) #:select (relative-file-name))
+ ((guix build union) #:select (symlink-relative))
(guix elf)
(guix build gremlin)
(ice-9 binary-ports)
(ice-9 ftw)
(ice-9 match)
+ (ice-9 receive)
(srfi srfi-1)
(rnrs bytevectors))
@@ -847,7 +852,7 @@ last resort for relocation."
(("@STORE_DIRECTORY@") (%store-directory)))
(let* ((base (strip-store-prefix program))
- (result (string-append target "/" base))
+ (result (string-append target base))
(proot #$(and proot?
#~(string-drop
#$(file-append (proot) "/bin/proot")
@@ -856,6 +861,9 @@ last resort for relocation."
(mkdir-p (dirname result))
(apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
"run.c" "-o" result
+ (string-append "-DWRAPPER_PROGRAM=\""
+ (canonicalize-path (dirname result)) "/"
+ (basename result) "\"")
(append (if proot
(list (string-append "-DPROOT_PROGRAM=\""
proot "\""))
@@ -870,16 +878,27 @@ last resort for relocation."
(mkdir target)
(for-each (lambda (file)
(unless (member file '("." ".." "bin" "sbin" "libexec"))
- (let ((file* (string-append input "/" file)))
- (symlink (relative-file-name target file*)
- (string-append target "/" file)))))
+ (symlink-relative (string-append input "/" file)
+ (string-append target "/" file))))
(scandir input))
- (for-each build-wrapper
- ;; Note: Trailing slash in case these are symlinks.
- (append (find-files (string-append input "/bin/"))
- (find-files (string-append input "/sbin/"))
- (find-files (string-append input "/libexec/")))))))
+ (receive (executables others)
+ (partition executable-file?
+ ;; Note: Trailing slash in case these are symlinks.
+ (append (find-files (string-append input "/bin/"))
+ (find-files (string-append input "/sbin/"))
+ (find-files (string-append input "/libexec/"))))
+ ;; Wrap only executables, since the wrapper will eventually need
+ ;; to execve them. E.g. git's "libexec" directory contains many
+ ;; shell scripts that are source'd from elsewhere, which fails if
+ ;; they are wrapped.
+ (for-each build-wrapper executables)
+ ;; Link any other non-executable files
+ (for-each (lambda (old)
+ (let ((new (string-append target (strip-store-prefix old))))
+ (mkdir-p (dirname new))
+ (symlink-relative old new)))
+ others)))))
(computed-file (string-append
(cond ((package? package)
@@ -1043,8 +1062,6 @@ last resort for relocation."
Create a bundle of PACKAGE.\n"))
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-f, --format=FORMAT build a pack in the given FORMAT"))
(display (G_ "
@@ -1118,9 +1135,9 @@ Create a bundle of PACKAGE.\n"))
(let* ((transform (options->transformation opts))
(packages (map (match-lambda
(((? package? package) output)
- (list (transform store package) output))
+ (list (transform package) output))
((? package? package)
- (list (transform store package) "out")))
+ (list (transform package) "out")))
(reverse
(filter-map maybe-package-argument opts))))
(manifests (filter-map (match-lambda
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 2f04652634..eb2e67a0de 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -41,6 +41,7 @@
#:use-module (guix config)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix describe)
#:autoload (guix store roots) (gc-roots user-owned?)
#:use-module ((guix build utils)
@@ -223,7 +224,7 @@ non-zero relevance score."
(($ <manifest-entry> name version output (? string? path))
(match (find-best-packages-by-name name #f)
((pkg . rest)
- (let* ((pkg (transform store pkg))
+ (let* ((pkg (transform pkg))
(candidate-version (package-version pkg)))
(match (package-superseded pkg)
((? package? new)
@@ -397,8 +398,6 @@ Install, remove, or upgrade packages in a single transaction.\n"))
(newline)
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
@@ -873,7 +872,7 @@ processed, #f otherwise."
(define transform (options->transformation opts))
(define (transform-entry entry)
- (let ((item (transform store (manifest-entry-item entry))))
+ (let ((item (transform (manifest-entry-item entry))))
(manifest-entry-with-transformations
(manifest-entry
(inherit entry)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 4eaf961ab2..e8faf379e2 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -82,6 +83,9 @@ Publish ~a over HTTP.\n") %store-directory)
(display (G_ "
-c, --cache=DIRECTORY cache published items to DIRECTORY"))
(display (G_ "
+ --cache-bypass-threshold=SIZE
+ serve store items below SIZE even when not cached"))
+ (display (G_ "
--workers=N use N workers to bake items"))
(display (G_ "
--ttl=TTL announce narinfos can be cached for TTL seconds"))
@@ -134,6 +138,12 @@ if ITEM is already compressed."
(list %no-compression)
requested))
+(define (low-compression c)
+ "Return <compression> of the same type as C, but optimized for low CPU
+usage."
+ (compression (compression-type c)
+ (min (compression-level c) 2)))
+
(define %options
(list (option '(#\h "help") #f #f
(lambda _
@@ -184,6 +194,10 @@ if ITEM is already compressed."
(option '(#\c "cache") #t #f
(lambda (opt name arg result)
(alist-cons 'cache arg result)))
+ (option '("cache-bypass-threshold") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cache-bypass-threshold (size->number arg)
+ result)))
(option '("workers") #t #f
(lambda (opt name arg result)
(alist-cons 'workers (string->number* arg)
@@ -434,7 +448,7 @@ items. Failing that, we could eventually have to recompute them and return
(expiration-time file))))))
(define (hash-part->path* store hash cache)
- "Like 'hash-part->path' but cached results under CACHE. This ensures we can
+ "Like 'hash-part->path' but cache results under CACHE. This ensures we can
still map HASH to the corresponding store file name, even if said store item
vanished from the store in the meantime."
(let ((cached (hash-part-mapping-cache-file cache hash)))
@@ -454,6 +468,18 @@ vanished from the store in the meantime."
result))
(apply throw args))))))
+(define cache-bypass-threshold
+ ;; Maximum size of a store item that may be served by the '/cached' handlers
+ ;; below even when not in cache.
+ (make-parameter (* 10 (expt 2 20))))
+
+(define (bypass-cache? store item)
+ "Return true if we allow ITEM to be downloaded before it is cached. ITEM is
+interpreted as the basename of a store item."
+ (guard (c ((store-error? c) #f))
+ (< (path-info-nar-size (query-path-info store item))
+ (cache-bypass-threshold))))
+
(define* (render-narinfo/cached store request hash
#:key ttl (compressions (list %no-compression))
(nar-path "nar")
@@ -513,9 +539,20 @@ requested using POOL."
(nar-expiration-time ttl)
#:delete-entry delete-entry
#:cleanup-period ttl))))
- (not-found request
- #:phrase "We're baking it"
- #:ttl 300)) ;should be available within 5m
+
+ ;; If ITEM passes 'bypass-cache?', render a temporary narinfo right
+ ;; away, with a short TTL. The narinfo is temporary because it
+ ;; lacks 'FileSize', for instance, which the cached narinfo will
+ ;; have. Chances are that the nar will be baked by the time the
+ ;; client asks for it.
+ (if (bypass-cache? store item)
+ (render-narinfo store request hash
+ #:ttl 300 ;temporary
+ #:nar-path nar-path
+ #:compressions compressions)
+ (not-found request
+ #:phrase "We're baking it"
+ #:ttl 300))) ;should be available within 5m
(else
(not-found request #:phrase "")))))
@@ -627,19 +664,32 @@ return it; otherwise, return 404. When TTL is true, use it as the
'Cache-Control' expiration time."
(let ((cached (nar-cache-file cache store-item
#:compression compression)))
- (if (file-exists? cached)
- (values `((content-type . (application/octet-stream
- (charset . "ISO-8859-1")))
- ,@(if ttl
- `((cache-control (max-age . ,ttl)))
- '())
-
- ;; XXX: We're not returning the actual contents, deferring
- ;; instead to 'http-write'. This is a hack to work around
- ;; <http://bugs.gnu.org/21093>.
- (x-raw-file . ,cached))
- #f)
- (not-found request))))
+ (cond ((file-exists? cached)
+ (values `((content-type . (application/octet-stream
+ (charset . "ISO-8859-1")))
+ ,@(if ttl
+ `((cache-control (max-age . ,ttl)))
+ '())
+
+ ;; XXX: We're not returning the actual contents, deferring
+ ;; instead to 'http-write'. This is a hack to work around
+ ;; <http://bugs.gnu.org/21093>.
+ (x-raw-file . ,cached))
+ #f))
+ ((let* ((hash (and=> (string-index store-item #\-)
+ (cut string-take store-item <>)))
+ (item (and hash
+ (guard (c ((store-error? c) #f))
+ (hash-part->path store hash)))))
+ (and item (not (string-null? item))
+ (bypass-cache? store item)))
+ ;; Render STORE-ITEM live. We reach this because STORE-ITEM is
+ ;; being baked but clients are already asking for it. Thus, we're
+ ;; duplicating work, but doing so allows us to reduce delays.
+ (render-nar store request store-item
+ #:compression (low-compression compression)))
+ (else
+ (not-found request)))))
(define (render-content-addressed-file store request
name algo hash)
@@ -686,6 +736,13 @@ to compress or decompress the log file; just return it as-is."
(values (response-headers log) log)
(not-found request))))
+(define (render-signing-key)
+ "Render signing key."
+ (let ((file %public-key-file))
+ (values `((content-type . (text/plain (charset . "UTF-8")))
+ (x-raw-file . ,file))
+ file)))
+
(define (render-home-page request)
"Render the home page."
(values `((content-type . (text/html (charset . "UTF-8"))))
@@ -699,7 +756,12 @@ to compress or decompress the log file; just return it as-is."
(a (@ (href
"https://guix.gnu.org/manual/en/html_node/Invoking-guix-publish.html"))
(tt "guix publish"))
- " speaking. Welcome!")))
+ " speaking. Welcome!")
+ (p "Here is the "
+ (a (@ (href
+ "signing-key.pub"))
+ (tt "signing key"))
+ " for this server. Knock yourselves out!")))
port)))))
(define (extract-narinfo-hash str)
@@ -918,6 +980,9 @@ methods, return the applicable compression."
;; /
((or () ("index.html"))
(render-home-page request))
+ ;; guix signing-key
+ (("signing-key.pub")
+ (render-signing-key))
;; /<hash>.narinfo
(((= extract-narinfo-hash (? string? hash)))
(if cache
@@ -1061,7 +1126,10 @@ methods, return the applicable compression."
consider using the '--user' option!~%")))
(parameterize ((%public-key public-key)
- (%private-key private-key))
+ (%private-key private-key)
+ (cache-bypass-threshold
+ (or (assoc-ref opts 'cache-bypass-threshold)
+ (cache-bypass-threshold))))
(info (G_ "publishing ~a on ~a, port ~d~%")
%store-directory
(inet-ntop (sockaddr:fam address) (sockaddr:addr address))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 7ec170b08a..ddb885d344 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -656,7 +656,7 @@ print a warning and return #f."
(get-bytevector-n port len)
(read-to-eof port))
(cache-narinfo! url (hash-part->path hash-part) #f
- (if (= 404 code)
+ (if (or (= 404 code) (= 202 code))
ttl
%narinfo-transient-error-ttl))
result))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9ed5c26483..ad998156c2 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -385,6 +385,8 @@ STORE is an open connection to the store."
(params (first (profile-boot-parameters %system-profile
(list number))))
(locale (boot-parameters-locale params))
+ (store-directory-prefix
+ (boot-parameters-store-directory-prefix params))
(old-generations
(delv number (reverse (generation-numbers %system-profile))))
(old-params (profile-boot-parameters
@@ -398,6 +400,7 @@ STORE is an open connection to the store."
((bootloader-configuration-file-generator bootloader)
bootloader-config entries
#:locale locale
+ #:store-directory-prefix store-directory-prefix
#:old-entries old-entries)))
(drvs -> (list bootcfg)))
(mbegin %store-monad
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index d89caf80fc..5581e12892 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -204,7 +204,8 @@ services as defined by OS."
;;; Bootloader configuration.
;;;
-(define (install-bootloader-program installer bootloader-package bootcfg
+(define (install-bootloader-program installer disk-installer
+ bootloader-package bootcfg
bootcfg-file device target)
"Return an executable store item that, upon being evaluated, will install
BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
@@ -246,10 +247,17 @@ BOOTLOADER-PACKAGE."
;; a broken installation.
(switch-symlinks new-gc-root #$bootcfg)
(install-boot-config #$bootcfg #$bootcfg-file #$target)
- (when #$installer
+ (when (or #$installer #$disk-installer)
(catch #t
(lambda ()
- (#$installer #$bootloader-package #$device #$target))
+ ;; The bootloader might not support installation on a
+ ;; mounted directory using the BOOTLOADER-INSTALLER
+ ;; procedure. In that case, fallback to installing the
+ ;; bootloader directly on DEVICE using the
+ ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure.
+ (if #$installer
+ (#$installer #$bootloader-package #$device #$target)
+ (#$disk-installer #$bootloader-package 0 #$device)))
(lambda args
(delete-file new-gc-root)
(match args
@@ -272,11 +280,14 @@ additional configurations specified by MENU-ENTRIES can be selected."
(let* ((bootloader (bootloader-configuration-bootloader configuration))
(installer (and run-installer?
(bootloader-installer bootloader)))
+ (disk-installer (and run-installer?
+ (bootloader-disk-image-installer bootloader)))
(package (bootloader-package bootloader))
(device (bootloader-configuration-target configuration))
(bootcfg-file (bootloader-configuration-file bootloader)))
(eval #~(parameterize ((current-warning-port (%make-void-port "w")))
(primitive-load #$(install-bootloader-program installer
+ disk-installer
package
bootcfg
bootcfg-file
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index 5ec844328e..1ee8937acf 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -21,6 +21,7 @@
#:use-module (guix ui)
#:use-module (guix scripts package)
#:use-module (guix scripts build)
+ #:use-module (guix transformations)
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -41,8 +42,6 @@ This is an alias for 'guix package -u'.\n"))
(newline)
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
diff --git a/guix/tests.scm b/guix/tests.scm
index 3ccf049a7d..fc3d521163 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -160,15 +160,17 @@ too expensive to build entirely in the test store."
number->string)
(logxor (getpid) (car (gettimeofday)))))
-(define %seed
+(define (%seed)
(let ((seed (random-seed)))
(format (current-error-port) "random seed for tests: ~a~%"
seed)
- (seed->random-state seed)))
+ (let ((result (seed->random-state seed)))
+ (set! %seed (lambda () result))
+ result)))
(define (random-text)
"Return the hexadecimal representation of a random number."
- (number->string (random (expt 2 256) %seed) 16))
+ (number->string (random (expt 2 256) (%seed)) 16))
(define (random-bytevector n)
"Return a random bytevector of N bytes."
@@ -176,7 +178,7 @@ too expensive to build entirely in the test store."
(let loop ((i 0))
(if (< i n)
(begin
- (bytevector-u8-set! bv i (random 256 %seed))
+ (bytevector-u8-set! bv i (random 256 (%seed)))
(loop (1+ i)))
bv))))
diff --git a/guix/transformations.scm b/guix/transformations.scm
new file mode 100644
index 0000000000..30142dd059
--- /dev/null
+++ b/guix/transformations.scm
@@ -0,0 +1,620 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix transformations)
+ #:use-module (guix i18n)
+ #:use-module (guix store)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix diagnostics)
+ #:autoload (guix download) (download-to-store)
+ #:autoload (guix git-download) (git-reference? git-reference-url)
+ #:autoload (guix git) (git-checkout git-checkout? git-checkout-url)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix gexp)
+
+ ;; Use the procedure that destructures "NAME-VERSION" forms.
+ #:use-module ((guix build utils)
+ #:select ((package-name->name+version
+ . hyphen-package-name->name+version)))
+
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:export (options->transformation
+ manifest-entry-with-transformations
+
+ show-transformation-options-help
+ %transformation-options))
+
+;;; Commentary:
+;;;
+;;; This module implements "package transformation options"---tools for
+;;; package graph rewriting. It contains the graph rewriting logic, but also
+;;; the tip of its user interface: command-line option handling.
+;;;
+;;; Code:
+
+(module-autoload! (current-module) '(gnu packages)
+ '(specification->package))
+
+(define (numeric-extension? file-name)
+ "Return true if FILE-NAME ends with digits."
+ (string-every char-set:hex-digit (file-extension file-name)))
+
+(define (tarball-base-name file-name)
+ "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
+extensions."
+ ;; TODO: Factorize.
+ (cond ((not (file-extension file-name))
+ file-name)
+ ((numeric-extension? file-name)
+ file-name)
+ ((string=? (file-extension file-name) "tar")
+ (file-sans-extension file-name))
+ ((file-extension file-name)
+ =>
+ (match-lambda
+ ("scm" file-name)
+ (_ (tarball-base-name (file-sans-extension file-name)))))
+ (else
+ file-name)))
+
+
+;; Files to be downloaded.
+(define-record-type <downloaded-file>
+ (downloaded-file uri recursive?)
+ downloaded-file?
+ (uri downloaded-file-uri)
+ (recursive? downloaded-file-recursive?))
+
+(define download-to-store*
+ (store-lift download-to-store))
+
+(define-gexp-compiler (compile-downloaded-file (file <downloaded-file>)
+ system target)
+ "Download FILE and return the result as a store item."
+ (match file
+ (($ <downloaded-file> uri recursive?)
+ (download-to-store* uri #:recursive? recursive?))))
+
+(define* (package-with-source p uri #:optional version)
+ "Return a package based on P but with its source taken from URI. Extract
+the new package's version number from URI."
+ (let ((base (tarball-base-name (basename uri))))
+ (let-values (((_ version*)
+ (hyphen-package-name->name+version base)))
+ (package (inherit p)
+ (version (or version version*
+ (package-version p)))
+
+ ;; Use #:recursive? #t to allow for directories.
+ (source (downloaded-file uri #t))))))
+
+
+;;;
+;;; Transformations.
+;;;
+
+(define (transform-package-source sources)
+ "Return a transformation procedure that replaces package sources with the
+matching URIs given in SOURCES."
+ (define new-sources
+ (map (lambda (uri)
+ (match (string-index uri #\=)
+ (#f
+ ;; Determine the package name and version from URI.
+ (call-with-values
+ (lambda ()
+ (hyphen-package-name->name+version
+ (tarball-base-name (basename uri))))
+ (lambda (name version)
+ (list name version uri))))
+ (index
+ ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
+ (call-with-values
+ (lambda ()
+ (package-name->name+version (string-take uri index)))
+ (lambda (name version)
+ (list name version
+ (string-drop uri (+ 1 index))))))))
+ sources))
+
+ (lambda (obj)
+ (let loop ((sources new-sources)
+ (result '()))
+ (match obj
+ ((? package? p)
+ (match (assoc-ref sources (package-name p))
+ ((version source)
+ (package-with-source p source version))
+ (#f
+ p)))
+ (_
+ obj)))))
+
+(define (evaluate-replacement-specs specs proc)
+ "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
+of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
+PROC is called with the package to be replaced and its replacement according
+to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a
+package it refers to could not be found."
+ (define not-equal
+ (char-set-complement (char-set #\=)))
+
+ (map (lambda (spec)
+ (match (string-tokenize spec not-equal)
+ ((spec new)
+ (cons spec
+ (let ((new (specification->package new)))
+ (lambda (old)
+ (proc old new)))))
+ (x
+ (raise (formatted-message
+ (G_ "invalid replacement specification: ~s")
+ spec)))))
+ specs))
+
+(define (transform-package-inputs replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"guile=guile@2.1\" meaning that, any dependency on a package
+called \"guile\" must be replaced with a dependency on a version 2.1 of
+\"guile\"."
+ (let* ((replacements (evaluate-replacement-specs replacement-specs
+ (lambda (old new)
+ new)))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define (transform-package-inputs/graft replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
+current 'gnutls' package, after which version 3.5.4 is grafted onto them."
+ (define (set-replacement old new)
+ (package (inherit old) (replacement new)))
+
+ (let* ((replacements (evaluate-replacement-specs replacement-specs
+ set-replacement))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define %not-equal
+ (char-set-complement (char-set #\=)))
+
+(define (package-git-url package)
+ "Return the URL of the Git repository for package, or raise an error if
+the source of PACKAGE is not fetched from a Git repository."
+ (let ((source (package-source package)))
+ (cond ((and (origin? source)
+ (git-reference? (origin-uri source)))
+ (git-reference-url (origin-uri source)))
+ ((git-checkout? source)
+ (git-checkout-url source))
+ (else
+ (raise
+ (formatted-message (G_ "the source of ~a is not a Git reference")
+ (package-full-name package)))))))
+
+(define (evaluate-git-replacement-specs specs proc)
+ "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
+of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
+replacement package. Raise an error if an element of SPECS uses invalid
+syntax, or if a package it refers to could not be found."
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec branch-or-commit)
+ (define (replace old)
+ (let* ((source (package-source old))
+ (url (package-git-url old)))
+ (proc old url branch-or-commit)))
+
+ (cons spec replace))
+ (_
+ (raise
+ (formatted-message (G_ "invalid replacement specification: ~s")
+ spec)))))
+ specs))
+
+(define (transform-package-source-branch replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"guile-next=stable-3.0\" meaning that packages are built using
+'guile-next' from the latest commit on its 'stable-3.0' branch."
+ (define (replace old url branch)
+ (package
+ (inherit old)
+ (version (string-append "git." (string-map (match-lambda
+ (#\/ #\-)
+ (chr chr))
+ branch)))
+ (source (git-checkout (url url) (branch branch)
+ (recursive? #t)))))
+
+ (let* ((replacements (evaluate-git-replacement-specs replacement-specs
+ replace))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define (transform-package-source-commit replacement-specs)
+ "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of
+strings like \"guile-next=cabba9e\" meaning that packages are built using
+'guile-next' from commit 'cabba9e'."
+ (define (replace old url commit)
+ (package
+ (inherit old)
+ (version (if (and (> (string-length commit) 1)
+ (string-prefix? "v" commit)
+ (char-set-contains? char-set:digit
+ (string-ref commit 1)))
+ (string-drop commit 1) ;looks like a tag like "v1.0"
+ (string-append "git."
+ (if (< (string-length commit) 7)
+ commit
+ (string-take commit 7)))))
+ (source (git-checkout (url url) (commit commit)
+ (recursive? #t)))))
+
+ (let* ((replacements (evaluate-git-replacement-specs replacement-specs
+ replace))
+ (rewrite (package-input-rewriting/spec replacements)))
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj))))
+
+(define (transform-package-source-git-url replacement-specs)
+ "Return a procedure that, when passed a package, replaces its dependencies
+according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like
+\"guile-json=https://gitthing.com/…\" meaning that packages are built using
+a checkout of the Git repository at the given URL."
+ (define replacements
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec url)
+ (cons spec
+ (lambda (old)
+ (package
+ (inherit old)
+ (source (git-checkout (url url)
+ (recursive? #t)))))))
+ (_
+ (raise
+ (formatted-message
+ (G_ "~a: invalid Git URL replacement specification")
+ spec)))))
+ replacement-specs))
+
+ (define rewrite
+ (package-input-rewriting/spec replacements))
+
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
+(define (package-dependents/spec top bottom)
+ "Return the list of dependents of BOTTOM, a spec string, that are also
+dependencies of TOP, a package."
+ (define-values (name version)
+ (package-name->name+version bottom))
+
+ (define dependent?
+ (mlambda (p)
+ (and (package? p)
+ (or (and (string=? name (package-name p))
+ (or (not version)
+ (version-prefix? version (package-version p))))
+ (match (bag-direct-inputs (package->bag p))
+ (((labels dependencies . _) ...)
+ (any dependent? dependencies)))))))
+
+ (filter dependent? (package-closure (list top))))
+
+(define (package-toolchain-rewriting p bottom toolchain)
+ "Return a procedure that, when passed a package that's either BOTTOM or one
+of its dependents up to P so, changes it so it is built with TOOLCHAIN.
+TOOLCHAIN must be an input list."
+ (define rewriting-property
+ (gensym " package-toolchain-rewriting"))
+
+ (match (package-dependents/spec p bottom)
+ (() ;P does not depend on BOTTOM
+ identity)
+ (set
+ ;; SET is the list of packages "between" P and BOTTOM (included) whose
+ ;; toolchain needs to be changed.
+ (package-mapping (lambda (p)
+ (if (or (assq rewriting-property
+ (package-properties p))
+ (not (memq p set)))
+ p
+ (let ((p (package-with-c-toolchain p toolchain)))
+ (package/inherit p
+ (properties `((,rewriting-property . #t)
+ ,@(package-properties p)))))))
+ (lambda (p)
+ (or (assq rewriting-property (package-properties p))
+ (not (memq p set))))
+ #:deep? #t))))
+
+(define (transform-package-toolchain replacement-specs)
+ "Return a procedure that, when passed a package, changes its toolchain or
+that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is
+a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
+the left of the equal sign must be built with the toolchain to the right of
+the equal sign."
+ (define split-on-commas
+ (cute string-tokenize <> (char-set-complement (char-set #\,))))
+
+ (define (specification->input spec)
+ (let ((package (specification->package spec)))
+ (list (package-name package) package)))
+
+ (define replacements
+ (map (lambda (spec)
+ (match (string-tokenize spec %not-equal)
+ ((spec (= split-on-commas toolchain))
+ (cons spec (map specification->input toolchain)))
+ (_
+ (raise
+ (formatted-message
+ (G_ "~a: invalid toolchain replacement specification")
+ spec)))))
+ replacement-specs))
+
+ (lambda (obj)
+ (if (package? obj)
+ (or (any (match-lambda
+ ((bottom . toolchain)
+ ((package-toolchain-rewriting obj bottom toolchain) obj)))
+ replacements)
+ obj)
+ obj)))
+
+(define (transform-package-with-debug-info specs)
+ "Return a procedure that, when passed a package, set its 'replacement' field
+to the same package but with #:strip-binaries? #f in its 'arguments' field."
+ (define (non-stripped p)
+ (package
+ (inherit p)
+ (arguments
+ (substitute-keyword-arguments (package-arguments p)
+ ((#:strip-binaries? _ #f) #f)))))
+
+ (define (package-with-debug-info p)
+ (if (member "debug" (package-outputs p))
+ p
+ (let loop ((p p))
+ (match (package-replacement p)
+ (#f
+ (package
+ (inherit p)
+ (replacement (non-stripped p))))
+ (next
+ (package
+ (inherit p)
+ (replacement (loop next))))))))
+
+ (define rewrite
+ (package-input-rewriting/spec (map (lambda (spec)
+ (cons spec package-with-debug-info))
+ specs)))
+
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
+(define (transform-package-tests specs)
+ "Return a procedure that, when passed a package, sets #:tests? #f in its
+'arguments' field."
+ (define (package-without-tests p)
+ (package/inherit p
+ (arguments
+ (substitute-keyword-arguments (package-arguments p)
+ ((#:tests? _ #f) #f)))))
+
+ (define rewrite
+ (package-input-rewriting/spec (map (lambda (spec)
+ (cons spec package-without-tests))
+ specs)))
+
+ (lambda (obj)
+ (if (package? obj)
+ (rewrite obj)
+ obj)))
+
+(define %transformations
+ ;; Transformations that can be applied to things to build. The car is the
+ ;; key used in the option alist, and the cdr is the transformation
+ ;; procedure; it is called with two arguments: the store, and a list of
+ ;; things to build.
+ `((with-source . ,transform-package-source)
+ (with-input . ,transform-package-inputs)
+ (with-graft . ,transform-package-inputs/graft)
+ (with-branch . ,transform-package-source-branch)
+ (with-commit . ,transform-package-source-commit)
+ (with-git-url . ,transform-package-source-git-url)
+ (with-c-toolchain . ,transform-package-toolchain)
+ (with-debug-info . ,transform-package-with-debug-info)
+ (without-tests . ,transform-package-tests)))
+
+(define (transformation-procedure key)
+ "Return the transformation procedure associated with KEY, a symbol such as
+'with-source', or #f if there is none."
+ (any (match-lambda
+ ((k . proc)
+ (and (eq? k key) proc)))
+ %transformations))
+
+
+;;;
+;;; Command-line handling.
+;;;
+
+(define %transformation-options
+ ;; The command-line interface to the above transformations.
+ (let ((parser (lambda (symbol)
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons symbol arg result)
+ rest)))))
+ (list (option '("with-source") #t #f
+ (parser 'with-source))
+ (option '("with-input") #t #f
+ (parser 'with-input))
+ (option '("with-graft") #t #f
+ (parser 'with-graft))
+ (option '("with-branch") #t #f
+ (parser 'with-branch))
+ (option '("with-commit") #t #f
+ (parser 'with-commit))
+ (option '("with-git-url") #t #f
+ (parser 'with-git-url))
+ (option '("with-c-toolchain") #t #f
+ (parser 'with-c-toolchain))
+ (option '("with-debug-info") #t #f
+ (parser 'with-debug-info))
+ (option '("without-tests") #t #f
+ (parser 'without-tests)))))
+
+(define (show-transformation-options-help)
+ (display (G_ "
+ --with-source=[PACKAGE=]SOURCE
+ use SOURCE when building the corresponding package"))
+ (display (G_ "
+ --with-input=PACKAGE=REPLACEMENT
+ replace dependency PACKAGE by REPLACEMENT"))
+ (display (G_ "
+ --with-graft=PACKAGE=REPLACEMENT
+ graft REPLACEMENT on packages that refer to PACKAGE"))
+ (display (G_ "
+ --with-branch=PACKAGE=BRANCH
+ build PACKAGE from the latest commit of BRANCH"))
+ (display (G_ "
+ --with-commit=PACKAGE=COMMIT
+ build PACKAGE from COMMIT"))
+ (display (G_ "
+ --with-git-url=PACKAGE=URL
+ build PACKAGE from the repository at URL"))
+ (display (G_ "
+ --with-c-toolchain=PACKAGE=TOOLCHAIN
+ build PACKAGE and its dependents with TOOLCHAIN"))
+ (display (G_ "
+ --with-debug-info=PACKAGE
+ build PACKAGE and preserve its debug info"))
+ (display (G_ "
+ --without-tests=PACKAGE
+ build PACKAGE without running its tests")))
+
+
+(define (options->transformation opts)
+ "Return a procedure that, when passed an object to build (package,
+derivation, etc.), applies the transformations specified by OPTS and returns
+the resulting objects. OPTS must be a list of symbol/string pairs such as:
+
+ ((with-branch . \"guile-gcrypt=master\")
+ (without-tests . \"libgcrypt\"))
+
+Each symbol names a transformation and the corresponding string is an argument
+to that transformation."
+ (define applicable
+ ;; List of applicable transformations as symbol/procedure pairs in the
+ ;; order in which they appear on the command line.
+ (filter-map (match-lambda
+ ((key . value)
+ (match (transformation-procedure key)
+ (#f
+ #f)
+ (transform
+ ;; XXX: We used to pass TRANSFORM a list of several
+ ;; arguments, but we now pass only one, assuming that
+ ;; transform composes well.
+ (list key value (transform (list value)))))))
+ (reverse opts)))
+
+ (define (package-with-transformation-properties p)
+ (package/inherit p
+ (properties `((transformations
+ . ,(map (match-lambda
+ ((key value _)
+ (cons key value)))
+ applicable))
+ ,@(package-properties p)))))
+
+ (lambda (obj)
+ (define (tagged-object new)
+ (if (and (not (eq? obj new))
+ (package? new) (not (null? applicable)))
+ (package-with-transformation-properties new)
+ new))
+
+ (tagged-object
+ (fold (match-lambda*
+ (((name value transform) obj)
+ (let ((new (transform obj)))
+ (when (eq? new obj)
+ (warning (G_ "transformation '~a' had no effect on ~a~%")
+ name
+ (if (package? obj)
+ (package-full-name obj)
+ obj)))
+ new)))
+ obj
+ applicable))))
+
+(define (package-transformations package)
+ "Return the transformations applied to PACKAGE according to its properties."
+ (match (assq-ref (package-properties package) 'transformations)
+ (#f '())
+ (transformations transformations)))
+
+(define (manifest-entry-with-transformations entry)
+ "Return ENTRY with an additional 'transformations' property if it's not
+already there."
+ (let ((properties (manifest-entry-properties entry)))
+ (if (assq 'transformations properties)
+ entry
+ (let ((item (manifest-entry-item entry)))
+ (manifest-entry
+ (inherit entry)
+ (properties
+ (match (and (package? item)
+ (package-transformations item))
+ ((or #f '())
+ properties)
+ (transformations
+ `((transformations . ,transformations)
+ ,@properties)))))))))