09/12: pack: Honor symlinks in the Docker back-end.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 9e84ea3673f77ebe5c5e9ce39fbcdb6d7bc8a06f
Author: Ludovic Courtès <address@hidden>
Date:   Thu Mar 16 22:40:06 2017 +0100

    pack: Honor symlinks in the Docker back-end.
    
    * guix/docker.scm (symlink-source, topmost-component): New procedures.
    (build-docker-image): Add #:symlinks parameter and honor it.  Remove
    hard-coded /bin symlink.
    * guix/scripts/pack.scm (docker-image): Pass #:symlinks to
    'build-docker-image'.
---
 guix/docker.scm       | 46 ++++++++++++++++++++++++++++++++++++----------
 guix/scripts/pack.scm |  3 ++-
 2 files changed, 38 insertions(+), 11 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 9b7a28f..290ad3d 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -21,7 +21,8 @@
   #:use-module (guix hash)
   #:use-module (guix base16)
   #:use-module ((guix build utils)
-                #:select (delete-file-recursively
+                #:select (mkdir-p
+                          delete-file-recursively
                           with-directory-excursion))
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-19)
@@ -89,14 +90,30 @@
   '("--sort=name" "address@hidden"
     "--owner=root:0" "--group=root:0"))
 
+(define symlink-source
+  (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)))
+
 (define* (build-docker-image image path
                              #:key closure compressor
+                             (symlinks '())
                              (creation-time (current-time time-utc)))
   "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).  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."
+#:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
+describing symlinks to be created in the image, where each TARGET is relative
+to PATH.
+
+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
         (closure (canonicalize-path closure))
         (id (docker-id path))
@@ -110,9 +127,6 @@ creation time in metadata."
     (mkdir directory)
 
     (and (with-directory-excursion directory
-           ;; Add symlink from /bin to /gnu/store/.../bin
-           (symlink (string-append path "/bin") "bin")
-
            (mkdir id)
            (with-directory-excursion id
              (with-output-to-file "VERSION"
@@ -120,13 +134,25 @@ creation time in metadata."
              (with-output-to-file "json"
                (lambda () (scm->json (image-description id time))))
 
-             ;; Wrap it up
+             ;; Wrap it up.
              (let ((items (call-with-input-file closure
                             read-reference-graph)))
+               ;; Create SYMLINKS.
+               (for-each (match-lambda
+                           ((source '-> target)
+                            (let ((source (string-trim source #\/)))
+                              (mkdir-p (dirname source))
+                              (symlink (string-append path "/" target)
+                                       source))))
+                         symlinks)
+
                (and (zero? (apply system* "tar" "-cf" "layer.tar"
                                   (append %tar-determinism-options
-                                          (cons "../bin" items))))
-                    (delete-file "../bin"))))
+                                          items
+                                          (map symlink-source symlinks))))
+                    (for-each delete-file-recursively
+                              (map (compose topmost-component symlink-source)
+                                   symlinks)))))
 
            (with-output-to-file "config.json"
              (lambda ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 694b2f2..edeb82f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -189,7 +189,7 @@ added to the pack."
   "Return a derivation to construct a Docker image of PROFILE.  The
 image is a tarball conforming to the Docker Image Specification, compressed
 with COMPRESSOR.  It can be passed to 'docker load'."
-  ;; FIXME: Honor SYMLINKS and LOCALSTATEDIR?.
+  ;; FIXME: Honor LOCALSTATEDIR?.
   (define not-config?
     (match-lambda
       (('guix 'config) #f)
@@ -227,6 +227,7 @@ with COMPRESSOR.  It can be passed to 'docker load'."
 
           (build-docker-image #$output #$profile
                               #:closure "profile"
+                              #:symlinks '#$symlinks
                               #:compressor '#$(compressor-command compressor)
                               #:creation-time (make-time time-utc 0 1)))))