From 6f5f43702f10a15f58df386d107d63843f788fe5 Mon Sep 17 00:00:00 2001
From: Chris Marusich
Date: Sat, 21 Oct 2017 14:40:58 -0700
Subject: [PATCH] Try to build a GuixSD docker image - currently fails
---
gnu/build/linux-boot.scm | 5 +-
gnu/build/vm.scm | 14 +++--
gnu/system/vm.scm | 158 ++++++++++++++++++++++++++++++++++++++++-------
guix/docker.scm | 6 +-
guix/scripts/pack.scm | 5 +-
guix/scripts/system.scm | 1 +
6 files changed, 161 insertions(+), 28 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/vm.scm b/gnu/system/vm.scm
index 3127b305e..5e3db23b3 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)
@@ -349,6 +353,111 @@ 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)
+ (inputs '()))
+ "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))))
+ (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
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs))
+ (graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #: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")
+ (mkdir-p root)
+ (initialize root)
+ (display "after initializing root\n")
+ (build-docker-image (string-append "/xchg/" #$name)
+ #$os-drv
+ #:closure "system"
+ #:symlinks '#$symlinks
+ #:compressor '#$(compressor-command compressor)
+ #:creation-time (make-time time-utc 0 1))))))
+ (expression->derivation-in-linux-vm
+ name
+ build
+ #:system system
+ #:make-disk-image? #f
+ #:single-file-output? #t
+ #:references-graphs inputs)))
+
;;;
;;; VM and disk images.
@@ -443,31 +552,38 @@ 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")
+ (display "made it to docker image part\n")
+ (os-docker-image #:name name
+ #:os-drv os-drv
+ #:register-closures? #t
+ #:inputs `(("system" ,os-drv))))
+ (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..64d92ce16 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)))
@@ -181,3 +182,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..392d2a3cc 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -640,6 +640,7 @@ any, are available. Raise an error if they're not."
(system-disk-image os
#:name (match 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