14 files changed, 220 insertions(+), 58 deletions(-)

M doc/guix.texi
M gnu/packages/aspell.scm
M gnu/packages/bash.scm
M gnu/packages/bootstrap.scm
M gnu/packages/readline.scm
M gnu/packages/virtualization.scm
M guix/import/utils.scm
M guix/packages.scm
M guix/tests.scm
M tests/challenge.scm
M tests/derivations.scm
M tests/graph.scm
M tests/packages.scm
M tests/store.scm

@@ 5966,9 5966,13 @@ specified in the @code{uri} field as a @code{git-reference} object; a
 @end table
 
 @item @code{sha256}
-A bytevector containing the SHA-256 hash of the source.  Typically the
-@code{base32} form is used here to generate the bytevector from a
-base-32 string.
+A bytevector containing the SHA-256 hash of the source.  This is
+equivalent to providing a @code{content-hash} SHA256 object in the
+@code{hash} field described below.
+
+@item @code{hash}
+The @code{content-hash} object of the source---see below for how to use
+@code{content-hash}.
 
 You can obtain this information using @code{guix download}
 (@pxref{Invoking guix download}) or @code{guix hash} (@pxref{Invoking


@@ 6013,6 6017,30 @@ this is @code{#f}, a sensible default is used.
 @end table
 @end deftp
 
+@deftp {Data Type} content-hash @var{value} [@var{algorithm}]
+Construct a content hash object for the given @var{algorithm}, and with
+@var{value} as its hash value.  When @var{algorithm} is omitted, assume
+it is @code{sha256}.
+
+@var{value} can be a literal string, in which case it is base32-decoded,
+or it can be a bytevector.
+
+The following forms are all equivalent:
+
+@lisp
+(content-hash "05zxkyz9bv3j9h0xyid1rhvh3klhsmrpkf3bcs6frvlgyr2gwilj")
+(content-hash "05zxkyz9bv3j9h0xyid1rhvh3klhsmrpkf3bcs6frvlgyr2gwilj"
+              sha256)
+(content-hash (base32
+               "05zxkyz9bv3j9h0xyid1rhvh3klhsmrpkf3bcs6frvlgyr2gwilj"))
+(content-hash (base64 "kkb+RPaP7uyMZmu4eXPVkM4BN8yhRd8BTHLslb6f/Rc=")
+              sha256)
+@end lisp
+
+Technically, @code{content-hash} is currently implemented as a macro.
+It performs sanity checks at macro-expansion time, when possible, such
+as ensuring that @var{value} has the right size for @var{algorithm}.
+@end deftp
 
 @node Build Systems
 @section Build Systems

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
 ;;; Copyright © 2016, 2017, 2019 Efraim Flashner <efraim@flashner.co.il>


@@ 111,7 111,7 @@ dictionaries, including personal ones.")
               (uri (string-append "mirror://gnu/aspell/dict/" dict-name
                                   "/" prefix dict-name "-"
                                   version ".tar.bz2"))
-              (sha256 sha256)))
+              (hash (content-hash sha256))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases


@@ 163,7 163,7 @@ dictionaries, including personal ones.")
          (method url-fetch)
          (uri (string-append "https://www.softcatala.org/pub/softcatala/aspell/"
                              version "/aspell6-ca-" version ".tar.bz2"))
-         (sha256 sha256)))
+         (hash (content-hash sha256))))
       (home-page "https://www.softcatala.org/pub/softcatala/aspell/"))))
 
 (define-public aspell-dict-de


@@ 264,7 264,7 @@ dictionaries, including personal ones.")
          (uri (string-append "mirror://sourceforge/linguistico/"
                              "Dizionario%20italiano%20per%20Aspell/" version "/"
                              "aspell6-it-" version ".tar.bz2"))
-         (sha256 sha256)))
+         (hash (content-hash sha256))))
        (home-page
         "http://linguistico.sourceforge.net/pages/dizionario_italiano.html"))))
 

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015, 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2016, 2017, 2018, 2019 Efraim Flashner <efraim@flashner.co.il>


