path: root/gnu/system/bootstrap.scm

;;; 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))