guix/docker.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
   3 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix docker)
  21   #:use-module (guix hash)
  22   #:use-module (guix base16)
  23   #:use-module ((guix build utils)
  24                 #:select (mkdir-p
  25                           delete-file-recursively
  26                           with-directory-excursion))
  27   #:use-module (guix build store-copy)
  28   #:use-module (srfi srfi-19)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (ice-9 match)
  31   #:export (build-docker-image))
  32
  33 ;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
  34 (module-use! (current-module) (resolve-interface '(json)))
  35
  36 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
  37 ;; containing the closure at PATH.
  38 (define docker-id
  39   (compose bytevector->base16-string sha256 string->utf8))
  40
  41 (define (layer-diff-id layer)
  42   "Generate a layer DiffID for the given LAYER archive."
  43   (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
  44
  45 ;; This is the semantic version of the JSON metadata schema according to
  46 ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
  47 ;; It is NOT the version of the image specification.
  48 (define schema-version "1.0")
  49
  50 (define (image-description id time)
  51   "Generate a simple image description."
  52   `((id . ,id)
  53     (created . ,time)
  54     (container_config . #nil)))
  55
  56 (define (generate-tag path)
  57   "Generate an image tag for the given PATH."
  58   (match (string-split (basename path) #\-)
  59     ((hash name . rest) (string-append name ":" hash))))
  60
  61 (define (manifest path id)
  62   "Generate a simple image manifest."
  63   `(((Config . "config.json")
  64      (RepoTags . (,(generate-tag path)))
  65      (Layers . (,(string-append id "/layer.tar"))))))
  66
  67 ;; According to the specifications this is required for backwards
  68 ;; compatibility.  It duplicates information provided by the manifest.
  69 (define (repositories path id)
  70   "Generate a repositories file referencing PATH and the image ID."
  71   `((,(generate-tag path) . ((latest . ,id)))))
  72
  73 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
  74 (define (config layer time arch)
  75   "Generate a minimal image configuration for the given LAYER file."
  76   ;; "architecture" must be values matching "platform.arch" in the
  77   ;; runtime-spec at
  78   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  79   `((architecture . ,arch)
  80     (comment . "Generated by GNU Guix")
  81     (created . ,time)
  82     (config . #nil)
  83     (container_config . #nil)
  84     (os . "linux")
  85     (rootfs . ((type . "layers")
  86                (diff_ids . (,(layer-diff-id layer)))))))
  87
  88 (define %tar-determinism-options
  89   ;; GNU tar options to produce archives deterministically.
  90   '("--sort=name" "--mtime=@1"
  91     "--owner=root:0" "--group=root:0"))
  92
  93 (define symlink-source
  94   (match-lambda
  95     ((source '-> target)
  96      (string-trim source #\/))))
  97
  98 (define (topmost-component file)
  99   "Return the topmost component of FILE.  For instance, if FILE is \"/a/b/c\",
 100 return \"a\"."
 101   (match (string-tokenize file (char-set-complement (char-set #\/)))
 102     ((first rest ...)
 103      first)))
 104
 105 (define* (build-docker-image image path
 106                              #:key closure compressor
 107                              (symlinks '())
 108                              (system (utsname:machine (uname)))
 109                              (creation-time (current-time time-utc)))
 110   "Write to IMAGE a Docker image archive from the given store PATH.  The image
 111 contains the closure of PATH, as specified in CLOSURE (a file produced by
 112 #:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
 113 describing symlinks to be created in the image, where each TARGET is relative
 114 to PATH.  SYSTEM is a GNU triplet (or prefix thereof) of the system the
 115 binaries at PATH are for; it is used to produce metadata in the image.
 116
 117 Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use
 118 CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
 119   (let ((directory "/tmp/docker-image")           ;temporary working directory
 120         (closure (canonicalize-path closure))
 121         (id (docker-id path))
 122         (time (date->string (time-utc->date creation-time) "~4"))
 123         (arch (let-syntax ((cond* (syntax-rules ()
 124                                     ((_ (pattern clause) ...)
 125                                      (cond ((string-prefix? pattern system)
 126                                             clause)
 127                                            ...
 128                                            (else
 129                                             (error "unsupported system"
 130                                                    system)))))))
 131                 (cond* ("x86_64" "amd64")
 132                        ("i686"   "386")
 133                        ("arm"    "arm")
 134                        ("mips64" "mips64le")))))
 135     ;; Make sure we start with a fresh, empty working directory.
 136     (mkdir directory)
 137
 138     (and (with-directory-excursion directory
 139            (mkdir id)
 140            (with-directory-excursion id
 141              (with-output-to-file "VERSION"
 142                (lambda () (display schema-version)))
 143              (with-output-to-file "json"
 144                (lambda () (scm->json (image-description id time))))
 145
 146              ;; Wrap it up.
 147              (let ((items (call-with-input-file closure
 148                             read-reference-graph)))
 149                ;; Create SYMLINKS.
 150                (for-each (match-lambda
 151                            ((source '-> target)
 152                             (let ((source (string-trim source #\/)))
 153                               (mkdir-p (dirname source))
 154                               (symlink (string-append path "/" target)
 155                                        source))))
 156                          symlinks)
 157
 158                (and (zero? (apply system* "tar" "-cf" "layer.tar"
 159                                   (append %tar-determinism-options
 160                                           items
 161                                           (map symlink-source symlinks))))
 162                     (for-each delete-file-recursively
 163                               (map (compose topmost-component symlink-source)
 164                                    symlinks)))))
 165
 166            (with-output-to-file "config.json"
 167              (lambda ()
 168                (scm->json (config (string-append id "/layer.tar")
 169                                   time arch))))
 170            (with-output-to-file "manifest.json"
 171              (lambda ()
 172                (scm->json (manifest path id))))
 173            (with-output-to-file "repositories"
 174              (lambda ()
 175                (scm->json (repositories path id)))))
 176
 177          (and (zero? (apply system* "tar" "-C" directory "-cf" image
 178                             `(,@%tar-determinism-options
 179                               ,@(if compressor
 180                                     (list "-I" (string-join compressor))
 181                                     '())
 182                               ".")))
 183               (begin (delete-file-recursively directory) #t)))))