@@ 48,12 48,12 @@
   "Return the URL of Bash patch number SEQNO."
   (format #f "mirror://gnu/bash/bash-5.0-patches/bash50-~3,'0d" seqno))
 
-(define (bash-patch seqno sha256)
-  "Return the origin of Bash patch SEQNO, with expected hash SHA256"
+(define (bash-patch seqno sha256-bv)
+  "Return the origin of Bash patch SEQNO, with expected hash SHA256-BV."
   (origin
     (method url-fetch)
     (uri (patch-url seqno))
-    (sha256 sha256)))
+    (sha256 sha256-bv)))
 
 (define-syntax-rule (patch-series (seqno hash) ...)
   (list (bash-patch seqno (base32 hash))

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015, 2018, 2019 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2018, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>


@@ 151,14 151,14 @@ built for SYSTEM."
                    (format #f (G_ "could not find bootstrap binary '~a' \
 for system '~a'")
                            program system))))))
-        ((sha256)
+        ((bv)
          (origin
            (method url-fetch/executable)
            (uri (map (cute string-append <>
                            (bootstrap-executable-file-name system program))
                      %bootstrap-executable-base-urls))
            (file-name program)
-           (sha256 sha256)))))))
+           (hash (content-hash bv sha256))))))))
 
 
 ;;;

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2019 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>


@@ 35,12 35,12 @@
   (format #f "mirror://gnu/readline/readline-~a-patches/readline~a-~3,'0d"
           version (string-join (string-split version #\.) "") seqno))
 
-(define (readline-patch version seqno sha256)
-  "Return the origin of Readline patch SEQNO, with expected hash SHA256"
+(define (readline-patch version seqno sha256-bv)
+  "Return the origin of Readline patch SEQNO, with expected hash SHA256-BV"
   (origin
     (method url-fetch)
     (uri (patch-url version seqno))
-    (sha256 sha256)))
+    (sha256 sha256-bv)))
 
 (define-syntax-rule (patch-series version (seqno hash) ...)
   (list (readline-patch version seqno (base32 hash))

@@ 104,14 104,14 @@
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match))
 
-(define (qemu-patch commit file-name sha256)
+(define (qemu-patch commit file-name sha256-bv)
   "Return an origin for COMMIT."
   (origin
     (method url-fetch)
     (uri (string-append
           "http://git.qemu.org/?p=qemu.git;a=commitdiff_plain;h="
           commit))
-    (sha256 sha256)
+    (hash (content-hash sha256-bv sha256))
     (file-name file-name)))
 
 (define-public qemu

@@ 24,7 24,7 @@
 (define-module (guix import utils)
   #:use-module (guix base32)
   #:use-module ((guix build download) #:prefix build:)
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:hide (sha256))
   #:use-module (guix http-client)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix utils)

@@ 35,6 35,8 @@
   #: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)


@@ 44,16 46,23 @@
   #: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


@@ 157,15 166,79 @@
 ;;;
 ;;; 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))
+
+(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)
+          (bytevector->nix-base32-string (content-hash-value hash))))
+
+(set-record-type-printer! <content-hash> print-content-hash)
+
+
 ;; 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,


@@ 188,12 261,37 @@
   (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)))))
 


@@ 238,6 336,7 @@ name of its URI."
          ;; git, svn, cvs, etc. reference
          #f))))
 
+
 (define %supported-systems
   ;; This is the list of system types that are supported.  By default, we
   ;; expect all packages to build successfully here.


@@ 1388,14 1487,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

@@ 26,7 26,7 @@
   #:use-module (guix monads)
   #:use-module ((guix utils) #:select (substitute-keyword-arguments))
   #:use-module ((guix build utils) #:select (mkdir-p))
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:hide (sha256))
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 19,7 19,7 @@
 (define-module (test-challenge)
   #:use-module (guix tests)
   #:use-module (guix tests http)
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:prefix gcrypt:)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix derivations)


