guix: Rewrite build-docker-image to allow more paths.
* guix/docker.scm (build-docker-image): Rename "path" argument to "prefix" to reflect the fact that it is used as a prefix for the symlink targets. Add the "paths" argument, and remove the "closure" argument, since it is now redundant. Add a "transformations" argument. * guix/scripts/pack.scm (docker-image): Read the profile's reference graph and provide its paths to build-docker-image via the new "paths" argument.
This commit is contained in:
Chris Marusich
parent
8c9bf2946a
commit
1c2ac6b482
190
guix/docker.scm
190
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.
|
||||
"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.
|
||||
|
||||
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")))))
|
||||
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)
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
;; Create SYMLINKS.
|
||||
(for-each (match-lambda
|
||||
((source '-> target)
|
||||
(let ((source (string-trim source #\/)))
|
||||
(mkdir-p (dirname source))
|
||||
(symlink (string-append prefix "/" target)
|
||||
source))))
|
||||
symlinks)
|
||||
|
||||
;; 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)
|
||||
(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)))
|
||||
|
||||
(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 prefix id))))
|
||||
(with-output-to-file "repositories"
|
||||
(lambda ()
|
||||
(scm->json (repositories prefix id)))))
|
||||
|
||||
(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)))))
|
||||
(apply invoke "tar" "-cf" image "-C" directory
|
||||
`(,@%tar-determinism-options
|
||||
,@(if compressor
|
||||
(list "-I" (string-join compressor))
|
||||
'())
|
||||
"."))
|
||||
(delete-file-recursively directory)))
|
||||
|
||||
@ -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)))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user