You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

226 lines
9.5 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
  3. ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  4. ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix docker)
  21. #:use-module (gcrypt hash)
  22. #:use-module (guix base16)
  23. #:use-module ((guix build utils)
  24. #:select (mkdir-p
  25. delete-file-recursively
  26. with-directory-excursion
  27. invoke))
  28. #:use-module (json) ;guile-json
  29. #:use-module (srfi srfi-19)
  30. #:use-module (srfi srfi-26)
  31. #:use-module ((texinfo string-utils)
  32. #:select (escape-special-chars))
  33. #:use-module (rnrs bytevectors)
  34. #:use-module (ice-9 match)
  35. #:export (build-docker-image))
  36. ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
  37. (define docker-id
  38. (compose bytevector->base16-string sha256 string->utf8))
  39. (define (layer-diff-id layer)
  40. "Generate a layer DiffID for the given LAYER archive."
  41. (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
  42. ;; This is the semantic version of the JSON metadata schema according to
  43. ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
  44. ;; It is NOT the version of the image specification.
  45. (define schema-version "1.0")
  46. (define (image-description id time)
  47. "Generate a simple image description."
  48. `((id . ,id)
  49. (created . ,time)
  50. (container_config . #nil)))
  51. (define (generate-tag path)
  52. "Generate an image tag for the given PATH."
  53. (match (string-split (basename path) #\-)
  54. ((hash name . rest) (string-append name ":" hash))))
  55. (define (manifest path id)
  56. "Generate a simple image manifest."
  57. `(((Config . "config.json")
  58. (RepoTags . (,(generate-tag path)))
  59. (Layers . (,(string-append id "/layer.tar"))))))
  60. ;; According to the specifications this is required for backwards
  61. ;; compatibility. It duplicates information provided by the manifest.
  62. (define (repositories path id)
  63. "Generate a repositories file referencing PATH and the image ID."
  64. `((,(generate-tag path) . ((latest . ,id)))))
  65. ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
  66. (define (config layer time arch)
  67. "Generate a minimal image configuration for the given LAYER file."
  68. ;; "architecture" must be values matching "platform.arch" in the
  69. ;; runtime-spec at
  70. ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  71. `((architecture . ,arch)
  72. (comment . "Generated by GNU Guix")
  73. (created . ,time)
  74. (config . #nil)
  75. (container_config . #nil)
  76. (os . "linux")
  77. (rootfs . ((type . "layers")
  78. (diff_ids . (,(layer-diff-id layer)))))))
  79. (define %tar-determinism-options
  80. ;; GNU tar options to produce archives deterministically.
  81. '("--sort=name" "--mtime=@1"
  82. "--owner=root:0" "--group=root:0"))
  83. (define symlink-source
  84. (match-lambda
  85. ((source '-> target)
  86. (string-trim source #\/))))
  87. (define (topmost-component file)
  88. "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\",
  89. return \"a\"."
  90. (match (string-tokenize file (char-set-complement (char-set #\/)))
  91. ((first rest ...)
  92. first)))
  93. (define* (build-docker-image image paths prefix
  94. #:key
  95. (symlinks '())
  96. (transformations '())
  97. (system (utsname:machine (uname)))
  98. compressor
  99. (creation-time (current-time time-utc)))
  100. "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
  101. must be a store path that is a prefix of any store paths in PATHS.
  102. SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
  103. created in the image, where each TARGET is relative to PREFIX.
  104. TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
  105. transform the PATHS. Any path in PATHS that begins with OLD will be rewritten
  106. in the Docker image so that it begins with NEW instead. If a path is a
  107. non-empty directory, then its contents will be recursively added, as well.
  108. SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
  109. PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a
  110. command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a
  111. SRFI-19 time-utc object, as the creation time in metadata."
  112. (define (sanitize path-fragment)
  113. (escape-special-chars
  114. ;; GNU tar strips the leading slash off of absolute paths before applying
  115. ;; the transformations, so we need to do the same, or else our
  116. ;; replacements won't match any paths.
  117. (string-trim path-fragment #\/)
  118. ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
  119. ;; We also need to escape "/" because we use it as a delimiter.
  120. "/*.^$[]\\"
  121. #\\))
  122. (define transformation->replacement
  123. (match-lambda
  124. ((old '-> new)
  125. ;; See "(tar) transform" for details on the expression syntax.
  126. (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
  127. (define (transformations->expression transformations)
  128. (let ((replacements (map transformation->replacement transformations)))
  129. (string-append
  130. ;; Avoid transforming link targets, since that would break some links
  131. ;; (e.g., symlinks that point to an absolute store path).
  132. "flags=rSH;"
  133. (string-join replacements ";")
  134. ;; Some paths might still have a leading path delimiter even after tar
  135. ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
  136. ;; strip any leading path delimiters that remain.
  137. ";s,^//*,,")))
  138. (define transformation-options
  139. (if (eq? '() transformations)
  140. '()
  141. `("--transform" ,(transformations->expression transformations))))
  142. (let* ((directory "/tmp/docker-image") ;temporary working directory
  143. (id (docker-id prefix))
  144. (time (date->string (time-utc->date creation-time) "~4"))
  145. (arch (let-syntax ((cond* (syntax-rules ()
  146. ((_ (pattern clause) ...)
  147. (cond ((string-prefix? pattern system)
  148. clause)
  149. ...
  150. (else
  151. (error "unsupported system"
  152. system)))))))
  153. (cond* ("x86_64" "amd64")
  154. ("i686" "386")
  155. ("arm" "arm")
  156. ("mips64" "mips64le")))))
  157. ;; Make sure we start with a fresh, empty working directory.
  158. (mkdir directory)
  159. (with-directory-excursion directory
  160. (mkdir id)
  161. (with-directory-excursion id
  162. (with-output-to-file "VERSION"
  163. (lambda () (display schema-version)))
  164. (with-output-to-file "json"
  165. (lambda () (scm->json (image-description id time))))
  166. ;; Create SYMLINKS.
  167. (for-each (match-lambda
  168. ((source '-> target)
  169. (let ((source (string-trim source #\/)))
  170. (mkdir-p (dirname source))
  171. (symlink (string-append prefix "/" target)
  172. source))))
  173. symlinks)
  174. (apply invoke "tar" "-cf" "layer.tar"
  175. `(,@transformation-options
  176. ,@%tar-determinism-options
  177. ,@paths
  178. ,@(map symlink-source symlinks)))
  179. ;; It is possible for "/" to show up in the archive, especially when
  180. ;; applying transformations. For example, the transformation
  181. ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
  182. ;; the path "/a" into "/". The presence of "/" in the archive is
  183. ;; probably benign, but it is definitely safe to remove it, so let's
  184. ;; do that. This fails when "/" is not in the archive, so use system*
  185. ;; instead of invoke to avoid an exception in that case.
  186. (system* "tar" "--delete" "/" "-f" "layer.tar")
  187. (for-each delete-file-recursively
  188. (map (compose topmost-component symlink-source)
  189. symlinks)))
  190. (with-output-to-file "config.json"
  191. (lambda ()
  192. (scm->json (config (string-append id "/layer.tar")
  193. time arch))))
  194. (with-output-to-file "manifest.json"
  195. (lambda ()
  196. (scm->json (manifest prefix id))))
  197. (with-output-to-file "repositories"
  198. (lambda ()
  199. (scm->json (repositories prefix id)))))
  200. (apply invoke "tar" "-cf" image "-C" directory
  201. `(,@%tar-determinism-options
  202. ,@(if compressor
  203. (list "-I" (string-join compressor))
  204. '())
  205. "."))
  206. (delete-file-recursively directory)))