ci: Remove hydra support.
[jackhill/guix/guix.git] / guix / packages.scm
index 2fa4fd0..a057a88 100644 (file)
@@ -3,7 +3,7 @@
 ;;; 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
@@ -62,6 +72,7 @@
             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
 
             %supported-systems
             %hurd-systems
-            %hydra-supported-systems
+            %cuirass-supported-systems
             supported-package?
 
             &package-error
 ;;;
 ;;; Code:
 
+(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 (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)
+
+;; 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
-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)))))
-
 (define (origin-actual-file-name origin)
   "Return the file name of ORIGIN, either its 'file-name' field or the file
 name of its URI."
@@ -231,16 +341,17 @@ name of its URI."
          ;; 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.
   '("i586-gnu" "i686-gnu"))
 
-(define %hydra-supported-systems
+(define %cuirass-supported-systems
   ;; This is the list of system types for which build machines are available.
   ;;
   ;; XXX: MIPS is unavailable in CI:
@@ -312,6 +423,16 @@ name of its URI."
                                                        package)
                                                       16)))))
 
+(define-syntax-rule (package/inherit p overrides ...)
+  "Like (package (inherit P) OVERRIDES ...), except that the same
+transformation is done to the package P's 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."
@@ -354,29 +475,34 @@ object."
 
   (match (package-location package)
     (($ <location> file line column)
-     (catch 'system-error
-       (lambda ()
-         ;; In general we want to keep relative file names for modules.
-         (call-with-input-file (search-path %load-path file)
-           (lambda (port)
-             (goto port line column)
-             (match (read port)
-               (('package inits ...)
-                (let ((field (assoc field inits)))
-                  (match field
-                    ((_ value)
-                     (let ((loc (and=> (source-properties value)
-                                       source-properties->location)))
-                       (and loc
-                            ;; Preserve the original file name, which may be a
-                            ;; relative file name.
-                            (set-field loc (location-file) file))))
-                    (_
-                     #f))))
-               (_
-                #f)))))
-       (lambda _
-         #f)))
+     (match (search-path %load-path file)
+       ((? string? file-found)
+        (catch 'system-error
+          (lambda ()
+            ;; In general we want to keep relative file names for modules.
+            (call-with-input-file file-found
+              (lambda (port)
+                (goto port line column)
+                (match (read port)
+                  (('package inits ...)
+                   (let ((field (assoc field inits)))
+                     (match field
+                       ((_ value)
+                        (let ((loc (and=> (source-properties value)
+                                          source-properties->location)))
+                          (and loc
+                               ;; Preserve the original file name, which may be a
+                               ;; relative file name.
+                               (set-field loc (location-file) file))))
+                       (_
+                        #f))))
+                  (_
+                   #f)))))
+          (lambda _
+            #f)))
+       (#f
+        ;; FILE could not be found in %LOAD-PATH.
+        #f)))
     (_ #f)))
 
 
@@ -638,8 +764,10 @@ specifies modules in scope when evaluating SNIPPET."
               (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?
@@ -668,6 +796,14 @@ specifies modules in scope when evaluating SNIPPET."
                         (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
@@ -812,20 +948,27 @@ dependencies are known to build on SYSTEM."
 
 (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
@@ -849,60 +992,125 @@ packages they depend on, recursively."
                    (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
@@ -927,22 +1135,27 @@ replacement for that package."
                  (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
 ;;;
@@ -1083,39 +1296,39 @@ and return it."
   (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))
@@ -1132,26 +1345,21 @@ dependencies; otherwise, restrict to target dependencies."
                       (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)))))
 
@@ -1166,23 +1374,27 @@ to (see 'graft-derivation'.)"
 
   (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
@@ -1376,14 +1588,19 @@ unless you know what you are doing."
                              #: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