From b1edfbc37f2f008188d91f594b046c5986485e47 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès 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 ++++++++++++++++++++++++++--------------------- guix/scripts/archive.scm | 31 ++------------ guix/scripts/pack.scm | 95 ++++++++++++++++++++++++++++++++++++++----- 3 files changed, 144 insertions(+), 85 deletions(-) (limited to 'guix') 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))))) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index cad279fb50..8137455a9d 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,6 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès -;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,11 +44,6 @@ #:export (guix-archive options->derivations+files)) -;; XXX: Use this hack instead of #:autoload to avoid compilation errors. -;; See . -(module-autoload! (current-module) - '(guix docker) '(build-docker-image)) - ;;; ;;; Command-line options. @@ -57,8 +51,7 @@ (define %default-options ;; Alist of default option values. - `((format . "nar") - (system . ,(%current-system)) + `((system . ,(%current-system)) (substitutes? . #t) (graft? . #t) (max-silent-time . 3600) @@ -69,8 +62,6 @@ Export/import one or more packages from/to the store.\n")) (display (_ " --export export the specified files/packages to stdout")) - (display (_ " - --format=FMT export files/packages in the specified format FMT")) (display (_ " -r, --recursive combined with '--export', include dependencies")) (display (_ " @@ -126,9 +117,6 @@ Export/import one or more packages from/to the store.\n")) (option '("export") #f #f (lambda (opt name arg result) (alist-cons 'export #t result))) - (option '(#\f "format") #t #f - (lambda (opt name arg result . rest) - (alist-cons 'format arg result))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'export-recursive? #t result))) @@ -258,21 +246,8 @@ resulting archive to the standard output port." (if (or (assoc-ref opts 'dry-run?) (build-derivations store drv)) - (match (assoc-ref opts 'format) - ("nar" - (export-paths store files (current-output-port) - #:recursive? (assoc-ref opts 'export-recursive?))) - ("docker" - (match files - ((file) - (let ((system (assoc-ref opts 'system))) - (format #t "~a\n" - (build-docker-image file #:system system)))) - (x - ;; TODO: Remove this restriction. - (leave (_ "only a single item can be exported to Docker~%"))))) - (format - (leave (_ "~a: unknown archive format~%") format))) + (export-paths store files (current-output-port) + #:recursive? (assoc-ref opts 'export-recursive?)) (leave (_ "unable to export the given packages~%"))))) (define (generate-key-pair parameters) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e422b3cdda..c6f2145c5c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -24,6 +24,7 @@ #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix monads) + #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) @@ -32,6 +33,8 @@ #:use-module (gnu packages compression) #:autoload (gnu packages base) (tar) #:autoload (gnu packages package-management) (guix) + #:autoload (gnu packages gnupg) (libgcrypt) + #:autoload (gnu packages guile) (guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-37) @@ -177,6 +180,59 @@ added to the pack." build #:references-graphs `(("profile" ,profile)))) +(define* (docker-image name profile + #:key deduplicate? + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (tar tar)) + "Return a derivation to construct a Docker image of PROFILE. The +image is a tarball conforming to the Docker Image Specification, compressed +with COMPRESSOR. It can be passed to 'docker load'." + ;; FIXME: Honor SYMLINKS and LOCALSTATEDIR?. + (define not-config? + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + + (define config + ;; (guix config) module for consumption by (guix gcrypt). + (scheme-file "gcrypt-config.scm" + #~(begin + (define-module (guix config) + #:export (%libgcrypt)) + + ;; XXX: Work around . + (eval-when (expand load eval) + (define %libgcrypt + #+(file-append libgcrypt "/lib/libgcrypt")))))) + + (define build + (with-imported-modules `(,@(source-module-closure '((guix docker)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + ;; Guile-JSON is required by (guix docker). + (add-to-load-path + (string-append #$guile-json "/share/guile/site/" + (effective-version))) + + (use-modules (guix docker)) + + (setenv "PATH" + (string-append #$tar "/bin:" + #$(compressor-package compressor) "/bin")) + + (build-docker-image #$output #$profile + #:closure "profile" + #:compressor '#$(compressor-command compressor))))) + + (gexp->derivation (string-append name ".tar." + (compressor-extension compressor)) + build + #:references-graphs `(("profile" ,profile)))) ;;; @@ -185,7 +241,8 @@ added to the pack." (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) + `((format . tarball) + (system . ,(%current-system)) (substitutes? . #t) (graft? . #t) (max-silent-time . 3600) @@ -193,6 +250,11 @@ added to the pack." (symlinks . ()) (compressor . ,(first %compressors)))) +(define %formats + ;; Supported pack formats. + `((tarball . ,self-contained-tarball) + (docker . ,docker-image))) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -206,6 +268,9 @@ added to the pack." (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\f "format") #t #f + (lambda (opt name arg result) + (alist-cons 'format (string->symbol arg) result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -242,6 +307,8 @@ Create a bundle of PACKAGE.\n")) (show-transformation-options-help) (newline) (display (_ " + -f, --format=FORMAT build a pack in the given FORMAT")) + (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) @@ -280,8 +347,16 @@ Create a bundle of PACKAGE.\n")) (specification->package+output spec)) list)) specs)) - (compressor (assoc-ref opts 'compressor)) - (symlinks (assoc-ref opts 'symlinks)) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (compressor (assoc-ref opts 'compressor)) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (_ "~a: unknown pack format") + format)))) (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store ;; Set the build options before we do anything else. @@ -290,13 +365,13 @@ Create a bundle of PACKAGE.\n")) (run-with-store store (mlet* %store-monad ((profile (profile-derivation (packages->manifest packages))) - (drv (self-contained-tarball "pack" profile - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir?))) + (drv (build-image name profile + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir?))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? -- cgit v1.2.3