diff options
| -rw-r--r-- | guix/docker.scm | 46 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 3 |
2 files changed, 38 insertions, 11 deletions
diff --git a/guix/docker.scm b/guix/docker.scm index 9b7a28f6f3..290ad3dcf1 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" "--mtime=@1" "--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 694b2f2aee..edeb82fafd 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))))) |