[bug#41382] [PATCH 5/6] packages: Add 'sha512' optional field to <origin>.

[Ludovic Courtès]

* guix/packages.scm (<origin>)[sha512]: New field.
(print-origin): Honor it.
(origin->derivation): Likewise.
* tests/packages.scm ("package-source-derivation, origin, sha512"): New
test.
* doc/guix.texi (origin Reference): Document 'sha512'.
---
 doc/guix.texi      |  8 +++++++-
 guix/packages.scm  | 25 ++++++++++++++-----------
 tests/packages.scm | 26 ++++++++++++++++++++++++++
 3 files changed, 47 insertions(+), 12 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fdd9622211..50d7eb7a43 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5966,10 +5966,16 @@ 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
+@itemx @code{sha512}
+A bytevector containing the SHA-256 (respectively SHA-512) hash of the source. 
 Typically the
 @code{base32} form is used here to generate the bytevector from a
 base-32 string.
 
+One of these fields must be a bytevector while the others can be
+@code{#f}.  When several hashes are provided, the ``strongest'' is used
+when computing the underlying fixed-output derivation
+(@pxref{Derivations}).
+
 You can obtain this information using @code{guix download}
 (@pxref{Invoking guix download}) or @code{guix hash} (@pxref{Invoking
 guix hash}).
diff --git a/guix/packages.scm b/guix/packages.scm
index 3fff50a6e8..7cf4c9c3e6 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -164,6 +164,7 @@
   (uri       origin-uri)                          ; string
   (method    origin-method)                       ; procedure
   (sha256    origin-sha256)                       ; bytevector
+  (sha512    origin-sha512 (default #f))          ; bytevector | #f
   (file-name origin-file-name (default #f))       ; optional file name
 
   ;; Patches are delayed so that the 'search-patch' calls are made lazily,
@@ -189,9 +190,9 @@
 (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 sha256 sha512 file-name patches)
      (simple-format port "#<origin ~s ~a ~s ~a>"
-                    uri (bytevector->base32-string sha256)
+                    uri (bytevector->base32-string (or sha512 sha256))
                     (force patches)
                     (number->string (object-address origin) 16)))))
 
@@ -1381,18 +1382,20 @@ 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 sha256 sha512 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
+     (let ((algorithm (if sha512 'sha512 'sha256)))
+       (method uri algorithm (or sha512 sha256) name #:system system)))
+    (($ <origin> uri method sha256 sha512 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))
-                         (guile  (package->derivation (or guile-for-build
-                                                          (default-guile))
-                                                      system
-                                                      #:graft? #f)))
+     (mlet* %store-monad ((algorithm -> (if sha512 'sha512 'sha256))
+                          (source (method uri algorithm (or sha512 sha256)
+                                          name #:system system))
+                          (guile  (package->derivation (or guile-for-build
+                                                           (default-guile))
+                                                       system
+                                                       #:graft? #f)))
        (patch-and-repack source patches
                          #:inputs inputs
                          #:snippet snippet
diff --git a/tests/packages.scm b/tests/packages.scm
index c528d2080c..06d41b5ce7 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -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")
+                    (sha256 (bytevector-hash (string->utf8 "hello")
+                                             (hash-algorithm sha256)))
+                    (sha512 (bytevector-hash (string->utf8 "hello")
+                                             (hash-algorithm 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"
-- 
2.26.2