kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

guix: Rewrite build-docker-image to allow more paths.

Browse Source 
* 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 2018-03-15 05:09:13 +01:00
parent 8c9bf2946a
commit 1c2ac6b482
No known key found for this signature in database
GPG Key ID: DD409A15D822469D
2 changed files with 123 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

190
guix/docker.scm
View File

@ -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,82 +105,123 @@ 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
(time (date->string (time-utc->date creation-time) "~4")) non-empty directory, then its contents will be recursively added, as well.
(arch (let-syntax ((cond* (syntax-rules ()
((_ (pattern clause) ...) SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
(cond ((string-prefix? pattern system) PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a
clause) command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a
... SRFI-19 time-utc object, as the creation time in metadata."
(else (define (sanitize path-fragment)
(error "unsupported system" (escape-special-chars
system))))))) ;; GNU tar strips the leading slash off of absolute paths before applying
(cond* ("x86_64" "amd64") ;; the transformations, so we need to do the same, or else our
("i686" "386") ;; replacements won't match any paths.
("arm" "arm") (string-trim path-fragment #\/)
("mips64" "mips64le"))))) ;; 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. ;; Make sure we start with a fresh, empty working directory.
(mkdir 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 ;; Create SYMLINKS.
(mkdir id) (for-each (match-lambda
(with-directory-excursion id ((source '-> target)
(with-output-to-file "VERSION" (let ((source (string-trim source #\/)))
(lambda () (display schema-version))) (mkdir-p (dirname source))
(with-output-to-file "json" (symlink (string-append prefix "/" target)
(lambda () (scm->json (image-description id time)))) source))))
symlinks)
;; Wrap it up. (apply invoke "tar" "-cf" "layer.tar"
(let ((items (call-with-input-file closure `(,@transformation-options
read-reference-graph))) ,@%tar-determinism-options
;; Create SYMLINKS. ,@paths
(for-each (match-lambda ,@(map symlink-source symlinks)))
((source '-> target) ;; It is possible for "/" to show up in the archive, especially when
(let ((source (string-trim source #\/))) ;; applying transformations. For example, the transformation
(mkdir-p (dirname source)) ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
(symlink (string-append path "/" target) ;; the path "/a" into "/". The presence of "/" in the archive is
source)))) ;; probably benign, but it is definitely safe to remove it, so let's
symlinks) ;; 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" (with-output-to-file "config.json"
(append %tar-determinism-options (lambda ()
items (scm->json (config (string-append id "/layer.tar")
(map symlink-source symlinks)))) time arch))))
(for-each delete-file-recursively (with-output-to-file "manifest.json"
(map (compose topmost-component symlink-source) (lambda ()
symlinks))))) (scm->json (manifest prefix id))))
(with-output-to-file "repositories"
(lambda ()
(scm->json (repositories prefix id)))))
(with-output-to-file "config.json" (apply invoke "tar" "-cf" image "-C" directory
(lambda () `(,@%tar-determinism-options
(scm->json (config (string-append id "/layer.tar") ,@(if compressor
time arch)))) (list "-I" (string-join compressor))
(with-output-to-file "manifest.json" '())
(lambda () "."))
(scm->json (manifest path id)))) (delete-file-recursively directory)))
(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)))))

9
guix/scripts/pack.scm
View File

@ -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)))))