From f1f29b304131f3c0c88edf441fb84425dca50b42 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 21 Mar 2020 16:04:52 +0000 Subject: Rename (guix docker) to (guix build docker) --- Makefile.am | 2 +- gnu/system/vm.scm | 6 +- guix/docker.scm | 274 -------------------------------------------------- guix/scripts/pack.scm | 6 +- 4 files changed, 7 insertions(+), 281 deletions(-) delete mode 100644 guix/docker.scm diff --git a/Makefile.am b/Makefile.am index d5829f3633..bce2a31184 100644 --- a/Makefile.am +++ b/Makefile.am @@ -67,7 +67,6 @@ MODULES = \ guix/ci.scm \ guix/cpio.scm \ guix/deprecation.scm \ - guix/docker.scm \ guix/json.scm \ guix/records.scm \ guix/pki.scm \ @@ -156,6 +155,7 @@ MODULES = \ guix/status.scm \ guix/build/android-ndk-build-system.scm \ guix/build/ant-build-system.scm \ + guix/build/docker.scm \ guix/build/download.scm \ guix/build/download-nar.scm \ guix/build/cargo-build-system.scm \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index d1c131ecb4..0b0e3d10b8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -525,10 +525,10 @@ system." (name (string-append name ".tar.gz")) (graph "system-graph")) (define build - (with-extensions (cons guile-json-3 ;for (guix docker) + (with-extensions (cons guile-json-3 ;for (guix build docker) gcrypt-sqlite3&co) ;for (guix store database) (with-imported-modules `(,@(source-module-closure - '((guix docker) + '((guix build docker) (guix store database) (guix build utils) (guix build store-copy) @@ -536,7 +536,7 @@ system." #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin - (use-modules (guix docker) + (use-modules (guix build docker) (guix build utils) (gnu build vm) (srfi srfi-19) diff --git a/guix/docker.scm b/guix/docker.scm deleted file mode 100644 index 97ac6d982b..0000000000 --- a/guix/docker.scm +++ /dev/null @@ -1,274 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès -;;; Copyright © 2018 Chris Marusich -;;; -;;; 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 (gcrypt hash) - #:use-module (guix base16) - #:use-module ((guix build utils) - #:select (mkdir-p - delete-file-recursively - with-directory-excursion - invoke)) - #:use-module (gnu build install) - #:use-module (json) ;guile-json - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module ((texinfo string-utils) - #:select (escape-special-chars)) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:export (build-docker-image)) - -;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. -(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 (canonicalize-repository-name name) - "\"Repository\" names are restricted to roughtl [a-z0-9_.-]. -Return a version of TAG that follows these rules." - (define ascii-letters - (string->char-set "abcdefghijklmnopqrstuvwxyz")) - - (define separators - (string->char-set "_-.")) - - (define repo-char-set - (char-set-union char-set:digit ascii-letters separators)) - - (string-map (lambda (chr) - (if (char-set-contains? repo-char-set chr) - chr - #\.)) - (string-trim (string-downcase name) separators))) - -(define* (manifest path id #:optional (tag "guix")) - "Generate a simple image manifest." - (let ((tag (canonicalize-repository-name tag))) - `#(((Config . "config.json") - (RepoTags . #(,(string-append tag ":latest"))) - (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 #:optional (tag "guix")) - "Generate a repositories file referencing PATH and the image ID." - `((,(canonicalize-repository-name tag) . ((latest . ,id))))) - -;; See https://github.com/opencontainers/image-spec/blob/master/config.md -(define* (config layer time arch #:key entry-point (environment '())) - "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 . ,`((env . ,(list->vector - (map (match-lambda - ((name . value) - (string-append name "=" value))) - environment))) - ,@(if entry-point - `((entrypoint . ,(list->vector entry-point))) - '()))) - (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 directive-file - ;; Return the file or directory created by a 'evaluate-populate-directive' - ;; directive. - (match-lambda - ((source '-> target) - (string-trim source #\/)) - (('directory name _ ...) - (string-trim name #\/)))) - -(define* (build-docker-image image paths prefix - #:key - (repository "guix") - (extra-files '()) - (transformations '()) - (system (utsname:machine (uname))) - database - entry-point - (environment '()) - compressor - (creation-time (current-time time-utc))) - "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX -must be a store path that is a prefix of any store paths in PATHS. REPOSITORY -is a descriptive name that will show up in \"REPOSITORY\" column of the output -of \"docker images\". - -When DATABASE is true, copy it to /var/guix/db in the image and create -/var/guix/gcroots and friends. - -When ENTRY-POINT is true, it must be a list of strings; it is stored as the -entry point in the Docker image JSON structure. - -ENVIRONMENT must be a list of name/value pairs. It specifies the environment -variables that must be defined in the resulting image. - -EXTRA-FILES must be a list of directives for 'evaluate-populate-directive' -describing non-store files that must be created in the image. - -TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to -transform the PATHS. Any path in PATHS that begins with OLD will be rewritten -in the Docker image so that it begins with NEW instead. If a path is a -non-empty directory, then its contents will be recursively added, as well. - -SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in -PATHS are for; it is used to produce metadata in the image. 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." - (define (sanitize path-fragment) - (escape-special-chars - ;; GNU tar strips the leading slash off of absolute paths before applying - ;; the transformations, so we need to do the same, or else our - ;; replacements won't match any paths. - (string-trim path-fragment #\/) - ;; Escape the basic regexp special characters (see: "(sed) BRE syntax"). - ;; We also need to escape "/" because we use it as a delimiter. - "/*.^$[]\\" - #\\)) - (define transformation->replacement - (match-lambda - ((old '-> new) - ;; See "(tar) transform" for details on the expression syntax. - (string-append "s/^" (sanitize old) "/" (sanitize new) "/")))) - (define (transformations->expression transformations) - (let ((replacements (map transformation->replacement transformations))) - (string-append - ;; Avoid transforming link targets, since that would break some links - ;; (e.g., symlinks that point to an absolute store path). - "flags=rSH;" - (string-join replacements ";") - ;; Some paths might still have a leading path delimiter even after tar - ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so - ;; strip any leading path delimiters that remain. - ";s,^//*,,"))) - (define transformation-options - (if (eq? '() transformations) - '() - `("--transform" ,(transformations->expression transformations)))) - (let* ((directory "/tmp/docker-image") ;temporary working directory - (id (docker-id prefix)) - (time (date->string (time-utc->date creation-time) "~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"))))) - ;; Make sure we start with a fresh, empty working directory. - (mkdir directory) - (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)))) - - ;; 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 <> "./") - extra-files) - - (when database - ;; Initialize /var/guix, assuming PREFIX points to a profile. - (install-database-and-gc-roots "." database prefix)) - - (apply invoke "tar" "-cf" "../layer.tar" - `(,@transformation-options - ,@%tar-determinism-options - ,@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* "tar" "--delete" "/" "-f" "layer.tar"))) - - (delete-file-recursively "extra")) - - (with-output-to-file "config.json" - (lambda () - (scm->json (config (string-append id "/layer.tar") - time arch - #:environment environment - #:entry-point entry-point)))) - (with-output-to-file "manifest.json" - (lambda () - (scm->json (manifest prefix id repository)))) - (with-output-to-file "repositories" - (lambda () - (scm->json (repositories prefix id repository))))) - - (apply invoke "tar" "-cf" image "-C" directory - `(,@%tar-determinism-options - ,@(if compressor - (list "-I" (string-join compressor)) - '()) - ".")) - (delete-file-recursively directory))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 652b4c63c4..ee0395ea00 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -503,17 +503,17 @@ the image." (define defmod 'define-module) ;trick Geiser (define build - ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). + ;; Guile-JSON and Guile-Gcrypt are required by (guix build docker). (with-extensions (list guile-json-3 guile-gcrypt) (with-imported-modules `(((guix config) => ,(make-config.scm)) ,@(source-module-closure - `((guix docker) + `((guix build docker) (guix build store-copy) (guix profiles) (guix search-paths)) #:select? not-config?)) #~(begin - (use-modules (guix docker) (guix build store-copy) + (use-modules (guix build docker) (guix build store-copy) (guix profiles) (guix search-paths) (srfi srfi-1) (srfi srfi-19) (ice-9 match)) -- cgit v1.2.3