diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
commit | d1f3b333e6176a7879ab3742bbebb2a99f61a528 (patch) | |
tree | 8bd82ce68bd2534a48bf13c7256997f82dd1b3f4 /guix/docker.scm | |
parent | e01d384efcdaf564bbb221e43b81e087c8e2af06 (diff) | |
parent | 861907f01efb1cae7f260e8cb7b991d5034a486a (diff) | |
download | guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar.gz |
Merge branch 'master' into staging
Diffstat (limited to 'guix/docker.scm')
-rw-r--r-- | guix/docker.scm | 111 |
1 files changed, 62 insertions, 49 deletions
diff --git a/guix/docker.scm b/guix/docker.scm index c598a073f6..97ac6d982b 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)) @@ -55,22 +57,36 @@ (created . ,time) (container_config . #nil))) -(define (generate-tag path) - "Generate an image tag for the given PATH." - (match (string-split (basename path) #\-) - ((hash name . rest) (string-append name ":" hash)))) +(define (canonicalize-repository-name name) + "\"Repository\" names are restricted to roughtl [a-z0-9_.-]. +Return a version of TAG that follows these rules." + (define ascii-letters + (string->char-set "abcdefghijklmnopqrstuvwxyz")) -(define (manifest path id) + (define separators + (string->char-set "_-.")) + + (define repo-char-set + (char-set-union char-set:digit ascii-letters separators)) + + (string-map (lambda (chr) + (if (char-set-contains? repo-char-set chr) + chr + #\.)) + (string-trim (string-downcase name) separators))) + +(define* (manifest path id #:optional (tag "guix")) "Generate a simple image manifest." - `#(((Config . "config.json") - (RepoTags . #(,(generate-tag path))) - (Layers . #(,(string-append id "/layer.tar")))))) + (let ((tag (canonicalize-repository-name tag))) + `#(((Config . "config.json") + (RepoTags . #(,(string-append tag ":latest"))) + (Layers . #(,(string-append id "/layer.tar"))))))) ;; According to the specifications this is required for backwards ;; compatibility. It duplicates information provided by the manifest. -(define (repositories path id) +(define* (repositories path id #:optional (tag "guix")) "Generate a repositories file referencing PATH and the image ID." - `((,(generate-tag path) . ((latest . ,id))))) + `((,(canonicalize-repository-name tag) . ((latest . ,id))))) ;; See https://github.com/opencontainers/image-spec/blob/master/config.md (define* (config layer time arch #:key entry-point (environment '())) @@ -99,21 +115,19 @@ '("--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 '()) + (repository "guix") + (extra-files '()) (transformations '()) (system (utsname:machine (uname))) database @@ -122,7 +136,9 @@ return \"a\"." compressor (creation-time (current-time time-utc))) "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. +must be a store path that is a prefix of any store paths in PATHS. REPOSITORY +is a descriptive name that will show up in \"REPOSITORY\" column of the output +of \"docker images\". When DATABASE is true, copy it to /var/guix/db in the image and create /var/guix/gcroots and friends. @@ -133,8 +149,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 +216,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 +250,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 () @@ -247,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata." #:entry-point entry-point)))) (with-output-to-file "manifest.json" (lambda () - (scm->json (manifest prefix id)))) + (scm->json (manifest prefix id repository)))) (with-output-to-file "repositories" (lambda () - (scm->json (repositories prefix id))))) + (scm->json (repositories prefix id repository))))) (apply invoke "tar" "-cf" image "-C" directory `(,@%tar-determinism-options |