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
| | ;;; 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 build utils)
#:select (delete-file-recursively
with-directory-excursion))
#:use-module (json)
#:use-module (rnrs bytevectors)
#:export (build-docker-image))
(define (hexencode bv)
"Return the hexadecimal representation of the bytevector BV."
(format #f "~{~2,'0x~}" (bytevector->u8-list bv)))
(define (docker-id path)
"Generate a 256-bit identifier in hexadecimal encoding for the Docker image
containing the closure at PATH."
(hexencode (sha256 (string->utf8 path))))
(define (layer-diff-id layer)
"Generate a layer DiffID for the given LAYER archive."
(string-append "sha256:" (hexencode (file-sha256 layer))))
(define spec-version "1.0")
(define (image-description id time)
"Generate a simple image description."
`((id . ,id)
(created . ,time)
(container_config . #nil)))
(define (manifest id)
"Generate a simple image manifest."
`(((Config . "config.json")
(RepoTags . #nil)
(Layers . (,(string-append id "/layer.tar"))))))
(define (repositories path id)
"Generate a repositories file referencing PATH and the image ID."
`((,(basename path) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define (config layer time)
"Generate a minimal image configuratio for the given LAYER file."
`((architecture . "amd64")
(comment . "Generated by GNU Guix")
(created . ,time)
(config . #nil)
(container_config . #nil)
(os . "linux")
(rootfs . ((type . "layers")
(diff_ids . (,(layer-diff-id layer)))))))
;; TODO: heroically copied from guix/script/pull.scm
(define (temporary-directory)
"Make a temporary directory and return its name."
(let ((name (tmpnam)))
(mkdir name)
(chmod name #o700)
name))
(define (build-docker-image path)
"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))
(directory (temporary-directory))
(time (strftime "%FT%TZ" (localtime (current-time)))))
(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 spec-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))))
(with-output-to-file "manifest.json"
(lambda ()
(scm->json (manifest id))))
(with-output-to-file "repositories"
(lambda ()
(scm->json (repositories path id)))))
(let ((name (string-append (getcwd)
"/docker-image-" (basename path) ".tar")))
(and (zero? (system* "tar" "-C" directory "-cf" name "."))
(delete-file-recursively directory)
name))))
|