diff options
| -rw-r--r-- | guix/docker.scm | 200 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 9 |
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))))) |