From 3bccc5edacbef0204ca1d261da9621a044906028 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 11 Dec 2019 23:54:35 +0100
Subject: system: bootstrap: Compute and print the result's hash.

* gnu/packages/commencement.scm (%bootstrap-guile+guild): Make public.
[properties]: New field.
* gnu/system/bootstrap.scm (hash-script): New procedure.
(bootstrapping-os): Wrap OBJ in 'hash-script'.
---
 gnu/packages/commencement.scm |  5 +--
 gnu/system/bootstrap.scm      | 83 ++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 81 insertions(+), 7 deletions(-)

diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm
index 34584fbde5..bec91f306e 100644
--- a/gnu/packages/commencement.scm
+++ b/gnu/packages/commencement.scm
@@ -84,7 +84,7 @@ (define-module (gnu packages commencement)
 ;;;
 ;;; Code:
 
-(define %bootstrap-guile+guild
+(define-public %bootstrap-guile+guild
   ;; This package combines %bootstrap-guile with guild, which is not included
   ;; in %bootstrap-guile.  Guild is needed to build gash-boot and
   ;; gash-core-utils-boot because it is dependency of the Guile build system.
@@ -133,7 +133,8 @@ (define %bootstrap-guile+guild
     (synopsis "Bootstrap Guile plus Guild")
     (description "Bootstrap Guile with added Guild")
     (home-page #f)
-    (license (package-license guile-2.0))))
+    (license (package-license guile-2.0))
+    (properties '((hidden? . #t)))))
 
 (define mes-boot
   (package
diff --git a/gnu/system/bootstrap.scm b/gnu/system/bootstrap.scm
index c6eb10616e..19f309d506 100644
--- a/gnu/system/bootstrap.scm
+++ b/gnu/system/bootstrap.scm
@@ -21,7 +21,13 @@ (define-module (gnu system bootstrap)
   #:use-module (guix modules)
   #:use-module ((guix packages) #:select (default-guile))
   #:use-module ((guix self) #:select (make-config.scm))
-  #:use-module (gnu packages bootstrap)
+  #:use-module ((guix utils)
+                #:select (version-major+minor substitute-keyword-arguments))
+  #:use-module (guix packages)
+  #:use-module (guix build-system trivial)
+  #:use-module (gnu packages commencement)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages guile-xyz)
   #:use-module (gnu system)
   #:use-module (gnu system shadow)
   #:use-module (gnu system file-systems)
@@ -44,6 +50,73 @@ (define-module (gnu system bootstrap)
 ;;;
 ;;; Code:
 
+(define* (hash-script obj #:key (guile (default-guile)))
+  "Return a derivation that computes the SHA256 hash of OBJ, using Guile and
+only pure Guile code."
+  (define hashing
+    (package
+      (inherit guile-hashing)
+      (arguments
+       `(#:guile ,guile
+         ,@(package-arguments guile-hashing)))
+      (native-inputs `(("guile" ,guile)))))
+
+  (define build
+    ;; Compute and display the SHA256 of OBJ.  Do that in pure Scheme: it's
+    ;; slower, but removes the need for a full-blown C compiler and GNU
+    ;; userland to get libgcrypt, etc.
+    (with-extensions (list hashing)
+      (with-imported-modules (source-module-closure
+                              '((guix serialization)))
+        #~(begin
+            (use-modules (hashing sha-2)
+                         (guix serialization)
+                         (rnrs io ports)
+                         (rnrs bytevectors)
+                         (ice-9 match))
+
+            (define (port-sha256 port)
+              ;; Return the SHA256 of the data read from PORT.
+              (define bv (make-bytevector 65536))
+              (define hash (make-sha-256))
+
+              (let loop ()
+                (match (get-bytevector-n! port bv 0
+                                          (bytevector-length bv))
+                  ((? eof-object?)
+                   (sha-256-finish! hash)
+                   hash)
+                  (n
+                   (sha-256-update! hash bv 0 n)
+                   (loop)))))
+
+            (define (file-sha256 file)
+              ;; Return the SHA256 of FILE.
+              (call-with-input-file file port-sha256))
+
+            ;; Serialize OBJ as a nar.  XXX: We should avoid writing to disk
+            ;; as this might be a tmpfs.
+            (call-with-output-file "nar"
+              (lambda (port)
+                (write-file #$obj port)))
+
+            ;; Compute, display, and store the hash of OBJ.
+            (let ((hash (file-sha256 "nar")))
+              (call-with-output-file #$output
+                (lambda (result)
+                  (for-each (lambda (port)
+                              (format port "~a\t~a~%"
+                                      (sha-256->string hash)
+                                      #$obj))
+                            (list (current-output-port)
+                                  result)))))))))
+
+  (computed-file "build-result-hashes" build
+                 #:guile guile
+                 #:options
+                 `(#:effective-version
+                   ,(version-major+minor (package-version guile)))))
+
 (define* (build-script obj #:key (guile (default-guile)))
   "Return a build script that builds OBJ, an arbitrary lowerable object such
 as a package, and all its dependencies.  The script essentially unrolls the
@@ -143,7 +216,6 @@ (define these-are-the-sources-we-need
                                     (format #t "~%Congratulations!~%")
                                     (sleep 3600)))
                             port)
-              ;; TODO: Print a hash or something at the end?
               (chmod port #o555))))))
 
   (computed-file "build.scm" emit-script
@@ -181,9 +253,10 @@ (define (bootstrapping-os obj)
     ;; includes all the source code (tarballs) necessary to build them.
     (initrd (lambda (fs . rest)
               (expression->initrd
-               #~(execl #$(build-script obj #:guile %bootstrap-guile)
-                        "build")
-               #:guile %bootstrap-guile)))))
+               (let ((obj (hash-script obj #:guile %bootstrap-guile+guild)))
+                 #~(execl #$(build-script obj #:guile %bootstrap-guile+guild)
+                          "build"))
+               #:guile %bootstrap-guile+guild)))))
 
 ;; This operating system builds MES-BOOT from scratch.  That currently
 ;; requires ~5 GiB of RAM.  TODO: Should we mount a root file system on a hard
-- 
cgit v1.2.3