[bug#41382] [PATCH 0/6] Allow for a cryptographic hash function migration

["Ludovic Courtès" <ludo@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1410 bytes --]

Hello,

Ludovic Courtès <ludo@gnu.org> skribis:

> Another option would be to create a <hash> data type that specifies
> its algorithm and its value.  We’d replace the ‘sha256’ field with
> a ‘hash’ field of that type (in a backward-compatible way).  Thinking
> about it, this is perhaps the better option.

Here’s a v2 that does that: instead of adding a ‘sha512’ field to
<origin>, it replaces the ‘sha256’ field with ‘hash’ and introduces a
<content-hash> data type (similar to the <uuid> data type we have).

One can now write things like:

  (origin
    ;; …
    (hash (content-hash (base64 "…") sha512)))

Since it’s a bit verbose, one can also pass a literal string directly,
in which case it’s base32-decoded:

  (origin
    ;; …
    (hash (content-hash "…")))

‘content-hash’ uses macrology to validate as much as possible at
macro-expansion time.

There’s a compatibility ‘origin’ macro intended to allow people to keep
writing:

  (origin
    (url …)
    (method …)
    (sha256 …))

and to automatically “convert” the ‘sha256’ field specification to a
‘content-hash’.  Due to the way identifiers are matched, there are cases
where we can’t preserve the illusion of compatibility, as can be seen
with the patch below.  Perhaps that’s acceptable, though.

Thoughts?

Thanks,
Ludo’.


[-- Attachment #2: the patch --]
[-- Type: text/x-patch, Size: 21215 bytes --]

From 0736d19071cc898e30b0bf06b445e7434848c825 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 19 May 2020 15:55:08 +0200
Subject: [PATCH] packages: Introduce <content-hash> and use it in <origin>.

* guix/packages.scm (<content-hash>): New record type.
(define-content-hash-constructor, build-content-hash)
(content-hash): New macros.
(print-content-hash): New procedure.
(<origin>): Rename constructor to '%origin'.
[sha256]: Remove field.
[hash]: New field.  Adjust users.
(origin-compatibility-helper, origin): New macros.
(origin-sha256): New deprecated procedure.
(origin->derivation): Adjust accordingly.
* tests/packages.scm ("package-source-derivation, origin, sha512"): New
test.
* guix/tests.scm: Hide (gcrypt hash) 'sha256' for proper syntax
matching.
* gnu/packages/aspell.scm (aspell-dictionary)
(aspell-dict-ca, aspell-dict-it): Use 'hash' and 'content-hash' for
proper syntax matching.
* gnu/packages/bash.scm (bash-patch): Rename 'sha256' to 'sha256-bv'.
* gnu/packages/bootstrap.scm (bootstrap-executable): Rename 'sha256' to 'bv'.
* gnu/packages/readline.scm (readline-patch): Likewise.
* gnu/packages/virtualization.scm (qemu-patch): Rename 'sha256' to
'sha256-bv'.
* guix/import/utils.scm: Hide (gcrypt hash) 'sha256'.
---
 doc/guix.texi                   |  34 ++++++++-
 gnu/packages/aspell.scm         |   8 +-
 gnu/packages/bash.scm           |   8 +-
 gnu/packages/bootstrap.scm      |   6 +-
 gnu/packages/readline.scm       |   8 +-
 gnu/packages/virtualization.scm |   4 +-
 guix/import/utils.scm           |   2 +-
 guix/packages.scm               | 126 +++++++++++++++++++++++++++++---
 guix/tests.scm                  |   2 +-
 tests/packages.scm              |  28 ++++++-
 10 files changed, 192 insertions(+), 34 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fdd9622211..71b10a141d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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
diff --git a/gnu/packages/aspell.scm b/gnu/packages/aspell.scm
index 7550736c40..22256f750b 100644
--- a/gnu/packages/aspell.scm
+++ b/gnu/packages/aspell.scm
@@ -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"))))
 
diff --git a/gnu/packages/bash.scm b/gnu/packages/bash.scm
index 1b342827c5..311e07a944 100644
--- a/gnu/packages/bash.scm
+++ b/gnu/packages/bash.scm
@@ -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))
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index f58ce2de93..a3ecb6e692 100644
--- a/gnu/packages/bootstrap.scm
+++ b/gnu/packages/bootstrap.scm
@@ -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))))))))
 
 \f
 ;;;
diff --git a/gnu/packages/readline.scm b/gnu/packages/readline.scm
index 5f61dcb735..8a36883347 100644
--- a/gnu/packages/readline.scm
+++ b/gnu/packages/readline.scm
@@ -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))
diff --git a/gnu/packages/virtualization.scm b/gnu/packages/virtualization.scm
index c2025c4fbe..da110bf8c6 100644
--- a/gnu/packages/virtualization.scm
+++ b/gnu/packages/virtualization.scm
@@ -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
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 3809c3d074..0cfa1f8321 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -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)
diff --git a/guix/packages.scm b/guix/packages.scm
index c1c4805ae9..3d9988d836 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -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)
+
+\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,
@@ -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))))
 
+\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
diff --git a/guix/tests.scm b/guix/tests.scm
index 95a7d7c4b8..3ccf049a7d 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -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)
diff --git a/tests/packages.scm b/tests/packages.scm
index c528d2080c..4935d4503e 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -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"
-- 
2.26.2