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