129 lines
5.1 KiB
Scheme
129 lines
5.1 KiB
Scheme
;;; 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)))
|