guix/docker.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix docker)
  22   #:use-module (gcrypt hash)
  23   #:use-module (guix base16)
  24   #:use-module ((guix build utils)
  25                 #:select (mkdir-p
  26                           delete-file-recursively
  27                           with-directory-excursion
  28                           invoke))
  29   #:use-module (gnu build install)
  30   #:use-module (json)                             ;guile-json
  31   #:use-module (srfi srfi-19)
  32   #:use-module (srfi srfi-26)
  33   #:use-module ((texinfo string-utils)
  34                 #:select (escape-special-chars))
  35   #:use-module (rnrs bytevectors)
  36   #:use-module (ice-9 match)
  37   #:export (build-docker-image))
  38
  39 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
  40 (define docker-id
  41   (compose bytevector->base16-string sha256 string->utf8))
  42
  43 (define (layer-diff-id layer)
  44   "Generate a layer DiffID for the given LAYER archive."
  45   (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
  46
  47 ;; This is the semantic version of the JSON metadata schema according to
  48 ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
  49 ;; It is NOT the version of the image specification.
  50 (define schema-version "1.0")
  51
  52 (define (image-description id time)
  53   "Generate a simple image description."
  54   `((id . ,id)
  55     (created . ,time)
  56     (container_config . #nil)))
  57
  58 (define (generate-tag path)
  59   "Generate an image tag for the given PATH."
  60   (match (string-split (basename path) #\-)
  61     ((hash name . rest) (string-append name ":" hash))))
  62
  63 (define (manifest path id)
  64   "Generate a simple image manifest."
  65   `(((Config . "config.json")
  66      (RepoTags . (,(generate-tag path)))
  67      (Layers . (,(string-append id "/layer.tar"))))))
  68
  69 ;; According to the specifications this is required for backwards
  70 ;; compatibility.  It duplicates information provided by the manifest.
  71 (define (repositories path id)
  72   "Generate a repositories file referencing PATH and the image ID."
  73   `((,(generate-tag path) . ((latest . ,id)))))
  74
  75 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
  76 (define* (config layer time arch #:key entry-point (environment '()))
  77   "Generate a minimal image configuration for the given LAYER file."
  78   ;; "architecture" must be values matching "platform.arch" in the
  79   ;; runtime-spec at
  80   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  81   `((architecture . ,arch)
  82     (comment . "Generated by GNU Guix")
  83     (created . ,time)
  84     (config . ,`((env . ,(map (match-lambda
  85                                 ((name . value)
  86                                  (string-append name "=" value)))
  87                               environment))
  88                  ,@(if entry-point
  89                        `((entrypoint . ,entry-point))
  90                        '())))
  91     (container_config . #nil)
  92     (os . "linux")
  93     (rootfs . ((type . "layers")
  94                (diff_ids . (,(layer-diff-id layer)))))))
  95
  96 (define %tar-determinism-options
  97   ;; GNU tar options to produce archives deterministically.
  98   '("--sort=name" "--mtime=@1"
  99     "--owner=root:0" "--group=root:0"))
 100
 101 (define symlink-source
 102   (match-lambda
 103     ((source '-> target)
 104      (string-trim source #\/))))
 105
 106 (define (topmost-component file)
 107   "Return the topmost component of FILE.  For instance, if FILE is \"/a/b/c\",
 108 return \"a\"."
 109   (match (string-tokenize file (char-set-complement (char-set #\/)))
 110     ((first rest ...)
 111      first)))
 112
 113 (define* (build-docker-image image paths prefix
 114                              #:key
 115                              (symlinks '())
 116                              (transformations '())
 117                              (system (utsname:machine (uname)))
 118                              database
 119                              entry-point
 120                              (environment '())
 121                              compressor
 122                              (creation-time (current-time time-utc)))
 123   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
 124 must be a store path that is a prefix of any store paths in PATHS.
 125
 126 When DATABASE is true, copy it to /var/guix/db in the image and create
 127 /var/guix/gcroots and friends.
 128
 129 When ENTRY-POINT is true, it must be a list of strings; it is stored as the
 130 entry point in the Docker image JSON structure.
 131
 132 ENVIRONMENT must be a list of name/value pairs.  It specifies the environment
 133 variables that must be defined in the resulting image.
 134
 135 SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
 136 created in the image, where each TARGET is relative to PREFIX.
 137 TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
 138 transform the PATHS.  Any path in PATHS that begins with OLD will be rewritten
 139 in the Docker image so that it begins with NEW instead.  If a path is a
 140 non-empty directory, then its contents will be recursively added, as well.
 141
 142 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 143 PATHS are for; it is used to produce metadata in the image.  Use COMPRESSOR, a
 144 command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use CREATION-TIME, a
 145 SRFI-19 time-utc object, as the creation time in metadata."
 146   (define (sanitize path-fragment)
 147     (escape-special-chars
 148      ;; GNU tar strips the leading slash off of absolute paths before applying
 149      ;; the transformations, so we need to do the same, or else our
 150      ;; replacements won't match any paths.
 151      (string-trim path-fragment #\/)
 152      ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
 153      ;; We also need to escape "/" because we use it as a delimiter.
 154      "/*.^$[]\\"
 155      #\\))
 156   (define transformation->replacement
 157     (match-lambda
 158       ((old '-> new)
 159        ;; See "(tar) transform" for details on the expression syntax.
 160        (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
 161   (define (transformations->expression transformations)
 162     (let ((replacements (map transformation->replacement transformations)))
 163       (string-append
 164        ;; Avoid transforming link targets, since that would break some links
 165        ;; (e.g., symlinks that point to an absolute store path).
 166        "flags=rSH;"
 167        (string-join replacements ";")
 168        ;; Some paths might still have a leading path delimiter even after tar
 169        ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
 170        ;; strip any leading path delimiters that remain.
 171        ";s,^//*,,")))
 172   (define transformation-options
 173     (if (eq? '() transformations)
 174         '()
 175         `("--transform" ,(transformations->expression transformations))))
 176   (let* ((directory "/tmp/docker-image") ;temporary working directory
 177          (id (docker-id prefix))
 178          (time (date->string (time-utc->date creation-time) "~4"))
 179          (arch (let-syntax ((cond* (syntax-rules ()
 180                                      ((_ (pattern clause) ...)
 181                                       (cond ((string-prefix? pattern system)
 182                                              clause)
 183                                             ...
 184                                             (else
 185                                              (error "unsupported system"
 186                                                     system)))))))
 187                  (cond* ("x86_64" "amd64")
 188                         ("i686"   "386")
 189                         ("arm"    "arm")
 190                         ("mips64" "mips64le")))))
 191     ;; Make sure we start with a fresh, empty working directory.
 192     (mkdir directory)
 193     (with-directory-excursion directory
 194       (mkdir id)
 195       (with-directory-excursion id
 196         (with-output-to-file "VERSION"
 197           (lambda () (display schema-version)))
 198         (with-output-to-file "json"
 199           (lambda () (scm->json (image-description id time))))
 200
 201         ;; Create SYMLINKS.
 202         (for-each (match-lambda
 203                     ((source '-> target)
 204                      (let ((source (string-trim source #\/)))
 205                        (mkdir-p (dirname source))
 206                        (symlink (string-append prefix "/" target)
 207                                 source))))
 208                   symlinks)
 209
 210         (when database
 211           ;; Initialize /var/guix, assuming PREFIX points to a profile.
 212           (install-database-and-gc-roots "." database prefix))
 213
 214         (apply invoke "tar" "-cf" "layer.tar"
 215                `(,@transformation-options
 216                  ,@%tar-determinism-options
 217                  ,@paths
 218                  ,@(if database '("var") '())
 219                  ,@(map symlink-source symlinks)))
 220         ;; It is possible for "/" to show up in the archive, especially when
 221         ;; applying transformations.  For example, the transformation
 222         ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
 223         ;; the path "/a" into "/".  The presence of "/" in the archive is
 224         ;; probably benign, but it is definitely safe to remove it, so let's
 225         ;; do that.  This fails when "/" is not in the archive, so use system*
 226         ;; instead of invoke to avoid an exception in that case, and redirect
 227         ;; stderr to the bit bucket to avoid "Exiting with failure status"
 228         ;; error messages.
 229         (with-error-to-port (%make-void-port "w")
 230           (lambda ()
 231             (system* "tar" "--delete" "/" "-f" "layer.tar")))
 232
 233         (for-each delete-file-recursively
 234                   (map (compose topmost-component symlink-source)
 235                        symlinks))
 236
 237         ;; Delete /var/guix.
 238         (when database
 239           (delete-file-recursively "var")))
 240
 241       (with-output-to-file "config.json"
 242         (lambda ()
 243           (scm->json (config (string-append id "/layer.tar")
 244                              time arch
 245                              #:environment environment
 246                              #:entry-point entry-point))))
 247       (with-output-to-file "manifest.json"
 248         (lambda ()
 249           (scm->json (manifest prefix id))))
 250       (with-output-to-file "repositories"
 251         (lambda ()
 252           (scm->json (repositories prefix id)))))
 253
 254     (apply invoke "tar" "-cf" image "-C" directory
 255            `(,@%tar-determinism-options
 256              ,@(if compressor
 257                    (list "-I" (string-join compressor))
 258                    '())
 259              "."))
 260     (delete-file-recursively directory)))