;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; 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 (guix store)
+ #:use-module (gcrypt hash)
#:use-module (guix base16)
- #:use-module (guix utils)
#:use-module ((guix build utils)
- #:select (delete-file-recursively
- with-directory-excursion))
- #:use-module (json)
+ #: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))
-;; 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))
(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)
+(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)))))))
-
-(define* (build-docker-image path #:key system)
- "Generate a Docker image archive from the given store PATH. The image
-contains the closure of the given store item."
- (let ((id (docker-id path))
- (time (strftime "%FT%TZ" (localtime (current-time))))
- (name (string-append (getcwd)
- "/docker-image-" (basename path) ".tar"))
- (arch (match system
- ("x86_64-linux" "amd64")
- ("i686-linux" "386")
- ("armhf-linux" "arm")
- ("mips64el-linux" "mips64le"))))
- (and (call-with-temporary-directory
- (lambda (directory)
- (with-directory-excursion directory
- ;; Add symlink from /bin to /gnu/store/.../bin
- (symlink (string-append path "/bin") "bin")
-
- (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))))
-
- ;; Wrap it up
- (let ((items (with-store store
- (requisites store (list path)))))
- (and (zero? (apply system* "tar" "-cf" "layer.tar"
- (cons "../bin" items)))
- (delete-file "../bin"))))
-
- (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? (system* "tar" "-C" directory "-cf" name "."))
- (begin (delete-file-recursively directory) #t))))
- name)))
+ (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 directive-file
+ ;; Return the file or directory created by a 'evaluate-populate-directive'
+ ;; directive.
+ (match-lambda
+ ((source '-> target)
+ (string-trim source #\/))
+ (('directory name _ ...)
+ (string-trim name #\/))))
+
+(define* (build-docker-image image paths prefix
+ #:key
+ (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. 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.
+
+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))))
+
+ ;; 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, 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
+ #:environment environment
+ #:entry-point entry-point))))
+ (with-output-to-file "manifest.json"
+ (lambda ()
+ (scm->json (manifest prefix id repository))))
+ (with-output-to-file "repositories"
+ (lambda ()
+ (scm->json (repositories prefix id repository)))))
+
+ (apply invoke "tar" "-cf" image "-C" directory
+ `(,@%tar-determinism-options
+ ,@(if compressor
+ (list "-I" (string-join compressor))
+ '())
+ "."))
+ (delete-file-recursively directory)))
HCoop / jackhill / guix / guix.git / blobdiff