From 25d5527b14302fc835af5c338bf37cf621c63a4e Mon Sep 17 00:00:00 2001 From: Chris Marusich Date: Sat, 21 Oct 2017 14:40:58 -0700 Subject: [PATCH] Make it possible to build GuixSD docker images --- gnu/build/linux-boot.scm | 5 +- gnu/build/vm.scm | 14 ++-- gnu/system/linux-initrd.scm | 12 ++-- gnu/system/vm.scm | 169 ++++++++++++++++++++++++++++++++++++++------ guix/docker.scm | 23 ++++-- guix/scripts/pack.scm | 5 +- guix/scripts/system.scm | 3 +- 7 files changed, 191 insertions(+), 40 deletions(-) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 3712abe91..37da5b217 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -117,8 +117,9 @@ with the given MAJOR number, starting with MINOR." "/") dir)) + (display "just before dev\n") (unless (file-exists? (scope "dev")) - (mkdir (scope "dev"))) + (mkdir (pk (scope "dev")))) ;; Make the device nodes for SCSI disks. (make-disk-device-nodes (scope "dev/sda") 8) @@ -138,6 +139,7 @@ with the given MAJOR number, starting with MINOR." (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2)) ;; Inputs (used by Xorg.) + (display "just before dev/input\n") (unless (file-exists? (scope "dev/input")) (mkdir (scope "dev/input"))) (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63)) @@ -171,6 +173,7 @@ with the given MAJOR number, starting with MINOR." (chmod (scope "dev/ptmx") #o666) ;; Create /dev/pts; it will be mounted later, at boot time. + (display "just before dev/pts\n") (unless (file-exists? (scope "dev/pts")) (mkdir (scope "dev/pts"))) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 7537f8150..19c47e1ff 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -294,11 +294,14 @@ it, run its initializer, and unmount it." (define* (root-partition-initializer #:key (closures '()) copy-closures? (register-closures? #t) - system-directory) + system-directory + (deduplicate? #t)) "Return a procedure to initialize a root partition. -If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's -store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition. +If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's +store. If DEDUPLICATE? is true, then also deduplicate files common to +CLOSURES and the rest of the store when registering the closures. If +COPY-CLOSURES? is true, copy all of CLOSURES to the partition. SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (lambda (target) (define target-store @@ -317,13 +320,16 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (unless copy-closures? ;; XXX: 'guix-register' wants to palpate the things it registers, so ;; bind-mount the store on the target. + (display "making target store directory\n") (mkdir-p target-store) + (display "bind-mounting\n") (mount (%store-directory) target-store "" MS_BIND)) (display "registering closures...\n") (for-each (lambda (closure) (register-closure target - (string-append "/xchg/" closure))) + (string-append "/xchg/" closure) + #:deduplicate? deduplicate?)) closures) (unless copy-closures? (umount target-store))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 948c543a1..698f0aa70 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -155,7 +155,8 @@ MODULES and taken from LINUX." (mapped-devices '()) (helper-packages '()) qemu-networking? - volatile-root?) + volatile-root? + (guile %guile-static-stripped)) "Return a monadic derivation that builds a raw initrd, with kernel modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified @@ -217,7 +218,8 @@ to it are lost." #:linux-module-directory '#$kodir #:qemu-guest-networking? #$qemu-networking? #:volatile-root? '#$volatile-root?))) - #:name "raw-initrd")) + #:name "raw-initrd" + #:guile guile)) (define* (file-system-packages file-systems #:key (volatile-root? #f)) "Return the list of statically-linked, stripped packages to check @@ -246,7 +248,8 @@ FILE-SYSTEMS." qemu-networking? volatile-root? (virtio? #t) - (extra-modules '())) + (extra-modules '()) + (guile %guile-static-stripped)) "Return a monadic derivation that builds a generic initrd, with kernel modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified @@ -321,6 +324,7 @@ loaded at boot time in the order in which they appear." #:mapped-devices mapped-devices #:helper-packages helper-packages #:qemu-networking? qemu-networking? - #:volatile-root? volatile-root?)) + #:volatile-root? volatile-root? + #:guile guile)) ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 3127b305e..b48a9a962 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -22,6 +22,7 @@ (define-module (gnu system vm) #:use-module (guix config) + #:use-module (guix docker) #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix derivations) @@ -29,13 +30,16 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix modules) + #:use-module (guix scripts pack) #:use-module ((gnu build vm) #:select (qemu-command)) #:use-module (gnu packages base) + #:use-module (gnu packages bootloaders) #:use-module (gnu packages cdrom) #:use-module (gnu packages guile) + #:autoload (gnu packages gnupg) (libgcrypt) #:use-module (gnu packages gawk) #:use-module (gnu packages bash) #:use-module (gnu packages less) @@ -116,7 +120,8 @@ (references-graphs #f) (memory-size 256) (disk-image-format "qcow2") - (disk-image-size 'guess)) + (disk-image-size 'guess) + (guile-for-initrd %guile-static-stripped)) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a derivation). The virtual machine runs with MEMORY-SIZE MiB of memory. In the virtual machine, EXP has access to all its inputs from the store; it should @@ -143,7 +148,8 @@ made available under the /xchg CIFS share." (base-initrd %linux-vm-file-systems #:linux linux #:virtio? #t - #:qemu-networking? #t)))) + #:qemu-networking? #t + #:guile guile-for-initrd)))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -349,6 +355,117 @@ the image." #:disk-image-format disk-image-format #:references-graphs inputs)) +(define* (os-docker-image #:key + (name "guixsd-docker-image") + os-drv + (system (%current-system)) + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (tar tar) + (register-closures? #t)) + "Build a docker image. OS-DRV is a derivation which builds the +operating system profile." + ;; FIXME: Honor LOCALSTATEDIR?. + (define not-config? + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + + (define config + ;; (guix config) module for consumption by (guix gcrypt). + (scheme-file "gcrypt-config.scm" + #~(begin + (define-module (guix config) + #:export (%libgcrypt)) + + ;; XXX: Work around . + (eval-when (expand load eval) + (define %libgcrypt + #+(file-append libgcrypt "/lib/libgcrypt")))))) + + (define json + ;; Pick the guile-json package that corresponds to the Guile used to build + ;; derivations. + (if (string-prefix? "2.0" (package-version (default-guile))) + guile2.0-json + guile-json)) + + (let ((name (string-append name ".tar" (compressor-extension compressor))) + (system-graph-name "system")) + (define build + (with-imported-modules `(,@(source-module-closure '((guix docker) + (gnu build vm) + (guix build utils) + (guix build syscalls)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + ;; Guile-JSON is required by (guix docker). + (add-to-load-path + (string-append #+json "/share/guile/site/" + (effective-version))) + (use-modules (gnu build vm) + (guix build utils) + (guix build syscalls) + (srfi srfi-26) + (ice-9 match) + (guix docker) + (srfi srfi-19)) + + (let* ((inputs + '#$(append (list tree parted e2fsprogs dosfstools tar) + (map canonical-package + (list sed grep coreutils findutils gawk)) + (if register-closures? (list guix) '()))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register '#$os-drv) + (initialize (root-partition-initializer + #:closures '(#$system-graph-name) + #:copy-closures? #f + #:register-closures? #$register-closures? + #:system-directory #$os-drv + #:deduplicate? #f)) + (root "/tmp/root")) + + (display "before set path\n") + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (system* "id") + (display "before initializing root\n") + (system* "df") + (mkdir-p root) + (initialize root) + (display "after initializing root, building docker image\n") + ;; Use a temporary directory inside xchg to avoid hitting space + ;; limitations in the initrd's root file system. + (let ((tmpdir "/xchg/tmp")) + (mkdir tmpdir) + ;; TODO: Put paths from outside of the store into the docker image. + ;; For example, /var/guix, /home, etc. + (build-docker-image + (string-append "/xchg/" #$name) ;; The output file. + #$os-drv + #:closure (string-append "/xchg/" #$system-graph-name) + #:symlinks '#$symlinks + #:compressor '#$(compressor-command compressor) + #:creation-time (make-time time-utc 0 1) + #:tmpdir tmpdir + #:extra-items-dir root) + (delete-file-recursively tmpdir)))))) + (expression->derivation-in-linux-vm + name + build + #:system system + #:make-disk-image? #f + #:single-file-output? #t + #:references-graphs `((,system-graph-name ,os-drv)) + #:guile-for-initrd guile-2.2 + #:memory-size 512))) + ;;; ;;; VM and disk images. @@ -443,31 +560,37 @@ to USB sticks meant to be read-only." (mlet* %store-monad ((os-drv (operating-system-derivation os)) (bootcfg (operating-system-bootcfg os))) - (if (string=? "iso9660" file-system-type) - (iso9660-image #:name name - #:file-system-label root-label - #:file-system-uuid root-uuid + (cond ((string=? "iso9660" file-system-type) + (iso9660-image #:name name + #:file-system-label root-label + #:file-system-uuid root-uuid + #:os-drv os-drv + #:register-closures? #t + #:bootcfg-drv bootcfg + #:bootloader (bootloader-configuration-bootloader + (operating-system-bootloader os)) + #:inputs `(("system" ,os-drv) + ("bootcfg" ,bootcfg)))) + ((string=? "docker" file-system-type) + (display "made it to docker image part\n") + (os-docker-image #:name name + #:os-drv os-drv + #:register-closures? #t)) + (else + (qemu-image #:name name #:os-drv os-drv - #:register-closures? #t #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os)) + (operating-system-bootloader os)) + #:disk-image-size disk-image-size + #:disk-image-format "raw" + #:file-system-type file-system-type + #:file-system-label root-label + #:file-system-uuid root-uuid + #:copy-inputs? #t + #:register-closures? #t #:inputs `(("system" ,os-drv) - ("bootcfg" ,bootcfg))) - (qemu-image #:name name - #:os-drv os-drv - #:bootcfg-drv bootcfg - #:bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os)) - #:disk-image-size disk-image-size - #:disk-image-format "raw" - #:file-system-type file-system-type - #:file-system-label root-label - #:file-system-uuid root-uuid - #:copy-inputs? #t - #:register-closures? #t - #:inputs `(("system" ,os-drv) - ("bootcfg" ,bootcfg))))))) + ("bootcfg" ,bootcfg)))))))) (define* (system-qemu-image os #:key diff --git a/guix/docker.scm b/guix/docker.scm index 060232148..98914f1a1 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -28,7 +28,8 @@ #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:export (build-docker-image)) + #:export (build-docker-image + raw-disk-image->docker-image)) ;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co. (module-use! (current-module) (resolve-interface '(json))) @@ -106,7 +107,9 @@ return \"a\"." #:key closure compressor (symlinks '()) (system (utsname:machine (uname))) - (creation-time (current-time time-utc))) + (creation-time (current-time time-utc)) + (tmpdir "/tmp") + extra-items-dir) "Write to IMAGE a Docker image archive from the given store PATH. The image contains the closure of PATH, as specified in CLOSURE (a file produced by #:references-graphs). SYMLINKS must be a list of (SOURCE -> TARGET) tuples @@ -116,7 +119,7 @@ binaries at PATH are for; it is used to produce metadata in the image. Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata." - (let ((directory "/tmp/docker-image") ;temporary working directory + (let ((directory (string-append tmpdir "/docker-image")) ;temporary working directory (closure (canonicalize-path closure)) (id (docker-id path)) (time (date->string (time-utc->date creation-time) "~4")) @@ -159,9 +162,14 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata." (append %tar-determinism-options items (map symlink-source symlinks)))) - (for-each delete-file-recursively - (map (compose topmost-component symlink-source) - symlinks))))) + (begin + (for-each delete-file-recursively + (map (compose topmost-component symlink-source) + symlinks)) + (zero? (apply system* "tar" "-C" extra-items-dir + "-rf" "layer.tar" + (append %tar-determinism-options + '(".")))))))) (with-output-to-file "config.json" (lambda () @@ -181,3 +189,6 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata." '()) "."))) (begin (delete-file-recursively directory) #t))))) + +(define* (raw-disk-image->docker-image raw-image) + (display "Doing the docker stuff!")) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 21fea446a..8d8053fca 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -41,7 +41,10 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (compressor? + #:export (%compressors + compressor-extension + compressor-command + compressor? lookup-compressor self-contained-tarball guix-pack)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e50f1d8ac..a319692d7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -638,8 +638,9 @@ any, are available. Raise an error if they're not." #:mappings mappings)) ((disk-image) (system-disk-image os - #:name (match file-system-type + #:name (match (pk file-system-type) ("iso9660" "image.iso") + ("docker" "docker-image") (_ "disk-image")) #:disk-image-size image-size #:file-system-type file-system-type)))) -- 2.14.2