guix/docker.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix docker)
  20   #:use-module (guix hash)
  21   #:use-module (guix store)
  22   #:use-module (guix base16)
  23   #:use-module (guix utils)
  24   #:use-module ((guix build utils)
  25                 #:select (delete-file-recursively
  26                           with-directory-excursion))
  27   #:use-module (json)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (ice-9 match)
  30   #:export (build-docker-image))
  31
  32 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
  33 ;; containing the closure at PATH.
  34 (define docker-id
  35   (compose bytevector->base16-string sha256 string->utf8))
  36
  37 (define (layer-diff-id layer)
  38   "Generate a layer DiffID for the given LAYER archive."
  39   (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
  40
  41 ;; This is the semantic version of the JSON metadata schema according to
  42 ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
  43 ;; It is NOT the version of the image specification.
  44 (define schema-version "1.0")
  45
  46 (define (image-description id time)
  47   "Generate a simple image description."
  48   `((id . ,id)
  49     (created . ,time)
  50     (container_config . #nil)))
  51
  52 (define (generate-tag path)
  53   "Generate an image tag for the given PATH."
  54   (match (string-split (basename path) #\-)
  55     ((hash name . rest) (string-append name ":" hash))))
  56
  57 (define (manifest path id)
  58   "Generate a simple image manifest."
  59   `(((Config . "config.json")
  60      (RepoTags . (,(generate-tag path)))
  61      (Layers . (,(string-append id "/layer.tar"))))))
  62
  63 ;; According to the specifications this is required for backwards
  64 ;; compatibility.  It duplicates information provided by the manifest.
  65 (define (repositories path id)
  66   "Generate a repositories file referencing PATH and the image ID."
  67   `((,(generate-tag path) . ((latest . ,id)))))
  68
  69 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
  70 (define (config layer time arch)
  71   "Generate a minimal image configuration for the given LAYER file."
  72   ;; "architecture" must be values matching "platform.arch" in the
  73   ;; runtime-spec at
  74   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  75   `((architecture . ,arch)
  76     (comment . "Generated by GNU Guix")
  77     (created . ,time)
  78     (config . #nil)
  79     (container_config . #nil)
  80     (os . "linux")
  81     (rootfs . ((type . "layers")
  82                (diff_ids . (,(layer-diff-id layer)))))))
  83
  84 (define* (build-docker-image path #:key system)
  85   "Generate a Docker image archive from the given store PATH.  The image
  86 contains the closure of the given store item."
  87   (let ((id (docker-id path))
  88         (time (strftime "%FT%TZ" (localtime (current-time))))
  89         (name (string-append (getcwd)
  90                              "/docker-image-" (basename path) ".tar"))
  91         (arch (match system
  92                 ("x86_64-linux" "amd64")
  93                 ("i686-linux" "386")
  94                 ("armhf-linux" "arm")
  95                 ("mips64el-linux" "mips64le"))))
  96     (and (call-with-temporary-directory
  97           (lambda (directory)
  98             (with-directory-excursion directory
  99               ;; Add symlink from /bin to /gnu/store/.../bin
 100               (symlink (string-append path "/bin") "bin")
 101
 102               (mkdir id)
 103               (with-directory-excursion id
 104                 (with-output-to-file "VERSION"
 105                   (lambda () (display schema-version)))
 106                 (with-output-to-file "json"
 107                   (lambda () (scm->json (image-description id time))))
 108
 109                 ;; Wrap it up
 110                 (let ((items (with-store store
 111                                (requisites store (list path)))))
 112                   (and (zero? (apply system* "tar" "-cf" "layer.tar"
 113                                      (cons "../bin" items)))
 114                        (delete-file "../bin"))))
 115
 116               (with-output-to-file "config.json"
 117                 (lambda ()
 118                   (scm->json (config (string-append id "/layer.tar")
 119                                      time arch))))
 120               (with-output-to-file "manifest.json"
 121                 (lambda ()
 122                   (scm->json (manifest path id))))
 123               (with-output-to-file "repositories"
 124                 (lambda ()
 125                   (scm->json (repositories path id)))))
 126             (and (zero? (system* "tar" "-C" directory "-cf" name "."))
 127                  (begin (delete-file-recursively directory) #t))))
 128          name)))