;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
#: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?
;;;
;;; 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.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
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."
(apply invoke
(string-append #+tar "/bin/tar")
"cvfa" #$output
- ;; avoid non-determinism in the archive
- "--mtime=@0"
+ ;; Avoid non-determinism in the archive. Set the mtime
+ ;; to 1 as is the case in the store (software like gzip
+ ;; behaves differently when it stumbles upon mtime = 0).
+ "--mtime=@1"
"--owner=root:0"
"--group=root:0"
(if tar-supports-sort?
(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 ...)
(_
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.
+ (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))))))))
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
#: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