1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
;;; 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 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)))
|