;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix docker)
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#:use-module (guix base16)
#:use-module ((guix build utils)
#:select (mkdir-p
delete-file-recursively
with-directory-excursion
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))
-;; 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.
(define docker-id
(compose bytevector->base16-string sha256 string->utf8))
(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 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)
+(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)
+(define* (config layer time arch #:key entry-point (environment '()))
"Generate a minimal image configuration for the given LAYER file."
;; "architecture" must be values matching "platform.arch" in the
;; runtime-spec at
`((architecture . ,arch)
(comment . "Generated by GNU Guix")
(created . ,time)
- (config . #nil)
+ (config . ,`((env . ,(list->vector
+ (map (match-lambda
+ ((name . value)
+ (string-append name "=" value)))
+ environment)))
+ ,@(if entry-point
+ `((entrypoint . ,(list->vector entry-point)))
+ '())))
(container_config . #nil)
(os . "linux")
(rootfs . ((type . "layers")
- (diff_ids . (,(layer-diff-id layer)))))))
+ (diff_ids . #(,(layer-diff-id layer)))))))
(define %tar-determinism-options
;; GNU tar options to produce archives deterministically.
'("--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
+ entry-point
+ (environment '())
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.
+
+When ENTRY-POINT is true, it must be a list of strings; it is stored as the
+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.
+
+EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
+describing non-store files that must be created in the 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.
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
(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)
-
- (apply invoke "tar" "-cf" "layer.tar"
- `(,@transformation-options
- ,@%tar-determinism-options
- ,@paths
- ,@(map symlink-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))
+
+ (apply invoke "tar" "-cf" "../layer.tar"
+ `(,@transformation-options
+ ,@%tar-determinism-options
+ ,@paths
+ ,@(scandir "."
+ (lambda (file)
+ (not (member file '("." ".."))))))))
+
;; 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)))
+ ;; instead of invoke to avoid an exception in that case, and redirect
+ ;; stderr to the bit bucket to avoid "Exiting with failure status"
+ ;; error messages.
+ (with-error-to-port (%make-void-port "w")
+ (lambda ()
+ (system* "tar" "--delete" "/" "-f" "layer.tar")))
+
+ (delete-file-recursively "extra"))
(with-output-to-file "config.json"
(lambda ()
(scm->json (config (string-append id "/layer.tar")
- time arch))))
+ time arch
+ #:environment environment
+ #: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
HCoop / jackhill / guix / guix.git / blobdiff