[bug#30572] [PATCH 5/7] guix: Rewrite build-docker-image to allow more paths.

[Chris Marusich]

* guix/docker.scm (build-docker-image): Rename "path" argument to
  "prefix" to reflect the fact that it is used as a prefix for the
  symlink targets.  Add the "paths" argument, and remove the "closure"
  argument, since it is now redundant.  Add a "transformations"
  argument.
* guix/scripts/pack.scm (docker-image): Read the profile's reference
  graph and provide its paths to build-docker-image via the new "paths"
  argument.
---
 guix/docker.scm       | 200 ++++++++++++++++++++++++++++++--------------------
 guix/scripts/pack.scm |   9 ++-
 2 files changed, 128 insertions(+), 81 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..a75534c33 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2018 Chris Marusich <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,9 +24,12 @@
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
-                          with-directory-excursion))
-  #:use-module (guix build store-copy)
+                          with-directory-excursion
+                          invoke))
   #: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 match)
   #:export (build-docker-image))
@@ -33,8 +37,7 @@
 ;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
 (module-use! (current-module) (resolve-interface '(json)))
 
-;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
-;; containing the closure at PATH.
+;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
   (compose bytevector->base16-string sha256 string->utf8))
 
@@ -102,82 +105,123 @@ return \"a\"."
     ((first rest ...)
      first)))
 