@@ 135,7 135,7 @@
     (mlet* %store-monad ((drv (gexp->derivation "something"
                                                 #~(list #$output #$text)))
                          (out -> (derivation->output-path drv))
-                         (hash -> (sha256 #vu8())))
+                         (hash -> (gcrypt:sha256 #vu8())))
       (with-derivation-narinfo* drv (sha256 => hash)
         (>>= (compare-contents (list out) (%test-substitute-urls))
              (match-lambda

@@ 23,7 23,7 @@
   #:use-module (guix grafts)
   #:use-module (guix store)
   #:use-module (guix utils)
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:prefix gcrypt:)
   #:use-module (guix base32)
   #:use-module (guix tests)
   #:use-module (guix tests http)


@@ 215,7 215,7 @@
                               #:env-vars `(("url"
                                             . ,(object->string (%local-url))))
                               #:hash-algo 'sha256
-                              #:hash (sha256 (string->utf8 text)))))
+                              #:hash (gcrypt:sha256 (string->utf8 text)))))
         (and (build-derivations %store (list drv))
              (string=? (call-with-input-file (derivation->output-path drv)
                          get-string-all)


@@ 230,7 230,7 @@
                             #:env-vars `(("url"
                                           . ,(object->string (%local-url))))
                             #:hash-algo 'sha256
-                            #:hash (sha256 (random-bytevector 100))))) ;wrong
+                            #:hash (gcrypt:sha256 (random-bytevector 100))))) ;wrong
       (guard (c ((store-protocol-error? c)
                  (string-contains (store-protocol-error-message c) "failed")))
         (build-derivations %store (list drv))


@@ 245,7 245,7 @@
                             #:env-vars `(("url"
                                           . ,(object->string (%local-url))))
                             #:hash-algo 'sha256
-                            #:hash (sha256 (random-bytevector 100)))))
+                            #:hash (gcrypt:sha256 (random-bytevector 100)))))
       (guard (c ((store-protocol-error? c)
                  (string-contains (store-protocol-error-message (pk c)) "failed")))
         (build-derivations %store (list drv))


@@ 273,7 273,7 @@
                           #:env-vars `(("url"
                                         . ,(object->string (%local-url))))
                           #:hash-algo 'sha256
-                          #:hash (sha256 (string->utf8 text)))))
+                          #:hash (gcrypt:sha256 (string->utf8 text)))))
     (and (with-http-server `((200 ,text))
            (build-derivations %store (list drv)))
          (with-http-server `((200 ,text))


@@ 317,7 317,7 @@
 (test-assert "fixed-output-derivation?"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (drv        (derivation %store "fixed"
                                  %bash `(,builder)
                                  #:sources (list builder)


@@ 329,10 329,10 @@
   (map (lambda (hash-algorithm)
          (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
                                             "echo -n hello > $out" '()))
-                (sha256  (sha256 (string->utf8 "hello")))
-                (hash    (bytevector-hash
+                (sha256  (gcrypt:sha256 (string->utf8 "hello")))
+                (hash    (gcrypt:bytevector-hash
                           (string->utf8 "hello")
-                          (lookup-hash-algorithm hash-algorithm)))
+                          (gcrypt:lookup-hash-algorithm hash-algorithm)))
                 (drv     (derivation %store
                                      (string-append
                                       "fixed-" (symbol->string hash-algorithm))


@@ 353,7 353,7 @@
                                         "echo -n hello > $out" '()))
          (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                         "echo hey; echo -n hello > $out" '()))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (drv1       (derivation %store "fixed"
                                  %bash `(,builder1)
                                  #:hash hash #:hash-algo 'sha256))


@@ 368,7 368,7 @@
 (test-assert "fixed-output derivation, recursive"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (drv        (derivation %store "fixed-rec"
                                  %bash `(,builder)
                                  #:sources (list builder)


@@ 390,7 390,7 @@
                                         "echo -n hello > $out" '()))
          (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                         "echo hey; echo -n hello > $out" '()))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (fixed1     (derivation %store "fixed"
                                  %bash `(,builder1)
                                  #:hash hash #:hash-algo 'sha256))


@@ 427,7 427,7 @@
                                         "echo -n hello > $out" '()))
          (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                         "echo hey; echo -n hello > $out" '()))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (fixed1     (derivation %store "fixed"
                                  %bash `(,builder1)
                                  #:hash hash #:hash-algo 'sha256))


@@ 680,7 680,7 @@
   (let* ((value (getenv "GUIX_STATE_DIRECTORY"))
          (drv   (derivation %store "leaked-env-vars" %bash
                             '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out")
-                            #:hash (sha256 (string->utf8 value))
+                            #:hash (gcrypt:sha256 (string->utf8 value))
                             #:hash-algo 'sha256
                             #:sources (list %bash)
                             #:leaked-env-vars '("GUIX_STATE_DIRECTORY"))))


@@ 1106,7 1106,7 @@
          (builder2   '(call-with-output-file (pk 'difference-here! %output)
                         (lambda (p)
                           (write "hello" p))))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (input1     (build-expression->derivation %store "fixed" builder1
                                                    #:hash hash
                                                    #:hash-algo 'sha256))


@@ 1127,7 1127,7 @@
          (builder2   '(call-with-output-file (pk 'difference-here! %output)
                         (lambda (p)
                           (write "hello" p))))
-         (hash       (sha256 (string->utf8 "hello")))
+         (hash       (gcrypt:sha256 (string->utf8 "hello")))
          (input1     (build-expression->derivation %store "fixed" builder1
                                                    #:hash hash
                                                    #:hash-algo 'sha256))

@@ 162,7 162,11 @@ edges."
   (let-values (((backend nodes+edges) (make-recording-backend)))
     (let* ((m (lambda* (uri hash-type hash name #:key system)
                 (text-file "foo-1.2.3.tar.gz" "This is a fake!")))
-           (o (origin (method m) (uri "the-uri") (sha256 #vu8(0 1 2))))
+           (o (origin
+                (method m) (uri "the-uri")
+                (sha256
+                 (base32
+                  "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))))
            (p (dummy-package "p" (source o))))
       (run-with-store %store
         (export-graph (list p) 'port

@@ 29,7 29,7 @@
                 #:renamer (lambda (name)
                             (cond ((eq? name 'location) 'make-location)
                                   (else name))))
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:hide (sha256))
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix grafts)


@@ 51,6 51,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
+  #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 regex)


@@ 497,6 498,31 @@
                      (search-path %load-path "guix/base32.scm")
                    get-bytevector-all)))))
 
+(test-equal "package-source-derivation, origin, sha512"
+  "hello"
+  (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
+         (builder (add-text-to-store %store "my-fixed-builder.sh"
+                                     "echo -n hello > $out" '()))
+         (method  (lambda* (url hash-algo hash #:optional name
+                                #:rest rest)
+                    (and (eq? hash-algo 'sha512)
+                         (raw-derivation name bash (list builder)
+                                         #:sources (list builder)
+                                         #:hash hash
+                                         #:hash-algo hash-algo))))
+         (source  (origin
+                    (method method)
+                    (uri "unused://")
+                    (file-name "origin-sha512")
+                    (hash (content-hash
+                           (bytevector-hash (string->utf8 "hello")
+                                            (hash-algorithm sha512))
+                           sha512))))
+         (drv    (package-source-derivation %store source))
+         (output (derivation->output-path drv)))
+    (build-derivations %store (list drv))
+    (call-with-input-file output get-string-all)))
+
 (unless (network-reachable?) (test-skip 1))
 (test-equal "package-source-derivation, snippet"
   "OK"

@@ 22,7 22,7 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix monads)
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:prefix gcrypt:)
   #:use-module (guix base32)
   #:use-module (guix packages)
   #:use-module (guix derivations)


@@ 321,7 321,7 @@
                            #:env-vars `(("t2" . ,t2))))
            (o  (derivation->output-path d)))
       (with-derivation-narinfo d
-        (sha256 => (sha256 (string->utf8 t2)))
+        (sha256 => (gcrypt:sha256 (string->utf8 t2)))
         (references => (list t2))
 
         (equal? (references/substitutes s (list o t3 t2 t1))


@@ 940,7 940,7 @@
         (foldm %store-monad
                (lambda (item result)
                  (define ref-hash
-                   (let-values (((port get) (open-sha256-port)))
+                   (let-values (((port get) (gcrypt:open-sha256-port)))
                      (write-file item port)
                      (close-port port)
                      (get)))


@@ 1144,7 1144,7 @@
          (info (query-path-info %store item)))
     (and (equal? (path-info-references info) (list ref))
          (equal? (path-info-hash info)
-                 (sha256
+                 (gcrypt:sha256
                   (string->utf8
                    (call-with-output-string (cut write-file item <>))))))))