07/10: DRAFT system: Add (gnu system bootstrap).

[guix-commits]

civodul pushed a commit to branch wip-system-bootstrap
in repository guix.

commit de340bd1f2b43b7a1c04ab5c4d555ce9ab8f7881
Author: Ludovic Courtès <address@hidden>
Date:   Fri Dec 6 23:58:10 2019 +0100

    DRAFT system: Add (gnu system bootstrap).
    
    This allows us to perform arbitrary builds on a system that has no
    userland besides the build process itself, running as PID 1.
    
    Suggested by Vagrant Cascadian.
    
    DRAFT: The resulting system does build things, but this is all happening
    into memory, which may or may not be a problem (it allows us to not have
    disk drivers in the kernel!).  More importantly, it does not display
    anything upon completion, and the build result is lost as well.
    
    * gnu/system/bootstrap.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk             |   1 +
 gnu/system/bootstrap.scm | 191 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 192 insertions(+)

diff --git a/gnu/local.mk b/gnu/local.mk
index 83bba6b..3d54f7c 100644
--- a/gnu/local.mk
+++ b/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                        \
diff --git a/gnu/system/bootstrap.scm b/gnu/system/bootstrap.scm
new file mode 100644
index 0000000..c6eb106
--- /dev/null
+++ b/gnu/system/bootstrap.scm
@@ -0,0 +1,191 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 (gnu packages bootstrap)
+  #: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* (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)
+              ;; TODO: Print a hash or something at the end?
+              (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
+               #~(execl #$(build-script obj #:guile %bootstrap-guile)
+                        "build")
+               #:guile %bootstrap-guile)))))
+
+;; 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))