From 59912117d4b8852d9bf5a86dd909f1d4e71b0ad6 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Thu, 16 Dec 2021 08:51:56 +0100
Subject: system: image: Add docker support.

* gnu/system/image.scm (docker-image, docker-image-type): New variables.
(system-docker-image): New procedure.
(image->root-file-system): Add docker image support.
(system-image): Ditto.
---
 gnu/system/image.scm | 125 +++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 116 insertions(+), 9 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 4b6aaf2e32..42e215f614 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -36,12 +36,14 @@
   #:use-module (gnu services base)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
+  #:use-module (gnu system linux-container)
   #:use-module (gnu system uuid)
   #:use-module (gnu system vm)
   #:use-module (guix packages)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages disk)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages genimage)
@@ -67,6 +69,7 @@
 
             efi-disk-image
             iso9660-image
+            docker-image
             raw-with-offset-disk-image
 
             image-with-os
@@ -74,6 +77,7 @@
             qcow2-image-type
             iso-image-type
             uncompressed-iso-image-type
+            docker-image-type
             raw-with-offset-image-type
 
             image-with-label
@@ -127,6 +131,10 @@
            (label "GUIX_IMAGE")
            (flags '(boot)))))))
 
+(define docker-image
+  (image
+   (format 'docker)))
+
 (define* (raw-with-offset-disk-image #:optional (offset root-offset))
   (image
    (format 'disk-image)
@@ -179,6 +187,11 @@ set to the given OS."
                   (compression? #f))
                  <>))))
 
+(define docker-image-type
+  (image-type
+   (name 'docker)
+   (constructor (cut image-with-os docker-image <>))))
+
 (define raw-with-offset-image-type
   (image-type
    (name 'raw-with-offset)
@@ -220,8 +233,7 @@ set to the given OS."
 (define-syntax-rule (with-imported-modules* gexp* ...)
   (with-extensions gcrypt-sqlite3&co
     (with-imported-modules `(,@(source-module-closure
-                                '((gnu build vm)
-                                  (gnu build image)
+                                '((gnu build image)
                                   (gnu build bootloader)
                                   (gnu build hurd-boot)
                                   (gnu build linux-boot)
@@ -229,8 +241,7 @@ set to the given OS."
                                 #:select? not-config?)
                              ((guix config) => ,(make-config.scm)))
       #~(begin
-          (use-modules (gnu build vm)
-                       (gnu build image)
+          (use-modules (gnu build image)
                        (gnu build bootloader)
                        (gnu build hurd-boot)
                        (gnu build linux-boot)
@@ -337,6 +348,8 @@ used in the image."
                  (initializer image-root
                               #:references-graphs '#$graph
                               #:deduplicate? #f
+                              #:copy-closures? (not
+                                                #$(image-shared-store? image))
                               #:system-directory #$os
                               #:grub-efi #+grub-efi
                               #:bootloader-package
@@ -527,6 +540,97 @@ returns an image record where the first partition's label is set to <label>."
              (label label))
            others))))))
 
+
+;;
+;; Docker image.
+;;
+
+(define* (system-docker-image image
+                              #:key
+                              (name "docker-image"))
+  "Build a docker image for IMAGE.  NAME is the base name to use for the
+output file."
+  (define boot-program
+    ;; Program that runs the boot script of OS, which in turn starts shepherd.
+    (program-file "boot-program"
+                  #~(let ((system (cadr (command-line))))
+                      (setenv "GUIX_NEW_SYSTEM" system)
+                      (execl #$(file-append guile-3.0 "/bin/guile")
+                             "guile" "--no-auto-compile"
+                             (string-append system "/boot")))))
+
+  (define shared-network?
+    (image-shared-network? image))
+
+  (let* ((os (operating-system-with-gc-roots
+              (containerized-operating-system
+               (image-operating-system image) '()
+               #:shared-network?
+               shared-network?)
+              (list boot-program)))
+         (substitutable? (image-substitutable? image))
+         (register-closures? (has-guix-service-type? os))
+         (schema (and register-closures?
+                      (local-file (search-path %load-path
+                                               "guix/store/schema.sql"))))
+         (name (string-append name ".tar.gz"))
+         (graph "system-graph"))
+    (define builder
+      (with-extensions (cons guile-json-3         ;for (guix docker)
+                             gcrypt-sqlite3&co)   ;for (guix store database)
+        (with-imported-modules `(,@(source-module-closure
+                                    '((guix docker)
+                                      (guix store database)
+                                      (guix build utils)
+                                      (guix build store-copy)
+                                      (gnu build image))
+                                    #:select? not-config?)
+                                 ((guix config) => ,(make-config.scm)))
+          #~(begin
+              (use-modules (guix docker)
+                           (guix build utils)
+                           (gnu build image)
+                           (srfi srfi-19)
+                           (guix build store-copy)
+                           (guix store database))
+
+              ;; Set the SQL schema location.
+              (sql-schema #$schema)
+
+              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+              (setenv "GUIX_LOCPATH"
+                      #+(file-append glibc-utf8-locales "/lib/locale"))
+              (setlocale LC_ALL "en_US.utf8")
+
+              (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
+
+              (let ((image-root (string-append (getcwd) "/tmp-root")))
+                (mkdir-p image-root)
+                (initialize-root-partition image-root
+                                           #:references-graphs '(#$graph)
+                                           #:copy-closures? #f
+                                           #:register-closures? #$register-closures?
+                                           #:deduplicate? #f
+                                           #:system-directory #$os)
+                (build-docker-image
+                 #$output
+                 (cons* image-root
+                        (map store-info-item
+                             (call-with-input-file #$graph
+                               read-reference-graph)))
+                 #$os
+                 #:entry-point '(#$boot-program #$os)
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:transformations `((,image-root -> ""))))))))
+
+    (computed-file name builder
+                   ;; Allow offloading so that this I/O-intensive process
+                   ;; doesn't run on the build farm's head node.
+                   #:local-build? #f
+                   #:options `(#:references-graphs ((,graph ,os))
+                               #:substitutable? ,substitutable?))))
+
 
 ;;
 ;; Image creation.
@@ -534,10 +638,11 @@ returns an image record where the first partition's label is set to <label>."
 
 (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
-  (let ((format (image-format image)))
-    (if (eq? format 'iso9660)
-        "iso9660"
-        (partition-file-system (find-root-partition image)))))
+  (case (image-format image)
+    ((iso9660) "iso9660")
+    ((docker) "dummy")
+    (else
+     (partition-file-system (find-root-partition image)))))
 
 (define (root-size image)
   "Return the root partition size of IMAGE."
@@ -671,6 +776,8 @@ image, depending on IMAGE format."
                             #:register-closures? register-closures?
                             #:inputs `(("system" ,os)
                                        ("bootcfg" ,bootcfg))))
+       ((memq image-format '(docker))
+        (system-docker-image image*))
        ((memq image-format '(iso9660))
          (system-iso9660-image
           image*
-- 
cgit v1.2.3