aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/docker.scm200
-rw-r--r--guix/scripts/pack.scm9
2 files changed, 128 insertions, 81 deletions
diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148e..a75534c33b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; 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 0ec1ef4d24..488638adc5 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -238,6 +238,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).
@@ -245,13 +246,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)))))