[jackhill/guix/guix.git] / guix / docker.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 base16)
  #:use-module ((guix build utils)
                #:select (mkdir-p
                          delete-file-recursively
                          with-directory-excursion))
  #:use-module (guix build store-copy)
  #:use-module (srfi srfi-19)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:export (build-docker-image))

;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
(module-use! (current-module) (resolve-interface '(json)))

;; 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 %tar-determinism-options
  ;; GNU tar options to produce archives deterministically.
  '("--sort=name" "--mtime=@1"
    "--owner=root:0" "--group=root:0"))

(define symlink-source
  (match-lambda
    ((source '-> target)
     (string-trim source #\/))))

(define (topmost-component file)
  "Return the topmost component of FILE.  For instance, if FILE is \"/a/b/c\",
return \"a\"."
  (match (string-tokenize file (char-set-complement (char-set #\/)))
    ((first rest ...)
     first)))

(define* (build-docker-image image path
                             #:key closure compressor
                             (symlinks '())
                             (creation-time (current-time time-utc)))
  "Write to IMAGE a Docker image archive from the given store PATH.  The image
contains the closure of PATH, as specified in CLOSURE (a file produced by
#:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
describing symlinks to be created in the image, where each TARGET is relative
to PATH.

Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use
CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
  (let ((directory "/tmp/docker-image")           ;temporary working directory
        (closure (canonicalize-path closure))
        (id (docker-id path))
        (time (date->string (time-utc->date creation-time) "~4"))
        (arch (match (utsname:machine (uname))
                ("x86_64" "amd64")
                ("i686"   "386")
                ("armv7l" "arm")
                ("mips64" "mips64le"))))
    ;; Make sure we start with a fresh, empty working directory.
    (mkdir directory)

    (and (with-directory-excursion directory
           (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 (call-with-input-file closure
                            read-reference-graph)))
               ;; Create SYMLINKS.
               (for-each (match-lambda
                           ((source '-> target)
                            (let ((source (string-trim source #\/)))
                              (mkdir-p (dirname source))
                              (symlink (string-append path "/" target)
                                       source))))
                         symlinks)

               (and (zero? (apply system* "tar" "-cf" "layer.tar"
                                  (append %tar-determinism-options
                                          items
                                          (map symlink-source symlinks))))
                    (for-each delete-file-recursively
                              (map (compose topmost-component symlink-source)
                                   symlinks)))))

           (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? (apply system* "tar" "-C" directory "-cf" image
                            `(,@%tar-determinism-options
                              ,@(if compressor
                                    (list "-I" (string-join compressor))
                                    '())
                              ".")))
              (begin (delete-file-recursively directory) #t)))))
Commit	Line	Data
03476a23 RW	1	;;; GNU Guix --- Functional package management for GNU
03476a23 RW	2	;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
b1edfbc3	3	;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
03476a23 RW	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (guix docker)
	21	#:use-module (guix hash)
4c0c4db0	22	#:use-module (guix base16)
03476a23	23	#:use-module ((guix build utils)
9e84ea36 LC	24	#:select (mkdir-p
9e84ea36 LC	25	delete-file-recursively
03476a23	26	with-directory-excursion))
b1edfbc3	27	#:use-module (guix build store-copy)
84dda5a9	28	#:use-module (srfi srfi-19)
03476a23 RW	29	#:use-module (rnrs bytevectors)
	30	#:use-module (ice-9 match)
	31	#:export (build-docker-image))
	32
b1edfbc3 LC	33	;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
	34	(module-use! (current-module) (resolve-interface '(json)))
	35
03476a23 RW	36	;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
	37	;; containing the closure at PATH.
	38	(define docker-id
	39	(compose bytevector->base16-string sha256 string->utf8))
	40
	41	(define (layer-diff-id layer)
	42	"Generate a layer DiffID for the given LAYER archive."
	43	(string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
	44
	45	;; This is the semantic version of the JSON metadata schema according to
	46	;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
	47	;; It is NOT the version of the image specification.
	48	(define schema-version "1.0")
	49
	50	(define (image-description id time)
	51	"Generate a simple image description."
	52	`((id . ,id)
	53	(created . ,time)
	54	(container_config . #nil)))
	55
	56	(define (generate-tag path)
	57	"Generate an image tag for the given PATH."
	58	(match (string-split (basename path) #\-)
	59	((hash name . rest) (string-append name ":" hash))))
	60
	61	(define (manifest path id)
	62	"Generate a simple image manifest."
	63	`(((Config . "config.json")
	64	(RepoTags . (,(generate-tag path)))
	65	(Layers . (,(string-append id "/layer.tar"))))))
	66
	67	;; According to the specifications this is required for backwards
	68	;; compatibility. It duplicates information provided by the manifest.
	69	(define (repositories path id)
	70	"Generate a repositories file referencing PATH and the image ID."
	71	`((,(generate-tag path) . ((latest . ,id)))))
	72
	73	;; See https://github.com/opencontainers/image-spec/blob/master/config.md
	74	(define (config layer time arch)
	75	"Generate a minimal image configuration for the given LAYER file."
	76	;; "architecture" must be values matching "platform.arch" in the
	77	;; runtime-spec at
	78	;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
	79	`((architecture . ,arch)
	80	(comment . "Generated by GNU Guix")
	81	(created . ,time)
	82	(config . #nil)
	83	(container_config . #nil)
	84	(os . "linux")
	85	(rootfs . ((type . "layers")
	86	(diff_ids . (,(layer-diff-id layer)))))))
	87
54241dc8 LC	88	(define %tar-determinism-options
	89	;; GNU tar options to produce archives deterministically.
	90	'("--sort=name" "--mtime=@1"
	91	"--owner=root:0" "--group=root:0"))
	92
9e84ea36 LC	93	(define symlink-source
	94	(match-lambda
	95	((source '-> target)
	96	(string-trim source #\/))))
	97
	98	(define (topmost-component file)
	99	"Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\",
	100	return \"a\"."
	101	(match (string-tokenize file (char-set-complement (char-set #\/)))
	102	((first rest ...)
	103	first)))
	104
84dda5a9 LC	105	(define* (build-docker-image image path
84dda5a9 LC	106	#:key closure compressor
9e84ea36	107	(symlinks '())
84dda5a9	108	(creation-time (current-time time-utc)))
b1edfbc3 LC	109	"Write to IMAGE a Docker image archive from the given store PATH. The image
b1edfbc3 LC	110	contains the closure of PATH, as specified in CLOSURE (a file produced by
9e84ea36 LC	111	#:references-graphs). SYMLINKS must be a list of (SOURCE -> TARGET) tuples
	112	describing symlinks to be created in the image, where each TARGET is relative
	113	to PATH.
	114
	115	Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use
	116	CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
b1edfbc3 LC	117	(let ((directory "/tmp/docker-image") ;temporary working directory
	118	(closure (canonicalize-path closure))
	119	(id (docker-id path))
84dda5a9	120	(time (date->string (time-utc->date creation-time) "~4"))
b1edfbc3 LC	121	(arch (match (utsname:machine (uname))
	122	("x86_64" "amd64")
	123	("i686" "386")
	124	("armv7l" "arm")
	125	("mips64" "mips64le"))))
	126	;; Make sure we start with a fresh, empty working directory.
	127	(mkdir directory)
	128
	129	(and (with-directory-excursion directory
b1edfbc3 LC	130	(mkdir id)
	131	(with-directory-excursion id
	132	(with-output-to-file "VERSION"
	133	(lambda () (display schema-version)))
	134	(with-output-to-file "json"
	135	(lambda () (scm->json (image-description id time))))
	136
9e84ea36	137	;; Wrap it up.
b1edfbc3 LC	138	(let ((items (call-with-input-file closure
b1edfbc3 LC	139	read-reference-graph)))
9e84ea36 LC	140	;; Create SYMLINKS.
	141	(for-each (match-lambda
	142	((source '-> target)
	143	(let ((source (string-trim source #\/)))
	144	(mkdir-p (dirname source))
	145	(symlink (string-append path "/" target)
	146	source))))
	147	symlinks)
	148
b1edfbc3	149	(and (zero? (apply system* "tar" "-cf" "layer.tar"
54241dc8	150	(append %tar-determinism-options
9e84ea36 LC	151	items
	152	(map symlink-source symlinks))))
	153	(for-each delete-file-recursively
	154	(map (compose topmost-component symlink-source)
	155	symlinks)))))
b1edfbc3 LC	156
	157	(with-output-to-file "config.json"
	158	(lambda ()
	159	(scm->json (config (string-append id "/layer.tar")
	160	time arch))))
	161	(with-output-to-file "manifest.json"
	162	(lambda ()
	163	(scm->json (manifest path id))))
	164	(with-output-to-file "repositories"
	165	(lambda ()
	166	(scm->json (repositories path id)))))
	167
	168	(and (zero? (apply system* "tar" "-C" directory "-cf" image
54241dc8 LC	169	`(,@%tar-determinism-options
54241dc8 LC	170	,@(if compressor
b1edfbc3 LC	171	(list "-I" (string-join compressor))
	172	'())
	173	".")))
	174	(begin (delete-file-recursively directory) #t)))))