aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-08-27 11:02:14 +0200
committerLudovic Courtès <ludo@gnu.org>2019-08-27 12:20:44 +0200
commit2b7c89f4fcc5e1607e153939d54d32aeaf494ca9 (patch)
tree5d3758c60f3c1a7590bab497ea146234d0d09beb
parentb29d6abc8f0aa7cb358954d7f7a8d7ca49c29eea (diff)
downloadpatches-2b7c89f4fcc5e1607e153939d54d32aeaf494ca9.tar
patches-2b7c89f4fcc5e1607e153939d54d32aeaf494ca9.tar.gz
docker: Take a list of directives instead of a list of symlinks.
* guix/docker.scm (symlink-source, topmost-component): Remove. (directive-file): New procedure. (build-docker-image): Remove #:symlinks and add #:extra-files. Make a sub-directory "extra" and call 'evaluate-populate-directive' for EXTRA-FILES in that directory. * guix/scripts/pack.scm (docker-image)[build](symlink->directives, directives): New procedures. Pass #:extra-files instead of #:symlinks to 'build-docker-image'.
-rw-r--r--guix/docker.scm68
-rw-r--r--guix/scripts/pack.scm20
2 files changed, 50 insertions, 38 deletions
diff --git a/guix/docker.scm b/guix/docker.scm
index c598a073f6..757bdeb458 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -28,11 +28,13 @@
invoke))
#:use-module (gnu build install)
#:use-module (json) ;guile-json
+ #:use-module (srfi srfi-1)
#: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 ftw)
#:use-module (ice-9 match)
#:export (build-docker-image))
@@ -99,21 +101,18 @@
'("--sort=name" "--mtime=@1"
"--owner=root:0" "--group=root:0"))
-(define symlink-source
+(define directive-file
+ ;; Return the file or directory created by a 'evaluate-populate-directive'
+ ;; directive.
(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)))
+ (string-trim source #\/))
+ (('directory name _ ...)
+ (string-trim name #\/))))
(define* (build-docker-image image paths prefix
#:key
- (symlinks '())
+ (extra-files '())
(transformations '())
(system (utsname:machine (uname)))
database
@@ -133,8 +132,9 @@ entry point in the Docker image JSON structure.
ENVIRONMENT must be a list of name/value pairs. It specifies the environment
variables that must be defined in the resulting image.
-SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
-created in the image, where each TARGET is relative to PREFIX.
+EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
+describing non-store files that must be created in the image.
+
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
@@ -199,25 +199,27 @@ SRFI-19 time-utc object, as the creation time in metadata."
(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)
+ ;; Create a directory for the non-store files that need to go into the
+ ;; archive.
+ (mkdir "extra")
+
+ (with-directory-excursion "extra"
+ ;; Create non-store files.
+ (for-each (cut evaluate-populate-directive <> "./")
+ extra-files)
- (when database
- ;; Initialize /var/guix, assuming PREFIX points to a profile.
- (install-database-and-gc-roots "." database prefix))
+ (when database
+ ;; Initialize /var/guix, assuming PREFIX points to a profile.
+ (install-database-and-gc-roots "." database prefix))
+
+ (apply invoke "tar" "-cf" "../layer.tar"
+ `(,@transformation-options
+ ,@%tar-determinism-options
+ ,@paths
+ ,@(scandir "."
+ (lambda (file)
+ (not (member file '("." ".."))))))))
- (apply invoke "tar" "-cf" "layer.tar"
- `(,@transformation-options
- ,@%tar-determinism-options
- ,@paths
- ,@(if database '("var") '())
- ,@(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
@@ -231,13 +233,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
(lambda ()
(system* "tar" "--delete" "/" "-f" "layer.tar")))
- (for-each delete-file-recursively
- (map (compose topmost-component symlink-source)
- symlinks))
-
- ;; Delete /var/guix.
- (when database
- (delete-file-recursively "var")))
+ (delete-file-recursively "extra"))
(with-output-to-file "config.json"
(lambda ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 794d2ee390..a15530ad70 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -490,7 +490,8 @@ the image."
#~(begin
(use-modules (guix docker) (guix build store-copy)
(guix profiles) (guix search-paths)
- (srfi srfi-19) (ice-9 match))
+ (srfi srfi-1) (srfi srfi-19)
+ (ice-9 match))
(define environment
(map (match-lambda
@@ -499,6 +500,21 @@ the image."
value)))
(profile-search-paths #$profile)))
+ (define symlink->directives
+ ;; Return "populate directives" to make the given symlink and its
+ ;; parent directories.
+ (match-lambda
+ ((source '-> target)
+ (let ((target (string-append #$profile "/" target))
+ (parent (dirname source)))
+ `((directory ,parent)
+ (,source -> ,target))))))
+
+ (define directives
+ ;; Fully-qualified symlinks.
+ (append-map symlink->directives '#$symlinks))
+
+
(setenv "PATH" (string-append #$archiver "/bin"))
(build-docker-image #$output
@@ -513,7 +529,7 @@ the image."
#$(and entry-point
#~(list (string-append #$profile "/"
#$entry-point)))
- #:symlinks '#$symlinks
+ #:extra-files directives
#:compressor '#$(compressor-command compressor)
#:creation-time (make-time time-utc 0 1))))))