From b1edfbc37f2f008188d91f594b046c5986485e47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 16 Mar 2017 18:02:59 +0100 Subject: pack: Add '--format' option and Docker output support. * guix/docker.scm: Remove dependency on (guix store) and (guix utils). Use (guix build store-copy). Load (json) lazily. (build-docker-image): Remove #:system. Add #:closure, #:compressor, and 'image' parameters. Use 'uname' to determine the architecture. Remove use of 'call-with-temporary-directory'. Use 'read-reference-graph' to compute ITEMS. Honor #:compressor. * guix/scripts/pack.scm (docker-image): New procedure. (%default-options): Add 'format'. (%formats): New variable. (%options, show-help): Add '--format'. (guix-pack): Honor '--format'. * guix/scripts/archive.scm: Remove '--format' option. This reverts commits 1545a012cb7cd78e25ed99ecee26df457be590e9, 01445711db6771cea6122859c3f717f130359f55, and 03476a23ff2d4175b7d3c808726178f764359bec. * doc/guix.texi (Invoking guix pack): Document '--format'. (Invoking guix archive): Remove documentation of '--format'. --- guix/docker.scm | 103 ++++++++++++++++++++++++++++++-------------------------- 1 file changed, 56 insertions(+), 47 deletions(-) (limited to 'guix/docker.scm') diff --git a/guix/docker.scm b/guix/docker.scm index 6dabaf25b0..56a0f7ec2b 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,17 +19,18 @@ (define-module (guix docker) #:use-module (guix hash) - #:use-module (guix store) #:use-module (guix base16) - #:use-module (guix utils) #:use-module ((guix build utils) #:select (delete-file-recursively with-directory-excursion)) - #:use-module (json) + #:use-module (guix build store-copy) #: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 @@ -81,48 +83,55 @@ (rootfs . ((type . "layers") (diff_ids . (,(layer-diff-id layer))))))) -(define* (build-docker-image path #:key system) - "Generate a Docker image archive from the given store PATH. The image -contains the closure of the given store item." - (let ((id (docker-id path)) +(define* (build-docker-image image path #:key closure compressor) + "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). Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), +to compress IMAGE." + (let ((directory "/tmp/docker-image") ;temporary working directory + (closure (canonicalize-path closure)) + (id (docker-id path)) (time (strftime "%FT%TZ" (localtime (current-time)))) - (name (string-append (getcwd) - "/docker-image-" (basename path) ".tar")) - (arch (match system - ("x86_64-linux" "amd64") - ("i686-linux" "386") - ("armhf-linux" "arm") - ("mips64el-linux" "mips64le")))) - (and (call-with-temporary-directory - (lambda (directory) - (with-directory-excursion directory - ;; Add symlink from /bin to /gnu/store/.../bin - (symlink (string-append path "/bin") "bin") - - (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 (with-store store - (requisites store (list path))))) - (and (zero? (apply system* "tar" "-cf" "layer.tar" - (cons "../bin" items))) - (delete-file "../bin")))) - - (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? (system* "tar" "-C" directory "-cf" name ".")) - (begin (delete-file-recursively directory) #t)))) - name))) + (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 + ;; Add symlink from /bin to /gnu/store/.../bin + (symlink (string-append path "/bin") "bin") + + (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))) + (and (zero? (apply system* "tar" "-cf" "layer.tar" + (cons "../bin" items))) + (delete-file "../bin")))) + + (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 + `(,@(if compressor + (list "-I" (string-join compressor)) + '()) + "."))) + (begin (delete-file-recursively directory) #t))))) -- cgit v1.2.3