summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2020-11-29 14:19:55 +0000
committerChristopher Baines <mail@cbaines.net>2020-11-29 17:34:18 +0000
commitff01206345e2306cc633db48e0b29eab9077091a (patch)
tree25c7ee17005dadc9bf4fae3f0873e03a4704f782 /guix
parented2545f0fa0e2ad99d5a0c45f532c539b299b9fb (diff)
parent7c2e67400ffaef8eb6f30ef7126c976ee3d7e36c (diff)
downloadguix-patches-ff01206345e2306cc633db48e0b29eab9077091a.tar
guix-patches-ff01206345e2306cc633db48e0b29eab9077091a.tar.gz
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/ocaml.scm27
-rw-r--r--guix/build/cargo-build-system.scm19
-rw-r--r--guix/build/maven-build-system.scm3
-rw-r--r--guix/channels.scm14
-rw-r--r--guix/cpio.scm33
-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/hg-download.scm38
-rw-r--r--guix/import/crate.scm2
-rw-r--r--guix/import/hackage.scm14
-rw-r--r--guix/import/print.scm11
-rw-r--r--guix/import/stackage.scm25
-rw-r--r--guix/lint.scm97
-rw-r--r--guix/packages.scm63
-rw-r--r--guix/profiles.scm42
-rw-r--r--guix/scripts/archive.scm11
-rw-r--r--guix/scripts/build.scm509
-rw-r--r--guix/scripts/deploy.scm33
-rw-r--r--guix/scripts/environment.scm3
-rw-r--r--guix/scripts/graph.scm13
-rw-r--r--guix/scripts/install.scm1
-rw-r--r--guix/scripts/lint.scm75
-rw-r--r--guix/scripts/offload.scm28
-rw-r--r--guix/scripts/pack.scm54
-rw-r--r--guix/scripts/package.scm5
-rw-r--r--guix/scripts/publish.scm150
-rw-r--r--guix/scripts/pull.scm2
-rw-r--r--guix/scripts/refresh.scm2
-rwxr-xr-xguix/scripts/substitute.scm2
-rw-r--r--guix/scripts/system.scm24
-rw-r--r--guix/scripts/system/reconfigure.scm17
-rw-r--r--guix/scripts/upgrade.scm1
-rw-r--r--guix/scripts/weather.scm36
-rw-r--r--guix/self.scm10
-rw-r--r--guix/store.scm7
-rw-r--r--guix/tests.scm10
-rw-r--r--guix/transformations.scm632
-rw-r--r--guix/ui.scm4
-rw-r--r--guix/utils.scm6
41 files changed, 1448 insertions, 796 deletions
diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm
index c5996bf0cf..5513216c25 100644
--- a/guix/build-system/ocaml.scm
+++ b/guix/build-system/ocaml.scm
@@ -29,6 +29,8 @@
#:export (%ocaml-build-system-modules
package-with-ocaml4.07
strip-ocaml4.07-variant
+ package-with-ocaml4.09
+ strip-ocaml4.09-variant
default-findlib
default-ocaml
lower
@@ -96,6 +98,18 @@
(let ((module (resolve-interface '(gnu packages ocaml))))
(module-ref module 'ocaml4.07-dune)))
+(define (default-ocaml4.09)
+ (let ((ocaml (resolve-interface '(gnu packages ocaml))))
+ (module-ref ocaml 'ocaml-4.09)))
+
+(define (default-ocaml4.09-findlib)
+ (let ((module (resolve-interface '(gnu packages ocaml))))
+ (module-ref module 'ocaml4.09-findlib)))
+
+(define (default-ocaml4.09-dune)
+ (let ((module (resolve-interface '(gnu packages ocaml))))
+ (module-ref module 'ocaml4.09-dune)))
+
(define* (package-with-explicit-ocaml ocaml findlib dune old-prefix new-prefix
#:key variant-property)
"Return a procedure of one argument, P. The procedure creates a package
@@ -171,6 +185,19 @@ pre-defined variants."
(inherit p)
(properties (alist-delete 'ocaml4.07-variant (package-properties p)))))
+(define package-with-ocaml4.09
+ (package-with-explicit-ocaml (delay (default-ocaml4.09))
+ (delay (default-ocaml4.09-findlib))
+ (delay (default-ocaml4.09-dune))
+ "ocaml-" "ocaml4.09-"
+ #:variant-property 'ocaml4.09-variant))
+
+(define (strip-ocaml4.09-variant p)
+ "Remove the 'ocaml4.09-variant' property from P."
+ (package
+ (inherit p)
+ (properties (alist-delete 'ocaml4.09-variant (package-properties p)))))
+
(define* (lower name
#:key source inputs native-inputs outputs system target
(ocaml (default-ocaml))
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 117c8da66c..c7beffc6e4 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -122,6 +123,13 @@ directory = '" port)
(setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
(setenv "LIBGIT2_SYS_USE_PKG_CONFIG" "1")
(setenv "LIBSSH2_SYS_USE_PKG_CONFIG" "1")
+ (when (assoc-ref inputs "openssl")
+ (setenv "OPENSSL_DIR" (assoc-ref inputs "openssl")))
+ (when (assoc-ref inputs "gettext")
+ (setenv "GETTEXT_SYSTEM" (assoc-ref inputs "gettext")))
+ (when (assoc-ref inputs "clang")
+ (setenv "LIBCLANG_PATH"
+ (string-append (assoc-ref inputs "clang") "/lib")))
;; We don't use the Cargo.lock file to determine the package versions we use
;; during building, and in any case if one is not present it is created
@@ -141,14 +149,17 @@ directory = '" port)
(define* (build #:key
skip-build?
- features
+ (features '())
(cargo-build-flags '("--release"))
#:allow-other-keys)
"Build a given Cargo package."
(or skip-build?
- (apply invoke "cargo" "build"
- "--features" (string-join features)
- cargo-build-flags)))
+ (apply invoke
+ `("cargo" "build"
+ ,@(if (null? features)
+ '()
+ `("--features" ,(string-join features)))
+ ,@cargo-build-flags))))
(define* (check #:key
tests?
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/channels.scm b/guix/channels.scm
index 916d663e9f..0c84eed477 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -72,6 +72,7 @@
openpgp-fingerprint->bytevector
openpgp-fingerprint
+ %default-guix-channel
%default-channels
guix-channel?
@@ -170,13 +171,16 @@ to the corresponding bytevector."
;; URL of the default 'guix' channel.
"https://git.savannah.gnu.org/git/guix.git")
+(define %default-guix-channel
+ (channel
+ (name 'guix)
+ (branch "master")
+ (url %default-channel-url)
+ (introduction %guix-channel-introduction)))
+
(define %default-channels
;; Default list of channels.
- (list (channel
- (name 'guix)
- (branch "master")
- (url %default-channel-url)
- (introduction %guix-channel-introduction))))
+ (list %default-guix-channel))
(define (guix-channel? channel)
"Return true if CHANNEL is the 'guix' channel."
diff --git a/guix/cpio.scm b/guix/cpio.scm
index e4692e2e9c..c9932f5bf9 100644
--- a/guix/cpio.scm
+++ b/guix/cpio.scm
@@ -27,6 +27,7 @@
make-cpio-header
file->cpio-header
file->cpio-header*
+ special-file->cpio-header*
write-cpio-header
read-cpio-header
@@ -132,9 +133,10 @@
(%make-cpio-header MAGIC
inode mode uid gid
nlink mtime
- (if (= C_ISDIR (logand mode C_FMT))
- 0
- size)
+ (if (or (= C_ISLNK (logand mode C_FMT))
+ (= C_ISREG (logand mode C_FMT)))
+ size
+ 0)
major minor rmajor rminor
(+ name-size 1) ;include trailing zero
0))) ;checksum
@@ -146,6 +148,8 @@ denotes, similar to 'stat:type'."
(cond ((= C_ISREG fmt) 'regular)
((= C_ISDIR fmt) 'directory)
((= C_ISLNK fmt) 'symlink)
+ ((= C_ISBLK fmt) 'block-special)
+ ((= C_ISCHR fmt) 'char-special)
(else
(error "unsupported file type" mode)))))
@@ -187,6 +191,25 @@ produced in a deterministic fashion."
#:size (stat:size st)
#:name-size (string-length file-name))))
+(define* (special-file->cpio-header* file
+ device-type
+ device-major
+ device-minor
+ permission-bits
+ #:optional (file-name file))
+ "Create a character or block device header.
+
+DEVICE-TYPE is either 'char-special or 'block-special.
+
+The number of hard links is assumed to be 1."
+ (make-cpio-header #:mode (logior (match device-type
+ ('block-special C_ISBLK)
+ ('char-special C_ISCHR))
+ permission-bits)
+ #:nlink 1
+ #:rdev (device-number device-major device-minor)
+ #:name-size (string-length file-name)))
+
(define %trailer
"TRAILER!!!")
@@ -233,6 +256,10 @@ produces with the '-H newc' option."
(put-string port target)))
((directory)
#t)
+ ((block-special)
+ #t)
+ ((char-special)
+ #t)
(else
(error "file type not supported")))
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 b8c831ccc3..5d93afa9c2 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/hg-download.scm b/guix/hg-download.scm
index 694105ceba..bd55946523 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -26,12 +26,14 @@
#:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-packages)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
#:export (hg-reference
hg-reference?
hg-reference-url
hg-reference-changeset
hg-reference-recursive?
-
+ hg-predicate
hg-fetch))
;;; Commentary:
@@ -93,4 +95,38 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#:recursive? #t
#:guile-for-build guile)))
+(define (hg-file-list directory)
+ "Evaluates to a list of files contained in the repository at path
+ @var{directory}"
+ (let* ((port (open-input-pipe (format #f "hg files --repository ~s" directory)))
+ (files (let loop ((files '()))
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line) files)
+ (else
+ (loop (cons line files))))))))
+ (close-pipe port)
+ (map canonicalize-path files)))
+
+(define (should-select? path-list candidate)
+ "Returns #t in case that @var{candidate} is a file that is part of the given
+@var{path-list}."
+ (let ((canon-candidate (canonicalize-path candidate)))
+ (let loop ((xs path-list))
+ (cond
+ ((null? xs)
+ ;; Directories are not part of `hg files', but `local-file' will not
+ ;; recurse if we don't return #t for directories.
+ (equal? (array-ref (lstat candidate) 13) 'directory))
+ ((string-contains candidate (car xs)) #t)
+ (else (loop (cdr xs)))))))
+
+(define (hg-predicate directory)
+ "This procedure evaluates to a predicate that reports back whether a given
+@var{file} - @var{stat} combination is part of the files tracked by
+Mercurial."
+ (let ((files (hg-file-list directory)))
+ (lambda (file stat)
+ (should-select? files file))))
+
;;; hg-download.scm ends here
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/hackage.scm b/guix/import/hackage.scm
index 35c67cad8d..6ca4f65cb0 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -40,7 +40,8 @@
#:use-module (guix upstream)
#:use-module (guix packages)
#:use-module ((guix utils) #:select (call-with-temporary-output-file))
- #:export (hackage->guix-package
+ #:export (%hackage-url
+ hackage->guix-package
hackage-recursive-import
%hackage-updater
@@ -92,20 +93,23 @@
(define package-name-prefix "ghc-")
+(define %hackage-url
+ (make-parameter "https://hackage.haskell.org"))
+
(define (hackage-source-url name version)
"Given a Hackage package NAME and VERSION, return a url to the source
tarball."
- (string-append "https://hackage.haskell.org/package/" name
- "/" name "-" version ".tar.gz"))
+ (string-append (%hackage-url) "/package/"
+ name "/" name "-" version ".tar.gz"))
(define* (hackage-cabal-url name #:optional version)
"Given a Hackage package NAME and VERSION, return a url to the corresponding
.cabal file on Hackage. If VERSION is #f or missing, the url for the latest
version is returned."
(if version
- (string-append "https://hackage.haskell.org/package/"
+ (string-append (%hackage-url) "/package/"
name "-" version "/" name ".cabal")
- (string-append "https://hackage.haskell.org/package/"
+ (string-append (%hackage-url) "/package/"
name "/" name ".cabal")))
(define (hackage-name->package-name name)
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..77cc6350cb 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -30,7 +30,8 @@
#:use-module (guix memoization)
#:use-module (guix packages)
#:use-module (guix upstream)
- #:export (stackage->guix-package
+ #:export (%stackage-url
+ stackage->guix-package
stackage-recursive-import
%stackage-updater))
@@ -39,12 +40,11 @@
;;; Stackage info fetcher and access functions
;;;
-(define %stackage-url "http://www.stackage.org")
+(define %stackage-url
+ (make-parameter "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 +57,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 +91,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 +120,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/lint.scm b/guix/lint.scm
index e1a77e8ac7..be6bb4eb01 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -10,6 +10,7 @@
;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -35,6 +36,8 @@
#:use-module (guix http-client)
#:use-module (guix packages)
#:use-module (guix i18n)
+ #:use-module ((guix gexp)
+ #:select (local-file? local-file-absolute-file-name))
#:use-module (guix licenses)
#:use-module (guix records)
#:use-module (guix grafts)
@@ -50,6 +53,7 @@
#:use-module ((guix swh) #:hide (origin?))
#:autoload (guix git-download) (git-reference?
git-reference-url git-reference-commit)
+ #:use-module (guix import stackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -73,6 +77,7 @@
check-inputs-should-be-native
check-inputs-should-not-be-an-input-at-all
check-patch-file-names
+ check-patch-headers
check-synopsis-style
check-derivation
check-home-page
@@ -87,6 +92,7 @@
check-formatting
check-archival
check-profile-collisions
+ check-haskell-stackage
lint-warning
lint-warning?
@@ -663,17 +669,11 @@ from ~a")
(define (check-patch-file-names package)
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
- (guard (c ((message-condition? c) ;raised by 'search-patch'
- (list
- ;; Use %make-warning, as condition-mesasge is already
- ;; translated.
- (%make-warning package (condition-message c)
- #:field 'patch-file-names)))
- ((formatted-message? c)
+ (guard (c ((formatted-message? c) ;raised by 'search-patch'
(list (%make-warning package
- (apply format #f
- (G_ (formatted-message-string c))
- (formatted-message-arguments c))))))
+ (formatted-message-string c)
+ (formatted-message-arguments c)
+ #:field 'source))))
(define patches
(match (package-source package)
((? origin? origin) (origin-patches origin))
@@ -718,6 +718,54 @@ patch could not be found."
(_ #f))
patches)))))
+(define (check-patch-headers package)
+ "Check that PACKAGE's patches start with a comment. Return a list of
+warnings."
+ (define (blank? str)
+ (string-every char-set:blank str))
+
+ (define (patch-header-warnings patch)
+ (call-with-input-file patch
+ (lambda (port)
+ ;; Read from PORT until a non-blank line is found or EOF is reached.
+ (let loop ()
+ (let ((line (read-line port)))
+ (cond ((eof-object? line)
+ (list (make-warning package
+ (G_ "~a: empty patch")
+ (list (basename patch))
+ #:field 'source)))
+ ((blank? line)
+ (loop))
+ ((or (string-prefix? "--- " line)
+ (string-prefix? "+++ " line))
+ (list (make-warning package
+ (G_ "~a: patch lacks comment and \
+upstream status")
+ (list (basename patch))
+ #:field 'source)))
+ (else
+ '())))))))
+
+ (guard (c ((formatted-message? c) ;raised by 'search-patch'
+ (list (%make-warning package
+ (formatted-message-string c)
+ (formatted-message-arguments c)
+ #:field 'source))))
+ (let ((patches (if (origin? (package-source package))
+ (origin-patches (package-source package))
+ '())))
+ (append-map (lambda (patch)
+ ;; Dismiss PATCH if it's an origin or similar.
+ (cond ((string? patch)
+ (patch-header-warnings patch))
+ ((local-file? patch)
+ (patch-header-warnings
+ (local-file-absolute-file-name patch)))
+ (else
+ '())))
+ patches))))
+
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
(list->string
@@ -1240,6 +1288,25 @@ Heritage")
'()
(apply throw key args))))))))
+(define (check-haskell-stackage package)
+ "Check whether PACKAGE is a Haskell package ahead of the current
+Stackage LTS version."
+ (match (with-networking-fail-safe
+ (format #f (G_ "while retrieving upstream info for '~a'")
+ (package-name package))
+ #f
+ (package-latest-release package (list %stackage-updater)))
+ ((? upstream-source? source)
+ (if (version>? (package-version package)
+ (upstream-source-version source))
+ (list
+ (make-warning package
+ (G_ "ahead of Stackage LTS version ~a")
+ (list (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '())))
+
;;;
;;; Source code formatting.
@@ -1424,6 +1491,10 @@ or a list thereof")
(description "Validate file names and availability of patches")
(check check-patch-file-names))
(lint-checker
+ (name 'patch-headers)
+ (description "Validate patch headers")
+ (check check-patch-headers))
+ (lint-checker
(name 'formatting)
(description "Look for formatting issues in the source")
(check check-formatting))))
@@ -1462,7 +1533,11 @@ or a list thereof")
(lint-checker
(name 'archival)
(description "Ensure source code archival on Software Heritage")
- (check check-archival))))
+ (check check-archival))
+ (lint-checker
+ (name 'haskell-stackage)
+ (description "Ensure Haskell packages use Stackage LTS versions")
+ (check check-haskell-stackage))))
(define %all-checkers
(append %local-checkers
diff --git a/guix/packages.scm b/guix/packages.scm
index 7d8d02c30e..93407c143c 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1009,8 +1009,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)))
@@ -1021,28 +1020,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/archive.scm b/guix/scripts/archive.scm
index 02557ce454..c04baf9784 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -310,6 +311,16 @@ the input port."
(leave (G_ "failed to read public key: ~a: ~a~%")
(error-source err) (error-string err)))))
+ ;; Warn about potentially volatile ACLs, but continue: system reconfiguration
+ ;; might not be possible without (newly-authorized) substitutes.
+ (let ((stat (false-if-exception (lstat %acl-file))))
+ (when (and stat (eq? 'symlink (stat:type (lstat %acl-file))))
+ (warning (G_ "replacing symbolic link ~a with a regular file~%")
+ %acl-file)
+ (when (string-prefix? (%store-prefix) (readlink %acl-file))
+ (display-hint (G_ "On Guix System, add public keys to the
+@code{authorized-keys} field of your @code{operating-system} instead.")))))
+
(let ((key (read-key))
(acl (current-acl)))
(unless (eq? 'public-key (canonical-sexp-nth-data key 0))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index e59e0ee67f..a959cb827d 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,24 @@
#: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))
- #:export (%standard-build-options
+ #:use-module (guix transformations)
+ #:export (log-url
+
+ %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 +142,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.
@@ -1053,8 +557,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/deploy.scm b/guix/scripts/deploy.scm
index 1b5be307be..0725fba54b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -120,17 +120,28 @@ Perform the deployment specified by FILE.\n"))
(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))
+ (guard* (c
+ ;; On Guile 3.0, exceptions such as 'unbound-variable' are compound
+ ;; and include a '&message'. However, that message only contains
+ ;; the format string. Thus, special-case it here to avoid
+ ;; displaying a bare format string.
+ ((cond-expand
+ (guile-3
+ ((exception-predicate &exception-with-kind-and-args) c))
+ (else #f))
+ (raise 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))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 085f11a9d4..e435bf0ce4 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))
@@ -322,7 +323,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..ddfc6ba497 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -34,11 +34,12 @@
#:use-module (guix sets)
#:use-module ((guix diagnostics)
#:select (location-file formatted-message))
- #:use-module ((guix scripts build)
+ #:use-module ((guix transformations)
#:select (show-transformation-options-help
options->transformation
- %standard-build-options
%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)
@@ -585,11 +586,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..63e625f266 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)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 979d4f8363..c72dc3caad 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -9,7 +9,8 @@
;;; 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>
+;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -47,11 +48,15 @@
;; provided MESSAGE.
(for-each
(lambda (lint-warning)
- (let ((package (lint-warning-package lint-warning))
- (loc (lint-warning-location lint-warning)))
- (info loc (G_ "~a@~a: ~a~%")
- (package-name package) (package-version package)
- (lint-warning-message lint-warning))))
+ (let* ((package (lint-warning-package lint-warning))
+ (name (package-name package))
+ (version (package-version package))
+ (loc (lint-warning-location lint-warning))
+ (message (lint-warning-message lint-warning)))
+ (parameterize
+ ((guix-warning-port (current-output-port)))
+ (info loc (G_ "~a@~a: ~a~%")
+ name version message))))
warnings))
(define* (run-checkers package checkers #:key store)
@@ -98,6 +103,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 +121,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 +188,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 ea2a96d5a1..6e0a16f033 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -44,6 +45,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)
@@ -59,11 +61,16 @@
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (compressor?
+ compressor-name
+ compressor-extenstion
+ compressor-command
+ %compressors
lookup-compressor
self-contained-tarball
docker-image
squashfs-image
+ %formats
guix-pack))
;; Type of a compression tool.
@@ -142,9 +149,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)
@@ -757,12 +766,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))
@@ -856,7 +866,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")
@@ -865,6 +875,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 "\""))
@@ -879,16 +892,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)
@@ -1127,9 +1151,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..6faf2adb7a 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)
@@ -873,7 +874,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..2a2185e2b9 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,6 +1,8 @@
;;; 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>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -61,10 +63,14 @@
#:use-module ((guix build utils)
#:select (dump-port mkdir-p find-files))
#:use-module ((guix build syscalls) #:select (set-thread-name))
- #:export (%public-key
+ #:export (%default-gzip-compression
+
+ %public-key
%private-key
signed-string
+ open-server-socket
+ run-publish-server
guix-publish))
(define (show-help)
@@ -82,6 +88,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 +143,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 +199,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)
@@ -236,6 +255,21 @@ if ITEM is already compressed."
("WantMassQuery" . 0)
("Priority" . 100)))
+;;; A common buffer size value used for the TCP socket SO_SNDBUF option and
+;;; the gzip compressor buffer size.
+(define %default-buffer-size
+ (* 208 1024))
+
+(define %default-socket-options
+ ;; List of options passed to 'setsockopt' when transmitting files.
+ (list (list SO_SNDBUF %default-buffer-size)))
+
+(define* (configure-socket socket #:key (level SOL_SOCKET)
+ (options %default-socket-options))
+ "Apply multiple option tuples in OPTIONS to SOCKET, using LEVEL."
+ (for-each (cut apply setsockopt socket level <>)
+ options))
+
(define (signed-string s)
"Sign the hash of the string S with the daemon's key. Return a canonical
sexp for the signature."
@@ -434,7 +468,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 +488,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 +559,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 "")))))
@@ -532,7 +589,7 @@ requested using POOL."
(lambda (port)
(write-file item port))
#:level (compression-level compression)
- #:buffer-size (* 128 1024))
+ #:buffer-size %default-buffer-size)
(rename-file (string-append nar ".tmp") nar))
('lzip
;; Note: the file port gets closed along with the lzip port.
@@ -546,7 +603,10 @@ requested using POOL."
;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
(with-atomic-file-output nar
(lambda (port)
- (write-file item port))))))
+ (write-file item port)
+ ;; Make the file world-readable, contrary to what
+ ;; 'with-atomic-file-output' does.
+ (chmod port (logand #o644 (lognot (umask)))))))))
(define* (bake-narinfo+nar cache item
#:key ttl (compressions (list %no-compression))
@@ -578,7 +638,12 @@ requested using POOL."
#:nar-path nar-path
#:compressions compressions
#:file-sizes sizes)
- port)))))
+ port)))
+
+ ;; Make the cached narinfo world-readable, contrary to what
+ ;; 'with-atomic-file-output' does, so that other users can rsync
+ ;; the whole cache.
+ (chmod port (logand #o644 (lognot (umask))))))
;; Make narinfo files for OTHERS hard links to NARINFO such that the
;; atime-based cache eviction considers either all the nars or none
@@ -627,19 +692,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 +764,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 +784,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)
@@ -796,7 +886,7 @@ or if EOF is reached."
;; 'make-gzip-output-port' wants a file port.
(make-gzip-output-port (response-port response)
#:level level
- #:buffer-size (* 64 1024)))
+ #:buffer-size %default-buffer-size))
(($ <compression> 'lzip level)
(make-lzip-output-port (response-port response)
#:level level))
@@ -821,6 +911,7 @@ blocking."
client))
(port (begin
(force-output client)
+ (configure-socket client)
(nar-response-port response compression))))
;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
;; 'render-nar', BODY here is just the file name of the store item.
@@ -850,7 +941,7 @@ blocking."
size)
client))
(output (response-port response)))
- (setsockopt client SOL_SOCKET SO_SNDBUF (* 128 1024))
+ (configure-socket client)
(if (file-port? output)
(sendfile output input size)
(dump-port input output))
@@ -918,6 +1009,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
@@ -992,7 +1086,8 @@ methods, return the applicable compression."
(define (open-server-socket address)
"Return a TCP socket bound to ADDRESS, a socket address."
(let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
- (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (configure-socket sock #:options (cons (list SO_REUSEADDR 1)
+ %default-socket-options))
(bind sock address)
sock))
@@ -1061,7 +1156,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/pull.scm b/guix/scripts/pull.scm
index bb1b560a22..7fd8b3f1a4 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -385,7 +385,7 @@ previous generation. Return true if there are news to display."
(and=> (relative-generation profile -1)
(cut generation-file-name profile <>)))
- (when previous
+ (and previous
(let ((old-channels (profile-channels previous))
(new-channels (profile-channels profile)))
;; Find the channels present in both PROFILE and PREVIOUS, and print
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 4a71df28d1..fb6c52a567 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -440,7 +440,7 @@ releases for ~a~%")
(full-name x)))
(lst
(format (current-output-port)
- (N_ "Building the following ~*package would ensure ~d \
+ (N_ "Building the following ~d package would ensure ~d \
dependent packages are rebuilt: ~{~a~^ ~}~%"
"Building the following ~d packages would ensure ~d \
dependent packages are rebuilt: ~{~a~^ ~}~%"
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..db80e0be8f 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
@@ -671,7 +674,8 @@ checking this by themselves in their 'check' procedure."
(define* (system-derivation-for-action os action
#:key image-size image-type
full-boot? container-shared-network?
- mappings label)
+ mappings label
+ volatile-root?)
"Return as a monadic value the derivation for OS according to ACTION."
(mlet %store-monad ((target (current-target-system)))
(case action
@@ -703,7 +707,8 @@ checking this by themselves in their 'check' procedure."
base-image))
(target (or base-target target))
(size image-size)
- (operating-system os))))))
+ (operating-system os)
+ (volatile-root? volatile-root?))))))
((docker-image)
(system-docker-image os
#:shared-network? container-shared-network?)))))
@@ -758,6 +763,7 @@ and TARGET arguments."
dry-run? derivations-only?
use-substitutes? bootloader-target target
image-size image-type
+ volatile-root?
full-boot? label container-shared-network?
(mappings '())
(gc-root #f))
@@ -765,7 +771,8 @@ and TARGET arguments."
bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
target root directory; IMAGE-SIZE is the size of the image to be built, for
the 'vm-image' and 'disk-image' actions. IMAGE-TYPE is the type of image to
-be built.
+be built. When VOLATILE-ROOT? is #t, the root file system is mounted
+volatile.
FULL-BOOT? is used for the 'vm' action; it determines whether to
boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK?
@@ -813,6 +820,7 @@ static checks."
#:label label
#:image-type image-type
#:image-size image-size
+ #:volatile-root? volatile-root?
#:full-boot? full-boot?
#:container-shared-network? container-shared-network?
#:mappings mappings))
@@ -972,6 +980,8 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "
--no-bootloader for 'init', do not install a bootloader"))
(display (G_ "
+ --volatile for 'disk-image', make the root file system volatile"))
+ (display (G_ "
--label=LABEL for 'disk-image', label disk image with LABEL"))
(display (G_ "
--save-provenance save provenance information"))
@@ -1045,6 +1055,9 @@ Some ACTIONS support additional ARGS.\n"))
(option '("no-bootloader" "no-grub") #f #f
(lambda (opt name arg result)
(alist-cons 'install-bootloader? #f result)))
+ (option '("volatile") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'volatile-root? #t result)))
(option '("label") #t #f
(lambda (opt name arg result)
(alist-cons 'label arg result)))
@@ -1106,7 +1119,8 @@ Some ACTIONS support additional ARGS.\n"))
(image-type . raw)
(image-size . guess)
(install-bootloader? . #t)
- (label . #f)))
+ (label . #f)
+ (volatile-root? . #f)))
(define (verbosity-level opts)
"Return the verbosity level based on OPTS, the alist of parsed options."
@@ -1203,6 +1217,8 @@ resulting from command-line parsing."
#:image-type (lookup-image-type-by-name
(assoc-ref opts 'image-type))
#:image-size (assoc-ref opts 'image-size)
+ #:volatile-root?
+ (assoc-ref opts 'volatile-root?)
#:full-boot? (assoc-ref opts 'full-boot?)
#:container-shared-network?
(assoc-ref opts 'container-shared-network?)
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..dcbcb2ab09 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)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 6a2582c997..f28070ddc4 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -30,6 +31,7 @@
#:use-module (guix grafts)
#:use-module (guix gexp)
#:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module ((guix build utils) #:select (every*))
#:use-module (guix scripts substitute)
#:use-module (guix http-client)
#:use-module (guix ci)
@@ -540,23 +542,23 @@ SERVER. Display information for packages with at least THRESHOLD dependents."
(package-outputs packages system))
systems))))))
(exit
- (every (lambda (server)
- (define coverage
- (report-server-coverage server items
- #:display-missing?
- (assoc-ref opts 'display-missing?)))
- (match (assoc-ref opts 'coverage)
- (#f #f)
- (threshold
- ;; PACKAGES may include non-package objects coming from a
- ;; manifest. Filter them out.
- (report-package-coverage server
- (filter package? packages)
- systems
- #:threshold threshold)))
-
- (= 1 coverage))
- urls))))))
+ (every* (lambda (server)
+ (define coverage
+ (report-server-coverage server items
+ #:display-missing?
+ (assoc-ref opts 'display-missing?)))
+ (match (assoc-ref opts 'coverage)
+ (#f #f)
+ (threshold
+ ;; PACKAGES may include non-package objects coming from a
+ ;; manifest. Filter them out.
+ (report-package-coverage server
+ (filter package? packages)
+ systems
+ #:threshold threshold)))
+
+ (= 1 coverage))
+ urls))))))
;;; Local Variables:
;;; eval: (put 'let/time 'scheme-indent-function 1)
diff --git a/guix/self.scm b/guix/self.scm
index bbfd2f1b95..026dcd9c1a 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -400,6 +400,12 @@ a list of extra files, such as '(\"contributing\")."
(find-files directory
"\\.[a-z]{2}(_[A-Z]{2})?\\.po$")))
+ (define parallel-jobs
+ ;; Limit thread creation by 'n-par-for-each'. Going beyond can
+ ;; lead libgc 8.0.4 to abort with:
+ ;; mmap(PROT_NONE) failed
+ (min (parallel-job-count) 4))
+
(mkdir #$output)
(copy-recursively #$documentation "."
#:log (%make-void-port "w"))
@@ -415,14 +421,14 @@ a list of extra files, such as '(\"contributing\")."
(setenv "LC_ALL" "en_US.UTF-8")
(setlocale LC_ALL "en_US.UTF-8")
- (n-par-for-each (parallel-job-count)
+ (n-par-for-each parallel-jobs
(match-lambda
((language . po)
(translate-texi "guix" po language
#:extras '("contributing"))))
(available-translations "." "guix-manual"))
- (n-par-for-each (parallel-job-count)
+ (n-par-for-each parallel-jobs
(match-lambda
((language . po)
(translate-texi "guix-cookbook" po language)))
diff --git a/guix/store.scm b/guix/store.scm
index d859ea33ed..4da39971b5 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -113,6 +113,7 @@
build
query-failed-paths
clear-failed-paths
+ ensure-path
add-temp-root
add-indirect-root
add-permanent-root
@@ -1397,6 +1398,12 @@ When a handler is installed with 'with-build-handler', it is called any time
(message "unsupported build mode")
(status 1))))))))))))
+(define-operation (ensure-path (store-path path))
+ "Ensure that a path is valid. If it is not valid, it may be made valid by
+running a substitute. As a GC root is not created by the daemon, you may want
+to call ADD-TEMP-ROOT on that store path."
+ boolean)
+
(define-operation (add-temp-root (store-path path))
"Make PATH a temporary root for the duration of the current session.
Return #t."
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..d49041cf59
--- /dev/null
+++ b/guix/transformations.scm
@@ -0,0 +1,632 @@
+;;; 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))
+
+ (option '("help-transform") #f #f
+ (lambda _
+ (format #t
+ (G_ "Available package transformation options:~%"))
+ (show-transformation-options-help/detailed)
+ (newline)
+ (exit 0))))))
+
+(define (show-transformation-options-help/detailed)
+ (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 (show-transformation-options-help)
+ "Show basic help for package transformation options."
+ (display (G_ "
+ --help-transform list package transformation options not shown here")))
+
+(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)))))))))
diff --git a/guix/ui.scm b/guix/ui.scm
index 8d7bc238bc..0c2c6a5e97 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -101,6 +101,7 @@
show-what-to-build
show-what-to-build*
show-manifest-transaction
+ guard*
call-with-error-handling
with-error-handling
with-unbound-variable-handling
@@ -435,6 +436,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler."
(gettext (condition-message obj) %gettext-domain)))
((formatted-message? obj)
(warning (G_ "failed to load '~a': ~a~%")
+ file
(apply format #f
(gettext (formatted-message-string obj)
%gettext-domain)
@@ -717,7 +719,7 @@ evaluating the tests and bodies of CLAUSES."
(package-full-name package)
(build-system-name system))))
((gexp-input-error? c)
- (let ((input (package-error-invalid-input c)))
+ (let ((input (gexp-error-invalid-input c)))
(leave (G_ "~s: invalid G-expression input~%")
(gexp-error-invalid-input c))))
((profile-not-found-error? c)
diff --git a/guix/utils.scm b/guix/utils.scm
index ba896623f4..0674ec61b8 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -83,6 +83,7 @@
target-arm?
target-64bit?
cc-for-target
+ cxx-for-target
version-compare
version>?
@@ -547,6 +548,11 @@ a character other than '@'."
(string-append target "-gcc")
"gcc"))
+(define* (cxx-for-target #:optional (target (%current-target-system)))
+ (if target
+ (string-append target "-g++")
+ "g++"))
+
(define version-compare
(let ((strverscmp
(let ((sym (or (dynamic-func "strverscmp" (dynamic-link))