Make it possible to build GuixSD docker imagesdocker-system

7 files changed, 191 insertions, 40 deletions

diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index a1ff4dd1ea..f6354dabf8 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 7537f81509..19c47e1ffc 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 b592defa45..0814dab985 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
@@ -243,7 +245,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
@@ -318,6 +321,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 3ddb41d9a6..ce0ba4df2a 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 <http://bugs.gnu.org/15602>.
+                     (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.
@@ -444,31 +561,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 060232148e..98914f1a13 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 21fea446a6..8d8053fcac 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 e50f1d8ac7..a319692d7f 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))))