#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix base32)
+ #:autoload (guix base64) (base64-decode)
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix memoization)
#:use-module (guix build-system)
#:use-module (guix search-paths)
#:use-module (guix sets)
+ #:use-module (guix deprecation)
+ #:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (rnrs bytevectors)
#:use-module (web uri)
#:re-export (%current-system
%current-target-system
search-path-specification) ;for convenience
- #:export (origin
+ #:export (content-hash
+ content-hash?
+ content-hash-algorithm
+ content-hash-value
+
+ origin
origin?
this-origin
origin-uri
origin-method
- origin-sha256
+ origin-hash
+ origin-sha256 ;deprecated
origin-file-name
origin-actual-file-name
origin-patches
origin-snippet
origin-modules
base32
+ base64
package
package?
package-patched-vulnerabilities
package-with-patches
package-with-extra-patches
+ package-with-c-toolchain
package/inherit
transitive-input-references
;;;
;;; Code:
+;; Crytographic content hash.
+(define-immutable-record-type <content-hash>
+ (%content-hash algorithm value)
+ content-hash?
+ (algorithm content-hash-algorithm) ;symbol
+ (value content-hash-value)) ;bytevector
+
+(define-syntax-rule (define-content-hash-constructor name
+ (algorithm size) ...)
+ "Define NAME as a <content-hash> constructor that ensures that (1) its
+second argument is among the listed ALGORITHM, and (2), when possible, that
+its first argument has the right size for the chosen algorithm."
+ (define-syntax name
+ (lambda (s)
+ (syntax-case s (algorithm ...)
+ ((_ bv algorithm)
+ (let ((bv* (syntax->datum #'bv)))
+ (when (and (bytevector? bv*)
+ (not (= size (bytevector-length bv*))))
+ (syntax-violation 'content-hash "invalid content hash length" s))
+ #'(%content-hash 'algorithm bv)))
+ ...))))
+
+(define-content-hash-constructor build-content-hash
+ (sha256 32)
+ (sha512 64)
+ (sha3-256 32)
+ (sha3-512 64)
+ (blake2s-256 64))
+
+(define-syntax content-hash
+ (lambda (s)
+ "Return a content hash with the given parameters. The default hash
+algorithm is sha256. If the first argument is a literal string, it is decoded
+as base32. Otherwise, it must be a bytevector."
+ ;; What we'd really want here is something like C++ 'constexpr'.
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ #'(content-hash str sha256))
+ ((_ str algorithm)
+ (string? (syntax->datum #'str))
+ (with-syntax ((bv (base32 (syntax->datum #'str))))
+ #'(content-hash bv algorithm)))
+ ((_ (id str) algorithm)
+ (and (string? (syntax->datum #'str))
+ (free-identifier=? #'id #'base32))
+ (with-syntax ((bv (nix-base32-string->bytevector (syntax->datum #'str))))
+ #'(content-hash bv algorithm)))
+ ((_ (id str) algorithm)
+ (and (string? (syntax->datum #'str))
+ (free-identifier=? #'id #'base64))
+ (with-syntax ((bv (base64-decode (syntax->datum #'str))))
+ #'(content-hash bv algorithm)))
+ ((_ bv)
+ #'(content-hash bv sha256))
+ ((_ bv hash)
+ #'(build-content-hash bv hash)))))
+
+(define (print-content-hash hash port)
+ (format port "#<content-hash ~a:~a>"
+ (content-hash-algorithm hash)
+ (and=> (content-hash-value hash)
+ bytevector->nix-base32-string)))
+
+(set-record-type-printer! <content-hash> print-content-hash)
+
+\f
;; The source of a package, such as a tarball URL and fetcher---called
;; "origin" to avoid name clash with `package-source', `source', etc.
(define-record-type* <origin>
- origin make-origin
+ %origin make-origin
origin?
this-origin
(uri origin-uri) ; string
(method origin-method) ; procedure
- (sha256 origin-sha256) ; bytevector
+ (hash origin-hash) ; <content-hash>
(file-name origin-file-name (default #f)) ; optional file name
;; Patches are delayed so that the 'search-patch' calls are made lazily,
(patch-guile origin-patch-guile ; package or #f
(default #f)))
+(define-syntax origin-compatibility-helper
+ (syntax-rules (sha256)
+ ((_ () (fields ...))
+ (%origin fields ...))
+ ((_ ((sha256 exp) rest ...) (others ...))
+ (%origin others ...
+ (hash (content-hash exp sha256))
+ rest ...))
+ ((_ (field rest ...) (others ...))
+ (origin-compatibility-helper (rest ...)
+ (others ... field)))))
+
+(define-syntax-rule (origin fields ...)
+ "Build an <origin> record, automatically converting 'sha256' field
+specifications to 'hash'."
+ (origin-compatibility-helper (fields ...) ()))
+
+(define-deprecated (origin-sha256 origin)
+ origin-hash
+ (let ((hash (origin-hash origin)))
+ (unless (eq? (content-hash-algorithm hash) 'sha256)
+ (raise (condition (&message
+ (message (G_ "no SHA256 hash for origin"))))))
+ (content-hash-value hash)))
+
(define (print-origin origin port)
"Write a concise representation of ORIGIN to PORT."
(match origin
- (($ <origin> uri method sha256 file-name patches)
+ (($ <origin> uri method hash file-name patches)
(simple-format port "#<origin ~s ~a ~s ~a>"
- uri (bytevector->base32-string sha256)
+ uri hash
(force patches)
(number->string (object-address origin) 16)))))
(set-record-type-printer! <origin> print-origin)
-(define-syntax base32
- (lambda (s)
- "Return the bytevector corresponding to the given Nix-base32
+(define-syntax-rule (define-compile-time-decoder name string->bytevector)
+ "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
+if possible."
+ (define-syntax name
+ (lambda (s)
+ "Return the bytevector corresponding to the given textual
representation."
- (syntax-case s ()
- ((_ str)
- (string? (syntax->datum #'str))
- ;; A literal string: do the conversion at expansion time.
- (with-syntax ((bv (nix-base32-string->bytevector
- (syntax->datum #'str))))
- #''bv))
- ((_ str)
- #'(nix-base32-string->bytevector str)))))
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ ;; A literal string: do the conversion at expansion time.
+ (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
+ #''bv))
+ ((_ str)
+ #'(string->bytevector str))))))
+
+(define-compile-time-decoder base32 nix-base32-string->bytevector)
+(define-compile-time-decoder base64 base64-decode)
(define (origin-actual-file-name origin)
"Return the file name of ORIGIN, either its 'file-name' field or the file
;; git, svn, cvs, etc. reference
#f))))
+\f
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
package)
16)))))
+(define-syntax-rule (package/inherit p overrides ...)
+ "Like (package (inherit P) OVERRIDES ...), except that the same
+transformation is done to the package replacement, if any. P must be a bare
+identifier, and will be bound to either P or its replacement when evaluating
+OVERRIDES."
+ (let loop ((p p))
+ (package (inherit p)
+ overrides ...
+ (replacement (and=> (package-replacement p) loop)))))
+
(define (package-upstream-name package)
"Return the upstream name of PACKAGE, which could be different from the name
it has in Guix."
(append (origin-patches (package-source original))
patches)))
+(define (package-with-c-toolchain package toolchain)
+ "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
+C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples)
+providing equivalent functionality, such as the 'gcc-toolchain' package."
+ (let ((bs (package-build-system package)))
+ (package/inherit package
+ (build-system (build-system-with-c-toolchain bs toolchain)))))
+
(define (transitive-inputs inputs)
"Return the closure of INPUTS when considering the 'propagated-inputs'
edges. Omit duplicate inputs, except for those already present in INPUTS
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."
- (transitive-inputs (bag-direct-inputs bag)))
+ (parameterize ((%current-target-system #f)
+ (%current-system (bag-system bag)))
+ (transitive-inputs (bag-direct-inputs bag))))
(define (bag-transitive-build-inputs bag)
"Same as 'package-transitive-native-inputs', but applied to a bag."
- (transitive-inputs (bag-build-inputs bag)))
+ (parameterize ((%current-target-system #f)
+ (%current-system (bag-system bag)))
+ (transitive-inputs (bag-build-inputs bag))))
(define (bag-transitive-host-inputs bag)
"Same as 'package-transitive-target-inputs', but applied to a bag."
- (parameterize ((%current-target-system (bag-target bag)))
+ (parameterize ((%current-target-system (bag-target bag))
+ (%current-system (bag-system bag)))
(transitive-inputs (bag-host-inputs bag))))
(define (bag-transitive-target-inputs bag)
"Return the \"target inputs\" of BAG, recursively."
- (transitive-inputs (bag-target-inputs bag)))
+ (parameterize ((%current-target-system (bag-target bag))
+ (%current-system (bag-system bag)))
+ (transitive-inputs (bag-target-inputs bag))))
(define* (package-closure packages #:key (system (%current-system)))
"Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
(vhash-consq package #t visited)
(fold set-insert closure dependencies))))))))
-(define* (package-mapping proc #:optional (cut? (const #f)))
+(define (build-system-with-package-mapping bs rewrite)
+ "Return a variant of BS, a build system, that rewrites a bag's inputs by
+passing them through REWRITE, a procedure that takes an input tuplet and
+returns a \"rewritten\" input tuplet."
+ (define lower
+ (build-system-lower bs))
+
+ (define (lower* . args)
+ (let ((lowered (apply lower args)))
+ (bag
+ (inherit lowered)
+ (build-inputs (map rewrite (bag-build-inputs lowered)))
+ (host-inputs (map rewrite (bag-host-inputs lowered)))
+ (target-inputs (map rewrite (bag-target-inputs lowered))))))
+
+ (build-system
+ (inherit bs)
+ (lower lower*)))
+
+(define* (package-mapping proc #:optional (cut? (const #f))
+ #:key deep?)
"Return a procedure that, given a package, applies PROC to all the packages
depended on and returns the resulting package. The procedure stops recursion
-when CUT? returns true for a given package."
+when CUT? returns true for a given package. When DEEP? is true, PROC is
+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)))
+ (define mapping-property
+ ;; Property indicating whether the package has already been processed.
+ (gensym " package-mapping-done"))
+
(define replace
(mlambdaq (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))
- (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) proc))))))
+ ;; If P is the result of a previous call, return it.
+ (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)
(define* (package-input-rewriting replacements
- #:optional (rewrite-name identity))
+ #:optional (rewrite-name identity)
+ #:key (deep? #t))
"Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
-REPLACEMENTS is a list of package pairs; the first element of each pair is the
-package to replace, and the second one is the replacement.
+indirect dependencies, including implicit inputs when DEEP? is true, according
+to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element
+of each pair is the package to replace, and the second one is the replacement.
Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
package and returns its new name after rewrite."
- (define (rewrite p)
- (match (assq-ref replacements p)
- (#f (package
- (inherit p)
- (name (rewrite-name (package-name p)))))
- (new new)))
-
- (package-mapping rewrite (cut assq <> replacements)))
+ (define replacement-property
+ ;; Property to tag right-hand sides in REPLACEMENTS.
+ (gensym " package-replacement"))
-(define (package-input-rewriting/spec replacements)
+ (define (rewrite p)
+ (if (assq-ref (package-properties p) replacement-property)
+ p
+ (match (assq-ref replacements p)
+ (#f (package/inherit p
+ (name (rewrite-name (package-name p)))))
+ (new (if deep?
+ (package/inherit new
+ (properties `((,replacement-property . #t)
+ ,@(package-properties new))))
+ new)))))
+
+ (define (cut? p)
+ (or (assq-ref (package-properties p) replacement-property)
+ (assq-ref replacements p)))
+
+ (package-mapping rewrite cut?
+ #:deep? deep?))
+
+(define* (package-input-rewriting/spec replacements #:key (deep? #t))
"Return a procedure that, given a package, applies the given REPLACEMENTS to
-all the package graph (excluding implicit inputs). REPLACEMENTS is a list of
-spec/procedures pair; each spec is a package specification such as \"gcc\" or
-\"guile@2\", and each procedure takes a matching package and returns a
-replacement for that package."
+all the package graph, including implicit inputs unless DEEP? is false.
+REPLACEMENTS is a list of spec/procedures pair; each spec is a package
+specification such as \"gcc\" or \"guile@2\", and each procedure takes a
+matching package and returns a replacement for that package."
(define table
(fold (lambda (replacement table)
(match replacement
(package-name package)
table))
- (define (rewrite package)
- (match (find-replacement package)
- (#f package)
- (proc (proc package))))
+ (define replacement-property
+ (gensym " package-replacement"))
- (package-mapping rewrite find-replacement))
-
-(define-syntax-rule (package/inherit p overrides ...)
- "Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any. P must be a bare
-identifier, and will be bound to either P or its replacement when evaluating
-OVERRIDES."
- (let loop ((p p))
- (package (inherit p)
- overrides ...
- (replacement (and=> (package-replacement p) loop)))))
+ (define (rewrite p)
+ (if (assq-ref (package-properties p) replacement-property)
+ p
+ (match (find-replacement p)
+ (#f p)
+ (proc
+ (let ((new (proc p)))
+ ;; Mark NEW as already processed.
+ (package/inherit new
+ (properties `((,replacement-property . #t)
+ ,@(package-properties new)))))))))
+
+ (define (cut? p)
+ (or (assq-ref (package-properties p) replacement-property)
+ (find-replacement p)))
+
+ (package-mapping rewrite cut?
+ #:deep? deep?))
\f
;;;
(make-weak-key-hash-table 200))
(define (input-graft store system)
- "Return a procedure that, given a package with a graft, returns a graft, and
-#f otherwise."
- (match-lambda
- ((? package? package)
+ "Return a procedure that, given a package with a replacement and an output name,
+returns a graft, and #f otherwise."
+ (match-lambda*
+ (((? package? package) output)
(let ((replacement (package-replacement package)))
(and replacement
- (cached (=> %graft-cache) package system
+ (cached (=> %graft-cache) package (cons output system)
(let ((orig (package-derivation store package system
#:graft? #f))
(new (package-derivation store replacement system
#:graft? #t)))
(graft
(origin orig)
- (replacement new)))))))
- (x
- #f)))
+ (origin-output output)
+ (replacement new)
+ (replacement-output output)))))))))
(define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs."
- (match-lambda
- ((? package? package)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-cross-derivation store package target system
- #:graft? #f))
- (new (package-cross-derivation store replacement
- target system
- #:graft? #t)))
- (graft
- (origin orig)
- (replacement new))))))
- (_
- #f)))
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (and replacement
+ (let ((orig (package-cross-derivation store package target system
+ #:graft? #f))
+ (new (package-cross-derivation store replacement
+ target system
+ #:graft? #t)))
+ (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))))))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
(bag-host-inputs bag))))
bag-host-inputs))
- (define nodes
- (match (bag-direct-inputs* bag)
- (((labels things _ ...) ...)
- things)))
-
- (let loop ((nodes nodes)
+ (let loop ((inputs (bag-direct-inputs* bag))
(result seed)
- (visited (setq)))
- (match nodes
+ (visited vlist-null))
+ (match inputs
(()
result)
- (((? package? head) . tail)
- (if (set-contains? visited head)
- (loop tail result visited)
- (let ((inputs (bag-direct-inputs* (package->bag head))))
- (loop (match inputs
- (((labels things _ ...) ...)
- (append things tail)))
- (proc head result)
- (set-insert head visited)))))
+ (((label (? package? head) . rest) . tail)
+ (let ((output (match rest (() "out") ((output) output)))
+ (outputs (vhash-foldq* cons '() head visited)))
+ (if (member output outputs)
+ (loop tail result visited)
+ (let ((inputs (bag-direct-inputs* (package->bag head))))
+ (loop (append inputs tail)
+ (proc head output result)
+ (vhash-consq head output visited))))))
((head . tail)
(loop tail result visited)))))
(define native-grafts
(let ((->graft (input-graft store system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag)))
+ (parameterize ((%current-system system)
+ (%current-target-system #f))
+ (fold-bag-dependencies (lambda (package output grafts)
+ (match (->graft package output)
+ (#f grafts)
+ (graft (cons graft grafts))))
+ '()
+ bag))))
(define target-grafts
(if target
(let ((->graft (input-cross-graft store target system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag
- #:native? #f))
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (fold-bag-dependencies (lambda (package output grafts)
+ (match (->graft package output)
+ (#f grafts)
+ (graft (cons graft grafts))))
+ '()
+ bag
+ #:native? #f)))
'()))
;; We can end up with several identical grafts if we stumble upon packages
"Return as a monadic value the absolute file name of FILE within the
OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
OUTPUT directory of PACKAGE. When TARGET is true, use it as a
-cross-compilation target triplet."
+cross-compilation target triplet.
+
+Note that this procedure does _not_ build PACKAGE. Thus, the result might or
+might not designate an existing file. We recommend not using this procedure
+unless you know what you are doing."
(lambda (store)
(define compute-derivation
(if target
#:optional (system (%current-system)))
"Return the derivation corresponding to ORIGIN."
(match origin
- (($ <origin> uri method sha256 name (= force ()) #f)
+ (($ <origin> uri method hash name (= force ()) #f)
;; No patches, no snippet: this is a fixed-output derivation.
- (method uri 'sha256 sha256 name #:system system))
- (($ <origin> uri method sha256 name (= force (patches ...)) snippet
+ (method uri
+ (content-hash-algorithm hash)
+ (content-hash-value hash)
+ name #:system system))
+ (($ <origin> uri method hash name (= force (patches ...)) snippet
(flags ...) inputs (modules ...) guile-for-build)
;; Patches and/or a snippet.
- (mlet %store-monad ((source (method uri 'sha256 sha256 name
- #:system system))
+ (mlet %store-monad ((source (method uri
+ (content-hash-algorithm hash)
+ (content-hash-value hash)
+ name #:system system))
(guile (package->derivation (or guile-for-build
(default-guile))
system
HCoop / jackhill / guix / guix.git / blobdiff