guix-kreyren/guix/docker.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; 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 (guix base16)
  #:use-module (guix utils)
  #:use-module ((guix build utils)
                #:select (delete-file-recursively
                          with-directory-excursion))
  #:use-module (json)
  #:use-module (rnrs bytevectors)
  #: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.
(define docker-id
  (compose bytevector->base16-string sha256 string->utf8))

(define (layer-diff-id layer)
  "Generate a layer DiffID for the given LAYER archive."
  (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))

;; This is the semantic version of the JSON metadata schema according to
;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
;; It is NOT the version of the image specification.
(define schema-version "1.0")

(define (image-description id time)
  "Generate a simple image description."
  `((id . ,id)
    (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 (manifest path id)
  "Generate a simple image manifest."
  `(((Config . "config.json")
     (RepoTags . (,(generate-tag path)))
     (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)
  "Generate a repositories file referencing PATH and the image ID."
  `((,(generate-tag path) . ((latest . ,id)))))

;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define (config layer time arch)
  "Generate a minimal image configuration for the given LAYER file."
  ;; "architecture" must be values matching "platform.arch" in the
  ;; runtime-spec at
  ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  `((architecture . ,arch)
    (comment . "Generated by GNU Guix")
    (created . ,time)
    (config . #nil)
    (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)))