-(define* (build-docker-image image path
-                             #:key closure compressor
+(define* (build-docker-image image paths prefix
+                             #:key
                              (symlinks '())
+                             (transformations '())
                              (system (utsname:machine (uname)))
+                             compressor
                              (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).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
-describing symlinks to be created in the image, where each TARGET is relative
-to PATH.  SYSTEM is a GNU triplet (or prefix thereof) of the system the
-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
-        (closure (canonicalize-path closure))
-        (id (docker-id path))
-        (time (date->string (time-utc->date creation-time) "~4"))
-        (arch (let-syntax ((cond* (syntax-rules ()
-                                    ((_ (pattern clause) ...)
-                                     (cond ((string-prefix? pattern system)
-                                            clause)
-                                           ...
-                                           (else
-                                            (error "unsupported system"
-                                                   system)))))))
-                (cond* ("x86_64" "amd64")
-                       ("i686"   "386")
-                       ("arm"    "arm")
-                       ("mips64" "mips64le")))))
+  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
+must be a store path that is a prefix of any store paths in PATHS.
+
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
+created in the image, where each TARGET is relative to PREFIX.
+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
+non-empty directory, then its contents will be recursively added, as well.
+
+SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
+PATHS 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."
+  (define (sanitize path-fragment)
+    (escape-special-chars
+     ;; GNU tar strips the leading slash off of absolute paths before applying
+     ;; the transformations, so we need to do the same, or else our
+     ;; replacements won't match any paths.
+     (string-trim path-fragment #\/)
+     ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
+     ;; We also need to escape "/" because we use it as a delimiter.
+     "/*.^$[]\\"
+     #\\))
+  (define transformation->replacement
+    (match-lambda
+      ((old '-> new)
+       ;; See "(tar) transform" for details on the expression syntax.
+       (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
+  (define (transformations->expression transformations)
+    (let ((replacements (map transformation->replacement transformations)))
+      (string-append
+       ;; Avoid transforming link targets, since that would break some links
+       ;; (e.g., symlinks that point to an absolute store path).
+       "flags=rSH;"
+       (string-join replacements ";")
+       ;; Some paths might still have a leading path delimiter even after tar
+       ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
+       ;; strip any leading path delimiters that remain.
+       ";s,^//*,,")))
+  (define transformation-options
+    (if (eq? '() transformations)
+        '()
+        `("--transform" ,(transformations->expression transformations))))
+  (let* ((directory "/tmp/docker-image") ;temporary working directory
+         (id (docker-id prefix))
+         (time (date->string (time-utc->date creation-time) "~4"))
+         (arch (let-syntax ((cond* (syntax-rules ()
+                                     ((_ (pattern clause) ...)
+                                      (cond ((string-prefix? pattern system)
+                                             clause)
+                                            ...
+                                            (else
+                                             (error "unsupported system"
+                                                    system)))))))
+                 (cond* ("x86_64" "amd64")
+                        ("i686"   "386")
+                        ("arm"    "arm")
+                        ("mips64" "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
-
-    (and (with-directory-excursion directory
-           (mkdir id)
-           (with-directory-excursion id
-             (with-output-to-file "VERSION"
-               (lambda () (display schema-version)))
-             (with-output-to-file "json"
-               (lambda () (scm->json (image-description id time))))
-
-             ;; 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
-                                          items
-                                          (map symlink-source symlinks))))
-                    (for-each delete-file-recursively
-                              (map (compose topmost-component symlink-source)
-                                   symlinks)))))
-
-           (with-output-to-file "config.json"
-             (lambda ()
-               (scm->json (config (string-append id "/layer.tar")
-                                  time arch))))
-           (with-output-to-file "manifest.json"
-             (lambda ()
-               (scm->json (manifest path id))))
-           (with-output-to-file "repositories"
-             (lambda ()
-               (scm->json (repositories path id)))))
-
-         (and (zero? (apply system* "tar" "-C" directory "-cf" image
-                            `(,@%tar-determinism-options
-                              ,@(if compressor
-                                    (list "-I" (string-join compressor))
-                                    '())
-                              ".")))
-              (begin (delete-file-recursively directory) #t)))))
+    (with-directory-excursion directory
+      (mkdir id)
+      (with-directory-excursion id
+        (with-output-to-file "VERSION"
+          (lambda () (display schema-version)))
+        (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)
+
+        (apply invoke "tar" "-cf" "layer.tar"
+               `(,@transformation-options
+                 ,@%tar-determinism-options
+                 ,@paths
+                 ,@(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
+        ;; the path "/a" into "/".  The presence of "/" in the archive is
+        ;; probably benign, but it is definitely safe to remove it, so let's
+        ;; do that.  This fails when "/" is not in the archive, so use system*
+        ;; instead of invoke to avoid an exception in that case.
+        (system* "tar" "--delete" "/" "-f" "layer.tar")
+        (for-each delete-file-recursively
+                  (map (compose topmost-component symlink-source)
+                       symlinks)))
+
+      (with-output-to-file "config.json"
+        (lambda ()
+          (scm->json (config (string-append id "/layer.tar")
+                             time arch))))
+      (with-output-to-file "manifest.json"
+        (lambda ()
+          (scm->json (manifest prefix id))))
+      (with-output-to-file "repositories"
+        (lambda ()
+          (scm->json (repositories prefix id)))))
+
+    (apply invoke "tar" "-cf" image "-C" directory
+           `(,@%tar-determinism-options
+             ,@(if compressor
+                   (list "-I" (string-join compressor))
+                   '())
+             "."))
+    (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 64ed44460..fba17f8e5 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -235,6 +235,7 @@ the image."
   (define build
     (with-imported-modules `(,@(source-module-closure '((guix docker))
                                                       #:select? not-config?)
+                             (guix build store-copy)
                              ((guix config) => ,config))
       #~(begin
           ;; Guile-JSON is required by (guix docker).
@@ -242,13 +243,15 @@ the image."
            (string-append #+json "/share/guile/site/"
                           (effective-version)))
 
-          (use-modules (guix docker) (srfi srfi-19))
+          (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 
           (setenv "PATH" (string-append #$tar "/bin"))
 
-          (build-docker-image #$output #$profile
+          (build-docker-image #$output
+                              (call-with-input-file "profile"
+                                read-reference-graph)
+                              #$profile
                               #:system (or #$target (utsname:machine (uname)))
-                              #:closure "profile"
                               #:symlinks '#$symlinks
                               #:compressor '#$(compressor-command compressor)
                               #:creation-time (make-time time-utc 0 1)))))
-- 
2.15.1