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/local.mk

@@ -593,6 +593,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/system/shadow.scm				\
   %D%/system/uuid.scm				\
   %D%/system/vm.scm				\
+  %D%/system/bootstrap.scm			\
 						\
   %D%/machine.scm				\
   %D%/machine/digital-ocean.scm			\

gnu/packages/commencement.scm

@@ -84,6 +84,58 @@
 ;;;
 ;;; Code:
 
+(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.
+  (package
+    (name "guile-bootstrap+guild")
+    (version "2.0")
+    (source (bootstrap-origin (package-source guile-2.0)))
+    (native-inputs `(("bash" ,(bootstrap-executable "bash" (%current-system)))
+                     ("tar" ,(bootstrap-executable "tar" (%current-system)))
+                     ("xz" ,(bootstrap-executable "xz" (%current-system)))
+                     ("guile" ,%bootstrap-guile)))
+    (build-system trivial-build-system)
+    (arguments
+     `(#:guile ,%bootstrap-guile
+       #:modules ((guix build utils))
+       #:builder (begin
+                   (use-modules (guix build utils))
+                   (let ((guile-source (assoc-ref %build-inputs "source"))
+                         (bin (string-append (getcwd) "/bin"))
+                         (tar (assoc-ref %build-inputs "tar"))
+                         (xz (assoc-ref %build-inputs "xz")))
+                     (mkdir-p bin)
+                     (setenv "PATH" bin)
+                     (with-directory-excursion bin
+                       (copy-file tar "tar")
+                       (copy-file xz "xz")
+                       (setenv "PATH" bin))
+                     (let* ((out (assoc-ref %outputs "out"))
+                            (out-bin (string-append out "/bin"))
+                            (guile (assoc-ref %build-inputs "guile"))
+                            (bash (assoc-ref %build-inputs "bash")))
+                       (mkdir-p out-bin)
+                       (with-directory-excursion out-bin
+                         (symlink (string-append guile "/bin/guile")
+                                  "guile")
+                         (invoke "tar" "--strip-components=2"
+                                 "-xvf" guile-source
+                                 (string-append "guile-"
+                                                ,(package-version guile-2.0)
+                                                "/meta/guild.in"))
+                         (copy-file "guild.in" "guild")
+                         (substitute* "guild"
+                           (("#!/bin/sh") (string-append "#! " bash))
+                           (("@installed_guile@") (string-append out-bin "/guile")))
+                         (chmod "guild" #o555)))))))
+    (synopsis "Bootstrap Guile plus Guild")
+    (description "Bootstrap Guile with added Guild")
+    (home-page #f)
+    (license (package-license guile-2.0))
+    (properties '((hidden? . #t)))))
+
 (define mes-boot
   (package
     (inherit mes)

gnu/system/bootstrap.scm

@@ -0,0 +1,264 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system bootstrap)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module ((guix packages) #:select (default-guile))
+  #:use-module ((guix self) #:select (make-config.scm))
+  #: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)
+  #:use-module (gnu system linux-initrd)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu bootloader grub)
+  #:use-module (ice-9 match))
+
+;;; Commentary:
+;;;
+;;; This file provides tooling to build an operating system image that builds
+;;; a set of derivations straight from the initrd.  This allows us to perform
+;;; builds in an environment where the trusted computing base (TCB) has been
+;;; stripped from guix-daemon, shepherd, and other things.
+;;;
+;;; Run "guix system vm gnu/system/bootstrap.scm" to get a VM that runs this
+;;; OS (pass "-m 5000" or so so it has enough memory), or use "guix system
+;;; disk-image", write it to a USB stick, and get it running on the bare
+;;; metal!
+;;;
+;;; 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
+build loop normally performed by 'guix-daemon'."
+  (define select?
+    ;; Select every module but (guix config) and non-Guix modules.
+    (match-lambda
+      (('guix 'config) #f)
+      (('guix _ ...)   #t)
+      (_               #f)))
+
+  (define fake-gcrypt-hash
+    ;; Fake (gcrypt hash) module: since (gcrypt hash) is pulled in and not
+    ;; actually used, plus GUILE may be a statically-linked Guile not capable
+    ;; of loading libgcrypt, it's OK to just provide a phony module.
+    (scheme-file "hash.scm"
+                 #~(define-module (gcrypt hash)
+                     #:export (sha1 sha256))))
+
+  (define emit-script
+    (with-imported-modules `(((guix config) => ,(make-config.scm))
+                             ((gcrypt hash) => ,fake-gcrypt-hash)
+
+                             ,@(source-module-closure
+                                `((guix derivations))
+                                #:select? select?))
+      #~(begin
+          (use-modules (guix derivations)
+                       (srfi srfi-1)
+                       (ice-9 match)
+                       (ice-9 pretty-print))
+
+          (define drv
+            ;; Load the derivation for OBJ.
+            (read-derivation-from-file #$(raw-derivation-file obj)))
+
+          (define (derivation->script drv)
+            ;; Return a snippet that "manually" builds DRV.
+            `(begin
+               ;; XXX: Drop part of DRV's file name to not cause the
+               ;; daemon to detect the reference and go wrong ("path `%1%'
+               ;; is not valid").
+               (format #t "~%~%build-started ...~a~%~%"
+                       ,(string-drop (basename
+                                      (derivation-file-name
+                                       drv))
+                                     10))
+
+               ;; XXX: Use the same directory name as the daemon?
+               (mkdir-p "/tmp/guix-build")
+               (chdir "/tmp/guix-build")
+               (environ ',(map (match-lambda
+                                 ((key . value)
+                                  (string-append key "=" value)))
+                               (derivation-builder-environment-vars drv)))
+               (let ((result (system* ,(derivation-builder drv)
+                                      ,@(derivation-builder-arguments
+                                         drv))))
+                 (chdir "/")
+                 (delete-file-recursively "/tmp/guix-build")
+                 (zero? result))))
+
+          (define graph
+            ;; Closure of the derivation for OBJ.  This does _not_ contain
+            ;; fixed-output derivations, but it contains sources.
+            (filter-map (lambda (file)
+                          (and (string-suffix? ".drv" file)
+                               (let* ((drv (read-derivation-from-file file))
+                                      (out (derivation->output-path drv)))
+                                 ;; GUILE itself is already in the initrd
+                                 ;; because it's executing this program.
+                                 ;; Thus, don't try to "build" it again.
+                                 (and (not (string=? out #$guile))
+                                      drv))))
+                        (call-with-input-file #$(raw-derivation-closure obj)
+                          read)))
+
+          ;; Emit a script that builds OBJ and all its
+          ;; dependencies sequentially.
+          (call-with-output-file #$output
+            (lambda (port)
+              (format port "#!~a/bin/guile --no-auto-compile~%!#~%" #$guile)
+              (pretty-print '(begin
+                               (use-modules (srfi srfi-1)
+                                            (ice-9 rdelim))
+
+                               ;; Ensure the script refers to all the
+                               ;; sources of OBJ.
+                               (define these-are-the-sources-we-need
+                                 '#$(object-sources obj))
+                               (primitive-load
+                                #$(local-file "../../guix/build/utils.scm")))
+                            port)
+              (newline port)
+              (pretty-print `(and ,@(map derivation->script graph)
+                                  (begin
+                                    (format #t "~%Congratulations!~%")
+                                    (sleep 3600)))
+                            port)
+              (chmod port #o555))))))
+
+  (computed-file "build.scm" emit-script
+                 #:guile guile))
+
+(define (bootstrapping-os obj)
+  "Return an operating system that starts building OBJ and all its
+dependencies, from scratch, as it boots."
+  (operating-system
+    (host-name "komputilo")
+    (timezone "Africa/Casablanca")
+    (locale "en_US.UTF-8")
+
+    (bootloader (bootloader-configuration
+                 (bootloader grub-bootloader)
+                 (target "/dev/sdX")))
+    ;; TODO: Use a minimal Linux-libre kernel.
+    (file-systems (cons (file-system
+                          (device (file-system-label "my-root"))
+                          (mount-point "/")
+                          (type "ext4"))
+                        %base-file-systems))
+
+    ;; Network access and all that are not needed.
+    (firmware '())
+
+    (users (cons (user-account
+                  (name "vagneke")
+                  (comment "The Bootstrapper")
+                  (group "users"))
+                 %base-user-accounts))
+
+    ;; Use a special initrd that builds it all!  The initrd contains the
+    ;; script returned by 'build-script' and all its dependencies, which
+    ;; includes all the source code (tarballs) necessary to build them.
+    (initrd (lambda (fs . rest)
+              (expression->initrd
+               (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
+;; disk or...?
+(bootstrapping-os (@@ (gnu packages commencement) mes-boot))

guix/derivations.scm

@@ -305,10 +305,13 @@ result is the set of prerequisites of DRV not already in valid."
           sub-drvs))))
 
 (define* (derivation-input-fold proc seed inputs
-                                #:key (cut? (const #f)))
+                                #:key
+                                (cut? (const #f))
+                                (skip-dependencies? (const #f)))
   "Perform a breadth-first traversal of INPUTS, calling PROC on each input
-with the current result, starting from SEED.  Skip recursion on inputs that
+with the current result, starting from SEED.  Skip inputs that match CUT? as
-match CUT?."
+well as all their dependencies; skip the dependencies of inputs that match
+SKIP-DEPENDENCIES?, but not the input itself."
   (let loop ((inputs inputs)
              (result seed)
              (visited (set)))
@@ -323,7 +326,9 @@ match CUT?."
                 (loop rest result (set-insert key visited)))
                (else
                 (let ((drv (derivation-input-derivation input)))
-                  (loop (append (derivation-inputs drv) rest)
+                  (loop (if (skip-dependencies? input)
+                            rest
+                            (append (derivation-inputs drv) rest))
                         (proc input result)
                         (set-insert key visited))))))))))
 

guix/gexp.scm

@@ -82,6 +82,12 @@
             raw-derivation-file
             raw-derivation-file?
 
+            raw-derivation-closure
+            raw-derivation-closure?
+
+            object-sources
+            object-sources?
+
             load-path-expression
             gexp-modules
 
@@ -291,6 +297,86 @@ The expander specifies how an object is converted to its sexp representation."
                     (derivation-file-name lowered)
                     lowered)))
 
+;; File containing the closure of a raw .drv file, in topological order.  This
+;; works around a deficiency of #:references-graphs that can produce the
+;; reference graph of an output, but not that of a raw .drv file.
+(define-record-type <raw-derivation-closure>
+  (raw-derivation-closure obj)
+  raw-derivation-closure?
+  (obj  raw-derivation-closure-object))
+
+(define sorted-references
+  (store-lift (lambda (store item)
+                (define (fixed-output? file)
+                  (and (string-suffix? ".drv" file)
+                       (let ((drv (read-derivation-from-file file)))
+                         (fixed-output-derivation? drv))))
+
+                (topologically-sorted store (list item)
+                                      #:cut? fixed-output?))))
+
+(define-gexp-compiler (raw-derivation-closure-compiler
+                       (obj <raw-derivation-closure>)
+                       system target)
+  (mlet %store-monad ((obj (lower-object
+                            (raw-derivation-closure-object obj)
+                            system #:target target)))
+    (if (derivation? obj)
+        (mlet %store-monad ((refs (sorted-references (derivation-file-name obj))))
+          (text-file "graph" (object->string refs)))
+        (return obj))))
+
+;; Representation of all the sources and fixed-output derivations OBJ refers
+;; to, directly or indirectly.
+(define-record-type <object-sources>
+  (object-sources obj)
+  object-sources?
+  (obj   object-sources-object))
+
+(define-gexp-compiler (object-sources-compiler (obj <object-sources>)
+                                               system target)
+  (define (derivation-fixed-output-requirements drv)
+    (derivation-input-fold (lambda (input result)
+                             (let ((drv (derivation-input-derivation input)))
+                               (if (fixed-output-derivation? drv)
+                                   (cons drv result)
+                                   result)))
+                           '()
+                           (derivation-inputs drv)
+
+                           ;; Skip the dependencies of fixed-output
+                           ;; derivations (e.g., 'git' for a 'git-fetch'
+                           ;; derivation.)
+                           #:skip-dependencies?
+                           (compose fixed-output-derivation?
+                                    derivation-input-derivation)))
+
+  (define (derivation-recursive-sources drv)
+    (delete-duplicates
+     (derivation-input-fold (lambda (input result)
+                              (let ((drv (derivation-input-derivation input)))
+                                (append (derivation-sources drv)
+                                        result)))
+                            '()
+                            (derivation-inputs drv))))
+
+  (mlet %store-monad ((obj (lower-object (object-sources-object obj)
+                                         system #:target target)))
+    (if (derivation? obj)
+        (let* ((drvs    (derivation-fixed-output-requirements obj))
+               (sources (derivation-recursive-sources obj))
+               (pairs   (append (map (lambda (drv)
+                                       `(,(store-path-package-name
+                                           (derivation-file-name drv))
+                                         ,drv))
+                                     drvs)
+                                (map (lambda (file)
+                                       `(,(basename file) ,file))
+                                     sources)))
+               (union   (file-union "sources" pairs)))
+          (lower-object union system #:target target))
+        (return obj))))
+
 
 ;;;
 ;;; File declarations.

guix/monads.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -279,11 +279,16 @@ more optimizations."
   ;; does not get redefined.  This works around a race condition in a
   ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>.
   (eval-when (load eval expand compile)
-    (define name
+    (cond-expand
-      (if (module-locally-bound? (current-module) 'name)
+      ((not guile-2.2)
-          (module-ref (current-module) 'name)
+       ;; The trick below doesn't work on Guile 2.0.
-          (make-syntax-transformer 'name 'syntax-parameter
+       (define-syntax-parameter name proc))
-                                   (list proc))))))
+      (else
+       (define name
+         (if (module-locally-bound? (current-module) 'name)
+             (module-ref (current-module) 'name)
+             (make-syntax-transformer 'name 'syntax-parameter
+                                      (list proc))))))))
 
 (define-syntax-parameter-once >>=
   ;; The name 'bind' is already taken, so we choose this (obscure) symbol.

guix/serialization.scm

@@ -287,6 +287,21 @@ order."
          string<?)
    string=?))
 
+(cond-expand
+  ((not guile-2.2)
+   ;; Guile 2.0 lacks 'define-values'.
+   (define-syntax define-values
+     (syntax-rules ()
+       ((_ (a b) exp)
+        (begin
+          (define a #f)
+          (define b #f)
+          (call-with-values (lambda () exp)
+            (lambda (x y)
+              (set! a x)
+              (set! b y))))))))
+  (else #t))
+
 (define* (write-file-tree file port
                           #:key
                           file-type+size

guix/store.scm

@@ -1378,9 +1378,10 @@ SEED."
 its references, recursively)."
   (fold-path store cons '() paths))
 
-(define (topologically-sorted store paths)
+(define* (topologically-sorted store paths #:key (cut? (const #f)))
   "Return a list containing PATHS and all their references sorted in
-topological order."
+topological order.  Skip store items that match CUT? as well as their
+dependencies."
   (define (traverse)
     ;; Do a simple depth-first traversal of all of PATHS.
     (let loop ((paths   paths)
@@ -1394,17 +1395,20 @@ topological order."
 
       (match paths
         ((head tail ...)
-         (if (visited? head)
+         (cond ((visited? head)
-             (loop tail visited result)
+                (loop tail visited result))
-             (call-with-values
+               ((cut? head)
-                 (lambda ()
+                (loop tail visited result))
-                   (loop (references store head)
+               (else
-                         (visit head)
+                (call-with-values
-                         result))
+                    (lambda ()
-               (lambda (visited result)
+                      (loop (references store head)
-                 (loop tail
+                            (visit head)
-                       visited
+                            result))
-                       (cons head result))))))
+                  (lambda (visited result)
+                    (loop tail
+                          visited
+                          (cons head result)))))))
         (()
          (values visited result)))))
 

guix/utils.scm

@@ -508,14 +508,17 @@ a character other than '@'."
 
 (define version-compare
   (let ((strverscmp
-         (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
+         ;; Delay symbol resolution so that this module can be used even on a
-                        (error "could not find `strverscmp' (from GNU libc)"))))
+         ;; statically-linked Guile.
-           (pointer->procedure int sym (list '* '*)))))
+         (delay
+           (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
+                          (error "could not find `strverscmp' (from GNU libc)"))))
+             (pointer->procedure int sym (list '* '*))))))
     (lambda (a b)
       "Return '> when A denotes a newer version than B,
 '< when A denotes a older version than B,
 or '= when they denote equal versions."
-      (let ((result (strverscmp (string->pointer a) (string->pointer b))))
+      (let ((result ((force strverscmp) (string->pointer a) (string->pointer b))))
         (cond ((positive? result) '>)
               ((negative? result) '<)
               (else '=))))))

tests/store.scm

@@ -388,6 +388,16 @@
          (s (topologically-sorted %store (list d))))
     (equal? s (list a b c d))))
 
+(test-assert "topologically-sorted, one item, cutting"
+  (let* ((a (add-text-to-store %store "a" "a"))
+         (b (add-text-to-store %store "b" "b" (list a)))
+         (c (add-text-to-store %store "c" "c" (list b)))
+         (d (add-text-to-store %store "d" "d" (list c)))
+         (s (topologically-sorted %store (list d)
+                                  #:cut?
+                                  (cut string-suffix? "-b" <>))))
+    (equal? s (list c d))))
+
 (test-assert "topologically-sorted, several items"
   (let* ((a  (add-text-to-store %store "a" "a"))
          (b  (add-text-to-store %store "b" "b" (list a)))