;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Christopher Baines ;;; ;;; 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 . (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 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 ) system target) (match 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 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 ) system target) (match 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)))))))))