guix/docker.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2017, 2018, 2019, 2021 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-1)
  32   #:use-module (srfi srfi-19)
  33   #:use-module (srfi srfi-26)
  34   #:use-module ((texinfo string-utils)
  35                 #:select (escape-special-chars))
  36   #:use-module (rnrs bytevectors)
  37   #:use-module (ice-9 ftw)
  38   #:use-module (ice-9 match)
  39   #:export (build-docker-image))
  40
  41 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
  42 (define docker-id
  43   (compose bytevector->base16-string sha256 string->utf8))
  44
  45 (define (layer-diff-id layer)
  46   "Generate a layer DiffID for the given LAYER archive."
  47   (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
  48
  49 ;; This is the semantic version of the JSON metadata schema according to
  50 ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
  51 ;; It is NOT the version of the image specification.
  52 (define schema-version "1.0")
  53
  54 (define (image-description id time)
  55   "Generate a simple image description."
  56   `((id . ,id)
  57     (created . ,time)
  58     (container_config . #nil)))
  59
  60 (define (canonicalize-repository-name name)
  61   "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
  62 Return a version of TAG that follows these rules."
  63   (define ascii-letters
  64     (string->char-set "abcdefghijklmnopqrstuvwxyz"))
  65
  66   (define separators
  67     (string->char-set "_-."))
  68
  69   (define repo-char-set
  70     (char-set-union char-set:digit ascii-letters separators))
  71
  72   (string-map (lambda (chr)
  73                 (if (char-set-contains? repo-char-set chr)
  74                     chr
  75                     #\.))
  76               (string-trim (string-downcase name) separators)))
  77
  78 (define* (manifest path id #:optional (tag "guix"))
  79   "Generate a simple image manifest."
  80   (let ((tag (canonicalize-repository-name tag)))
  81     `#(((Config . "config.json")
  82         (RepoTags . #(,(string-append tag ":latest")))
  83         (Layers . #(,(string-append id "/layer.tar")))))))
  84
  85 ;; According to the specifications this is required for backwards
  86 ;; compatibility.  It duplicates information provided by the manifest.
  87 (define* (repositories path id #:optional (tag "guix"))
  88   "Generate a repositories file referencing PATH and the image ID."
  89   `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
  90
  91 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
  92 (define* (config layer time arch #:key entry-point (environment '()))
  93   "Generate a minimal image configuration for the given LAYER file."
  94   ;; "architecture" must be values matching "platform.arch" in the
  95   ;; runtime-spec at
  96   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  97   `((architecture . ,arch)
  98     (comment . "Generated by GNU Guix")
  99     (created . ,time)
 100     (config . ,`((env . ,(list->vector
 101                           (map (match-lambda
 102                                  ((name . value)
 103                                   (string-append name "=" value)))
 104                                environment)))
 105                  ,@(if entry-point
 106                        `((entrypoint . ,(list->vector entry-point)))
 107                        '())))
 108     (container_config . #nil)
 109     (os . "linux")
 110     (rootfs . ((type . "layers")
 111                (diff_ids . #(,(layer-diff-id layer)))))))
 112
 113 (define %tar-determinism-options
 114   ;; GNU tar options to produce archives deterministically.
 115   '("--sort=name" "--mtime=@1"
 116     "--owner=root:0" "--group=root:0"
 117
 118     ;; When 'build-docker-image' is passed store items, the 'nlink' of the
 119     ;; files therein leads tar to store hard links instead of actual copies.
 120     ;; However, the 'nlink' count depends on deduplication in the store; it's
 121     ;; an "implicit input" to the build process.  '--hard-dereference'
 122     ;; eliminates it.
 123     "--hard-dereference"))
 124
 125 (define directive-file
 126   ;; Return the file or directory created by a 'evaluate-populate-directive'
 127   ;; directive.
 128   (match-lambda
 129     ((source '-> target)
 130      (string-trim source #\/))
 131     (('directory name _ ...)
 132      (string-trim name #\/))))
 133
 134 (define* (build-docker-image image paths prefix
 135                              #:key
 136                              (repository "guix")
 137                              (extra-files '())
 138                              (transformations '())
 139                              (system (utsname:machine (uname)))
 140                              database
 141                              entry-point
 142                              (environment '())
 143                              compressor
 144                              (creation-time (current-time time-utc)))
 145   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
 146 must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
 147 is a descriptive name that will show up in \"REPOSITORY\" column of the output
 148 of \"docker images\".
 149
 150 When DATABASE is true, copy it to /var/guix/db in the image and create
 151 /var/guix/gcroots and friends.
 152
 153 When ENTRY-POINT is true, it must be a list of strings; it is stored as the
 154 entry point in the Docker image JSON structure.
 155
 156 ENVIRONMENT must be a list of name/value pairs.  It specifies the environment
 157 variables that must be defined in the resulting image.
 158
 159 EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
 160 describing non-store files that must be created in the image.
 161
 162 TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
 163 transform the PATHS.  Any path in PATHS that begins with OLD will be rewritten
 164 in the Docker image so that it begins with NEW instead.  If a path is a
 165 non-empty directory, then its contents will be recursively added, as well.
 166
 167 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 168 PATHS are for; it is used to produce metadata in the image.  Use COMPRESSOR, a
 169 command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use CREATION-TIME, a
 170 SRFI-19 time-utc object, as the creation time in metadata."
 171   (define (sanitize path-fragment)
 172     (escape-special-chars
 173      ;; GNU tar strips the leading slash off of absolute paths before applying
 174      ;; the transformations, so we need to do the same, or else our
 175      ;; replacements won't match any paths.
 176      (string-trim path-fragment #\/)
 177      ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
 178      ;; We also need to escape "/" because we use it as a delimiter.
 179      "/*.^$[]\\"
 180      #\\))
 181   (define transformation->replacement
 182     (match-lambda
 183       ((old '-> new)
 184        ;; See "(tar) transform" for details on the expression syntax.
 185        (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
 186   (define (transformations->expression transformations)
 187     (let ((replacements (map transformation->replacement transformations)))
 188       (string-append
 189        ;; Avoid transforming link targets, since that would break some links
 190        ;; (e.g., symlinks that point to an absolute store path).
 191        "flags=rSH;"
 192        (string-join replacements ";")
 193        ;; Some paths might still have a leading path delimiter even after tar
 194        ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
 195        ;; strip any leading path delimiters that remain.
 196        ";s,^//*,,")))
 197   (define transformation-options
 198     (if (eq? '() transformations)
 199         '()
 200         `("--transform" ,(transformations->expression transformations))))
 201   (let* ((directory "/tmp/docker-image") ;temporary working directory
 202          (id (docker-id prefix))
 203          (time (date->string (time-utc->date creation-time) "~4"))
 204          (arch (let-syntax ((cond* (syntax-rules ()
 205                                      ((_ (pattern clause) ...)
 206                                       (cond ((string-prefix? pattern system)
 207                                              clause)
 208                                             ...
 209                                             (else
 210                                              (error "unsupported system"
 211                                                     system)))))))
 212                  (cond* ("x86_64" "amd64")
 213                         ("i686"   "386")
 214                         ("arm"    "arm")
 215                         ("mips64" "mips64le")))))
 216     ;; Make sure we start with a fresh, empty working directory.
 217     (mkdir directory)
 218     (with-directory-excursion directory
 219       (mkdir id)
 220       (with-directory-excursion id
 221         (with-output-to-file "VERSION"
 222           (lambda () (display schema-version)))
 223         (with-output-to-file "json"
 224           (lambda () (scm->json (image-description id time))))
 225
 226         ;; Create a directory for the non-store files that need to go into the
 227         ;; archive.
 228         (mkdir "extra")
 229
 230         (with-directory-excursion "extra"
 231           ;; Create non-store files.
 232           (for-each (cut evaluate-populate-directive <> "./")
 233                     extra-files)
 234
 235           (when database
 236             ;; Initialize /var/guix, assuming PREFIX points to a profile.
 237             (install-database-and-gc-roots "." database prefix))
 238
 239           (apply invoke "tar" "-cf" "../layer.tar"
 240                  `(,@transformation-options
 241                    ,@%tar-determinism-options
 242                    ,@paths
 243                    ,@(scandir "."
 244                               (lambda (file)
 245                                 (not (member file '("." ".."))))))))
 246
 247         ;; It is possible for "/" to show up in the archive, especially when
 248         ;; applying transformations.  For example, the transformation
 249         ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
 250         ;; the path "/a" into "/".  The presence of "/" in the archive is
 251         ;; probably benign, but it is definitely safe to remove it, so let's
 252         ;; do that.  This fails when "/" is not in the archive, so use system*
 253         ;; instead of invoke to avoid an exception in that case, and redirect
 254         ;; stderr to the bit bucket to avoid "Exiting with failure status"
 255         ;; error messages.
 256         (with-error-to-port (%make-void-port "w")
 257           (lambda ()
 258             (system* "tar" "--delete" "/" "-f" "layer.tar")))
 259
 260         (delete-file-recursively "extra"))
 261
 262       (with-output-to-file "config.json"
 263         (lambda ()
 264           (scm->json (config (string-append id "/layer.tar")
 265                              time arch
 266                              #:environment environment
 267                              #:entry-point entry-point))))
 268       (with-output-to-file "manifest.json"
 269         (lambda ()
 270           (scm->json (manifest prefix id repository))))
 271       (with-output-to-file "repositories"
 272         (lambda ()
 273           (scm->json (repositories prefix id repository)))))
 274
 275     (apply invoke "tar" "-cf" image "-C" directory
 276            `(,@%tar-determinism-options
 277              ,@(if compressor
 278                    (list "-I" (string-join compressor))
 279                    '())
 280              "."))
 281     (delete-file-recursively directory)))