aboutsummaryrefslogtreecommitdiff
path: root/guix/docker.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/docker.scm')
-rw-r--r--guix/docker.scm246
1 files changed, 246 insertions, 0 deletions
diff --git a/guix/docker.scm b/guix/docker.scm
new file mode 100644
index 0000000000..47bc2e8f99
--- /dev/null
+++ b/guix/docker.scm
@@ -0,0 +1,246 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.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 (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 match)
+ #:use-module (guix gexp)
+ #:use-module (guix modules)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages compression)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages gnupg)
+ #:export (docker-image-layer
+ docker-image-layer-name
+ docker-image-layer-store-paths
+ docker-image-layer-transformations
+ docker-image-layer-extra-files
+ docker-image-layer-extra-gexp
+
+ docker-image
+ docker-image-name
+ docker-image-layers
+ docker-image-repository
+ docker-image-entry-point
+ docker-image-environment
+ docker-image-compressor
+ docker-image-creation-time))
+
+
+(define-record-type <docker-image-layer>
+ (%docker-image-layer name store-paths transformations extra-files extra-gexp
+ creation-time)
+ docker-image-layer?
+ (name docker-image-layer-name)
+ (store-paths docker-image-layer-store-paths)
+ (transformations docker-image-layer-transformations)
+ (extra-files docker-image-layer-extra-files)
+ (extra-gexp docker-image-layer-extra-gexp)
+ (creation-time docker-image-layer-creation-time))
+
+
+(define* (docker-image-layer name store-paths
+ #:key (transformations '())
+ (extra-files '()) extra-gexp
+ (creation-time (make-time time-utc 0 1)))
+ (%docker-image-layer name store-paths transformations extra-files extra-gexp
+ creation-time))
+
+(define-gexp-compiler (docker-image-layer-compiler (layer <docker-image-layer>)
+ system target)
+ (match layer
+ (($ <docker-image-layer> name store-paths transformations
+ extra-files extra-gexp creation-time)
+ (gexp->derivation
+ name
+ (with-extensions (list guile-json-3 ;for (guix build docker)
+ guile-gcrypt)
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build docker)
+ (guix build utils)
+ (guix build store-copy))))
+ #~(begin
+ (use-modules (srfi srfi-26)
+ (ice-9 ftw)
+ (json)
+ (guix build utils)
+ (guix build docker))
+
+ (let ((out #$output)
+ (store-paths (list #$@store-paths))
+ (transformations (list #$@transformations))
+ (time #$(date->string (time-utc->date creation-time 0) "~4")))
+
+ (define transformation-options
+ (if (null? transformations)
+ '()
+ `("--transform" ,(transformations->expression transformations))))
+
+ (define layer-id
+ (docker-id out))
+
+ (mkdir out)
+ (with-directory-excursion out
+ (with-output-to-file "VERSION"
+ (lambda () (display schema-version)))
+ (with-output-to-file "json"
+ (lambda () (scm->json (image-description layer-id time))))
+
+ ;; Create a directory for the non-store files that need to
+ ;; go into the archive.
+ (mkdir "extra")
+
+ (with-directory-excursion "extra"
+ ;; Create non-store files.
+ (for-each (cut evaluate-populate-directive <> "./")
+ (list #$@extra-files))
+
+ (apply invoke #$(file-append tar "/bin/tar")
+ "-cf" "../layer.tar"
+ `(,@transformation-options
+ ,@%tar-determinism-options
+ ,@store-paths
+ ,@(scandir "."
+ (lambda (file)
+ (not (member file '("." ".."))))))))
+
+ ;; It is possible for "/" to show up in the archive,
+ ;; especially when applying transformations. For example,
+ ;; the transformation "s,^/a,," will (perhaps surprisingly)
+ ;; cause GNU tar to transform the path "/a" into "/". The
+ ;; presence of "/" in the archive is probably benign, but it
+ ;; is definitely safe to remove it, so let's do that. This
+ ;; fails when "/" is not in the archive, so use system*
+ ;; instead of invoke to avoid an exception in that case, and
+ ;; redirect stderr to the bit bucket to avoid "Exiting with
+ ;; failure status" error messages.
+ (with-error-to-port (%make-void-port "w")
+ (lambda ()
+ (system* #$(file-append tar "/bin/tar")
+ "--delete" "/" "-f" "layer.tar")))
+
+ (delete-file-recursively "extra"))))))
+ #:system system
+ #:target target))))
+
+
+(define-record-type <docker-image>
+ (%docker-image name layers repository entry-point
+ environment compressor creation-time)
+ docker-image?
+ (name docker-image-name)
+ (layers docker-image-layers)
+ (repository docker-image-repository)
+ (entry-point docker-image-entry-point)
+ (environment docker-image-environment)
+ (compressor docker-image-compressor)
+ (creation-time docker-image-creation-time))
+
+(define* (docker-image name layers
+ #:key
+ (repository "guix")
+ entry-point
+ (environment '())
+ (compressor
+ #~(#+(file-append gzip "/bin/gzip") "-9n"))
+ (creation-time (make-time time-utc 0 1)))
+
+ (%docker-image name layers repository entry-point
+ environment compressor creation-time))
+
+(define-gexp-compiler (docker-image-compiler (image <docker-image>)
+ system target)
+ (match image
+ (($ <docker-image> name layers repository entry-point
+ environment compressor creation-time)
+ (gexp->derivation
+ name
+ (with-extensions (list guile-json-3 ;for (guix build docker)
+ guile-gcrypt)
+ (with-imported-modules `(,@(source-module-closure
+ '((guix build docker)
+ (guix build utils)
+ (guix build store-copy))))
+ #~(begin
+ (use-modules (srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 ftw)
+ (json)
+ (guix build utils)
+ (guix build docker))
+ (let* ((out #$output)
+ (directory "/tmp/docker-image") ;temporary working directory
+ (id (docker-id out))
+ (repository #$repository)
+ (time #$(date->string (time-utc->date creation-time 0) "~4"))
+ (arch (let-syntax ((cond* (syntax-rules ()
+ ((_ (pattern clause) ...)
+ (cond ((string-prefix? pattern #$system)
+ clause)
+ ...
+ (else
+ (error "unsupported system"
+ system)))))))
+ (cond* ("x86_64" "amd64")
+ ("i686" "386")
+ ("arm" "arm")
+ ("mips64" "mips64le"))))
+ (layers (list #$@ layers))
+ (layer-docker-ids
+ (map docker-id layers))
+ (compressor
+ (list #$@compressor)))
+
+ ;; Make sure we start with a fresh, empty working directory.
+ (mkdir directory)
+ (with-directory-excursion directory
+ (for-each symlink
+ layers
+ layer-docker-ids)
+
+ (with-output-to-file "config.json"
+ (lambda ()
+ (scm->json (config (map (lambda (id)
+ (string-append id "/layer.tar"))
+ layer-docker-ids)
+ time arch
+ #:environment '#$environment
+ #$@(if entry-point
+ #~(#:entry-point
+ (list #$@entry-point))
+ '())))))
+ (with-output-to-file "manifest.json"
+ (lambda ()
+ (scm->json (manifest layer-docker-ids repository))))
+ (with-output-to-file "repositories"
+ (lambda ()
+ (scm->json (repositories (last layer-docker-ids)
+ repository)))))
+
+ (apply invoke
+ #$(file-append tar "/bin/tar")
+ "-cf" out
+ "--dereference" ;; to follow the layer symlinks
+ "-C" directory
+ `(,@%tar-determinism-options
+ ,@(if compressor
+ (list "-I" (string-join compressor))
+ '())
+ "."))
+ (delete-file-recursively directory)))))))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-16 01:39:07 +0000