From 2b7c89f4fcc5e1607e153939d54d32aeaf494ca9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 27 Aug 2019 11:02:14 +0200
Subject: docker: Take a list of directives instead of a list of symlinks.

* guix/docker.scm (symlink-source, topmost-component): Remove.
(directive-file): New procedure.
(build-docker-image): Remove #:symlinks and add #:extra-files.
Make a sub-directory "extra" and call 'evaluate-populate-directive' for
EXTRA-FILES in that directory.
* guix/scripts/pack.scm (docker-image)[build](symlink->directives,
directives): New procedures.
Pass #:extra-files instead of #:symlinks to 'build-docker-image'.
---
 guix/docker.scm | 68 +++++++++++++++++++++++++++------------------------------
 1 file changed, 32 insertions(+), 36 deletions(-)

(limited to 'guix/docker.scm')

diff --git a/guix/docker.scm b/guix/docker.scm
index c598a073f6..757bdeb458 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -28,11 +28,13 @@
                           invoke))
   #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module ((texinfo string-utils)
                 #:select (escape-special-chars))
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:export (build-docker-image))
 
@@ -99,21 +101,18 @@
   '("--sort=name" "--mtime=@1"
     "--owner=root:0" "--group=root:0"))
 
-(define symlink-source
+(define directive-file
+  ;; Return the file or directory created by a 'evaluate-populate-directive'
+  ;; directive.
   (match-lambda
     ((source '-> target)
-     (string-trim source #\/))))
-
-(define (topmost-component file)
-  "Return the topmost component of FILE.  For instance, if FILE is \"/a/b/c\",
-return \"a\"."
-  (match (string-tokenize file (char-set-complement (char-set #\/)))
-    ((first rest ...)
-     first)))
+     (string-trim source #\/))
+    (('directory name _ ...)
+     (string-trim name #\/))))
 
 (define* (build-docker-image image paths prefix
                              #:key
-                             (symlinks '())
+                             (extra-files '())
                              (transformations '())
                              (system (utsname:machine (uname)))
                              database
@@ -133,8 +132,9 @@ entry point in the Docker image JSON structure.
 ENVIRONMENT must be a list of name/value pairs.  It specifies the environment
 variables that must be defined in the resulting image.
 
-SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
-created in the image, where each TARGET is relative to PREFIX.
+EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
+describing non-store files that must be created in the image.
+
 TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
 transform the PATHS.  Any path in PATHS that begins with OLD will be rewritten
 in the Docker image so that it begins with NEW instead.  If a path is a
@@ -199,25 +199,27 @@ SRFI-19 time-utc object, as the creation time in metadata."
         (with-output-to-file "json"
           (lambda () (scm->json (image-description id time))))
 
-        ;; Create SYMLINKS.
-        (for-each (match-lambda
-                    ((source '-> target)
-                     (let ((source (string-trim source #\/)))
-                       (mkdir-p (dirname source))
-                       (symlink (string-append prefix "/" target)
-                                source))))
-                  symlinks)
+        ;; Create a directory for the non-store files that need to go into the
+        ;; archive.
+        (mkdir "extra")
+
+        (with-directory-excursion "extra"
+          ;; Create non-store files.
+          (for-each (cut evaluate-populate-directive <> "./")
+                    extra-files)
 
-        (when database
-          ;; Initialize /var/guix, assuming PREFIX points to a profile.
-          (install-database-and-gc-roots "." database prefix))
+          (when database
+            ;; Initialize /var/guix, assuming PREFIX points to a profile.
+            (install-database-and-gc-roots "." database prefix))
+
+          (apply invoke "tar" "-cf" "../layer.tar"
+                 `(,@transformation-options
+                   ,@%tar-determinism-options
+                   ,@paths
+                   ,@(scandir "."
+                              (lambda (file)
+                                (not (member file '("." ".."))))))))
 
-        (apply invoke "tar" "-cf" "layer.tar"
-               `(,@transformation-options
-                 ,@%tar-determinism-options
-                 ,@paths
-                 ,@(if database '("var") '())
-                 ,@(map symlink-source symlinks)))
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
         ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
@@ -231,13 +233,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
           (lambda ()
             (system* "tar" "--delete" "/" "-f" "layer.tar")))
 
-        (for-each delete-file-recursively
-                  (map (compose topmost-component symlink-source)
-                       symlinks))
-
-        ;; Delete /var/guix.
-        (when database
-          (delete-file-recursively "var")))
+        (delete-file-recursively "extra"))
 
       (with-output-to-file "config.json"
         (lambda ()
-- 
cgit v1.2.3