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:
parent
8c9bf2946a
commit
1c2ac6b482
110
guix/docker.scm
110
guix/docker.scm
|
@ -1,6 +1,7 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
|
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
|
||||||
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -23,9 +24,12 @@
|
||||||
#:use-module ((guix build utils)
|
#:use-module ((guix build utils)
|
||||||
#:select (mkdir-p
|
#:select (mkdir-p
|
||||||
delete-file-recursively
|
delete-file-recursively
|
||||||
with-directory-excursion))
|
with-directory-excursion
|
||||||
#:use-module (guix build store-copy)
|
invoke))
|
||||||
#:use-module (srfi srfi-19)
|
#: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 (rnrs bytevectors)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export (build-docker-image))
|
#:export (build-docker-image))
|
||||||
|
@ -33,8 +37,7 @@
|
||||||
;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
|
;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
|
||||||
(module-use! (current-module) (resolve-interface '(json)))
|
(module-use! (current-module) (resolve-interface '(json)))
|
||||||
|
|
||||||
;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
|
;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
|
||||||
;; containing the closure at PATH.
|
|
||||||
(define docker-id
|
(define docker-id
|
||||||
(compose bytevector->base16-string sha256 string->utf8))
|
(compose bytevector->base16-string sha256 string->utf8))
|
||||||
|
|
||||||
|
@ -102,23 +105,59 @@ return \"a\"."
|
||||||
((first rest ...)
|
((first rest ...)
|
||||||
first)))
|
first)))
|
||||||
|
|
||||||
(define* (build-docker-image image path
|
(define* (build-docker-image image paths prefix
|
||||||
#:key closure compressor
|
#:key
|
||||||
(symlinks '())
|
(symlinks '())
|
||||||
|
(transformations '())
|
||||||
(system (utsname:machine (uname)))
|
(system (utsname:machine (uname)))
|
||||||
|
compressor
|
||||||
(creation-time (current-time time-utc)))
|
(creation-time (current-time time-utc)))
|
||||||
"Write to IMAGE a Docker image archive from the given store PATH. The image
|
"Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
|
||||||
contains the closure of PATH, as specified in CLOSURE (a file produced by
|
must be a store path that is a prefix of any store paths in PATHS.
|
||||||
#: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.
|
|
||||||
|
|
||||||
Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use
|
SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
|
||||||
CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
|
created in the image, where each TARGET is relative to PREFIX.
|
||||||
(let ((directory "/tmp/docker-image") ;temporary working directory
|
TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
|
||||||
(closure (canonicalize-path closure))
|
transform the PATHS. Any path in PATHS that begins with OLD will be rewritten
|
||||||
(id (docker-id path))
|
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"))
|
(time (date->string (time-utc->date creation-time) "~4"))
|
||||||
(arch (let-syntax ((cond* (syntax-rules ()
|
(arch (let-syntax ((cond* (syntax-rules ()
|
||||||
((_ (pattern clause) ...)
|
((_ (pattern clause) ...)
|
||||||
|
@ -134,8 +173,7 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
|
||||||
("mips64" "mips64le")))))
|
("mips64" "mips64le")))))
|
||||||
;; Make sure we start with a fresh, empty working directory.
|
;; Make sure we start with a fresh, empty working directory.
|
||||||
(mkdir directory)
|
(mkdir directory)
|
||||||
|
(with-directory-excursion directory
|
||||||
(and (with-directory-excursion directory
|
|
||||||
(mkdir id)
|
(mkdir id)
|
||||||
(with-directory-excursion id
|
(with-directory-excursion id
|
||||||
(with-output-to-file "VERSION"
|
(with-output-to-file "VERSION"
|
||||||
|
@ -143,25 +181,31 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
|
||||||
(with-output-to-file "json"
|
(with-output-to-file "json"
|
||||||
(lambda () (scm->json (image-description id time))))
|
(lambda () (scm->json (image-description id time))))
|
||||||
|
|
||||||
;; Wrap it up.
|
|
||||||
(let ((items (call-with-input-file closure
|
|
||||||
read-reference-graph)))
|
|
||||||
;; Create SYMLINKS.
|
;; Create SYMLINKS.
|
||||||
(for-each (match-lambda
|
(for-each (match-lambda
|
||||||
((source '-> target)
|
((source '-> target)
|
||||||
(let ((source (string-trim source #\/)))
|
(let ((source (string-trim source #\/)))
|
||||||
(mkdir-p (dirname source))
|
(mkdir-p (dirname source))
|
||||||
(symlink (string-append path "/" target)
|
(symlink (string-append prefix "/" target)
|
||||||
source))))
|
source))))
|
||||||
symlinks)
|
symlinks)
|
||||||
|
|
||||||
(and (zero? (apply system* "tar" "-cf" "layer.tar"
|
(apply invoke "tar" "-cf" "layer.tar"
|
||||||
(append %tar-determinism-options
|
`(,@transformation-options
|
||||||
items
|
,@%tar-determinism-options
|
||||||
(map symlink-source symlinks))))
|
,@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
|
(for-each delete-file-recursively
|
||||||
(map (compose topmost-component symlink-source)
|
(map (compose topmost-component symlink-source)
|
||||||
symlinks)))))
|
symlinks)))
|
||||||
|
|
||||||
(with-output-to-file "config.json"
|
(with-output-to-file "config.json"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
@ -169,15 +213,15 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
|
||||||
time arch))))
|
time arch))))
|
||||||
(with-output-to-file "manifest.json"
|
(with-output-to-file "manifest.json"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(scm->json (manifest path id))))
|
(scm->json (manifest prefix id))))
|
||||||
(with-output-to-file "repositories"
|
(with-output-to-file "repositories"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(scm->json (repositories path id)))))
|
(scm->json (repositories prefix id)))))
|
||||||
|
|
||||||
(and (zero? (apply system* "tar" "-C" directory "-cf" image
|
(apply invoke "tar" "-cf" image "-C" directory
|
||||||
`(,@%tar-determinism-options
|
`(,@%tar-determinism-options
|
||||||
,@(if compressor
|
,@(if compressor
|
||||||
(list "-I" (string-join compressor))
|
(list "-I" (string-join compressor))
|
||||||
'())
|
'())
|
||||||
".")))
|
"."))
|
||||||
(begin (delete-file-recursively directory) #t)))))
|
(delete-file-recursively directory)))
|
||||||
|
|
|
@ -238,6 +238,7 @@ the image."
|
||||||
(define build
|
(define build
|
||||||
(with-imported-modules `(,@(source-module-closure '((guix docker))
|
(with-imported-modules `(,@(source-module-closure '((guix docker))
|
||||||
#:select? not-config?)
|
#:select? not-config?)
|
||||||
|
(guix build store-copy)
|
||||||
((guix config) => ,config))
|
((guix config) => ,config))
|
||||||
#~(begin
|
#~(begin
|
||||||
;; Guile-JSON is required by (guix docker).
|
;; Guile-JSON is required by (guix docker).
|
||||||
|
@ -245,13 +246,15 @@ the image."
|
||||||
(string-append #+json "/share/guile/site/"
|
(string-append #+json "/share/guile/site/"
|
||||||
(effective-version)))
|
(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"))
|
(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)))
|
#:system (or #$target (utsname:machine (uname)))
|
||||||
#:closure "profile"
|
|
||||||
#:symlinks '#$symlinks
|
#:symlinks '#$symlinks
|
||||||
#:compressor '#$(compressor-command compressor)
|
#:compressor '#$(compressor-command compressor)
|
||||||
#:creation-time (make-time time-utc 0 1)))))
|
#:creation-time (make-time time-utc 0 1)))))
|
||||||
|
|
Loading…
Reference in New Issue