From 4c0c4db0702048488a9712dbba7cad862c667d54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Mar 2017 21:54:34 +0100 Subject: utils: Move base16 procedures to (guix base16). * guix/utils.scm (bytevector->base16-string, base16-string->bytevector): Move to... * guix/base16.scm: ... here. New file. * tests/utils.scm ("bytevector->base16-string->bytevector"): Move to... * tests/base16.scm: ... here. New file. * Makefile.am (MODULES): Add guix/base16.scm. (SCM_TESTS): Add tests/base16.scm. * build-aux/download.scm, guix/derivations.scm, guix/docker.scm, guix/import/snix.scm, guix/pk-crypto.scm, guix/scripts/authenticate.scm, guix/scripts/download.scm, guix/scripts/hash.scm, guix/store.scm, tests/hash.scm, tests/pk-crypto.scm: Adjust imports accordingly. --- guix/scripts/authenticate.scm | 4 ++-- guix/scripts/download.scm | 4 ++-- guix/scripts/hash.scm | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index d9f799df26..d9a312f1da 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +18,7 @@ (define-module (guix scripts authenticate) #:use-module (guix config) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module (guix pk-crypto) #:use-module (guix pki) #:use-module (guix ui) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index dffff79729..1ddfd648cd 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +21,7 @@ (define-module (guix scripts download) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix hash) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module (guix base32) #:use-module ((guix download) #:hide (url-fetch)) #:use-module ((guix build download) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 640b2417d2..a048b53461 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -24,7 +24,7 @@ (define-module (guix scripts hash) #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module (ice-9 binary-ports) #:use-module (rnrs files) #:use-module (ice-9 match) -- cgit v1.2.3 From 2971f39c3330a69f44d1ac97443e42b0f8e0173e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Mar 2017 17:31:10 +0100 Subject: pack: Honor command-line options related to the store. * guix/scripts/pack.scm (guix-pack): Call 'set-build-options-from-command-line'. --- guix/scripts/pack.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 067b1227e0..e422b3cdda 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -284,6 +284,9 @@ (define opts (symlinks (assoc-ref opts 'symlinks)) (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + (run-with-store store (mlet* %store-monad ((profile (profile-derivation (packages->manifest packages))) -- cgit v1.2.3 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'. --- doc/guix.texi | 34 ++++++++-------- guix/docker.scm | 103 ++++++++++++++++++++++++++--------------------- guix/scripts/archive.scm | 31 ++------------ guix/scripts/pack.scm | 95 ++++++++++++++++++++++++++++++++++++++----- 4 files changed, 161 insertions(+), 102 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 3382ac414e..45d171c52d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2435,6 +2435,22 @@ guix pack -S /opt/gnu/bin=bin guile emacs geiser @noindent That way, users can happily type @file{/opt/gnu/bin/guile} and enjoy. +Alternatively, you can produce a pack in the Docker image format, as +described in +@uref{https://github.com/docker/docker/blob/master/image/spec/v1.2.md, +version 1.2 of the specification}. This is what the following command +does: + +@example +guix pack -f docker guile emacs geiser +@end example + +@noindent +The result is a tarball that can be passed to the @command{docker load} +command. See the +@uref{https://docs.docker.com/engine/reference/commandline/load/, Docker +documentation} for more information. + Several command-line options allow you to customize your pack: @table @code @@ -2537,7 +2553,7 @@ what you should use in this case (@pxref{Invoking guix copy}). @cindex nar, archive format @cindex normalized archive (nar) -By default archives are stored in the ``normalized archive'' or ``nar'' format, which is +Archives are stored in the ``normalized archive'' or ``nar'' format, which is comparable in spirit to `tar', but with differences that make it more appropriate for our purposes. First, rather than recording all Unix metadata for each file, the nar format only mentions @@ -2553,9 +2569,6 @@ verifies the signature and rejects the import in case of an invalid signature or if the signing key is not authorized. @c FIXME: Add xref to daemon doc about signatures. -Optionally, archives can be exported as a Docker image in the tar -archive format using @code{--format=docker}. - The main options are: @table @code @@ -2584,19 +2597,6 @@ Read a list of store file names from the standard input, one per line, and write on the standard output the subset of these files missing from the store. -@item -f -@item --format=@var{FMT} -@cindex docker, export -@cindex export format -Specify the export format. Acceptable arguments are @code{nar} and -@code{docker}. The default is the nar format. When the format is -@code{docker}, recursively export the specified store directory as a -Docker image in tar archive format, as specified in -@uref{https://github.com/docker/docker/blob/master/image/spec/v1.2.md, -version 1.2.0 of the Docker Image Specification}. Using -@code{--format=docker} implies @code{--recursive}. The generated -archive can be loaded by Docker using @command{docker load}. - @item --generate-key[=@var{parameters}] @cindex signing, archives Generate a new key pair for the daemon. This is a prerequisite before 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 @@ (define (config layer time arch) (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 @@ (define-module (guix scripts archive) #: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-module (guix scripts archive) (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 @@ (define (show-help) 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 @@ (define %options (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 @@ (define (export-from-store store opts) (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 @@ (define-module (guix scripts pack) #: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 @@ (define-module (guix scripts pack) #: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 @@ (define tar-supports-sort? 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 @@ (define tar-supports-sort? (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 @@ (define %default-options (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 @@ (define %options (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 @@ (define (show-help) (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 @@ (define opts (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 @@ (define opts (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 From 84dda5a9c0772b2507fab3209938ead9da2a3442 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Mar 2017 21:41:38 +0100 Subject: pack: Use a fixed timestamp in Docker images. * guix/docker.scm (build-docker-image): Add #:creation-time parameter. Use SRFI-19 'date->string' instead of 'strftime' et al. * guix/scripts/pack.scm (docker-image)[build]: Pass #:creation-time to 'build-docker-image'. --- guix/docker.scm | 10 +++++++--- guix/scripts/pack.scm | 5 +++-- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/docker.scm b/guix/docker.scm index 56a0f7ec2b..5614ab2115 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -24,6 +24,7 @@ (define-module (guix docker) #:select (delete-file-recursively with-directory-excursion)) #:use-module (guix build store-copy) + #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (build-docker-image)) @@ -83,15 +84,18 @@ (define (config layer time arch) (rootfs . ((type . "layers") (diff_ids . (,(layer-diff-id layer))))))) -(define* (build-docker-image image path #:key closure compressor) +(define* (build-docker-image image path + #:key closure compressor + (creation-time (current-time time-utc))) "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." +to compress IMAGE. Use CREATION-TIME, a SRFI-19 time-utc object, as the +creation time in metadata." (let ((directory "/tmp/docker-image") ;temporary working directory (closure (canonicalize-path closure)) (id (docker-id path)) - (time (strftime "%FT%TZ" (localtime (current-time)))) + (time (date->string (time-utc->date creation-time) "~4")) (arch (match (utsname:machine (uname)) ("x86_64" "amd64") ("i686" "386") diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c6f2145c5c..694b2f2aee 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -219,7 +219,7 @@ (define build (string-append #$guile-json "/share/guile/site/" (effective-version))) - (use-modules (guix docker)) + (use-modules (guix docker) (srfi srfi-19)) (setenv "PATH" (string-append #$tar "/bin:" @@ -227,7 +227,8 @@ (define build (build-docker-image #$output #$profile #:closure "profile" - #:compressor '#$(compressor-command compressor))))) + #:compressor '#$(compressor-command compressor) + #:creation-time (make-time time-utc 0 1))))) (gexp->derivation (string-append name ".tar." (compressor-extension compressor)) -- cgit v1.2.3 From 9e84ea3673f77ebe5c5e9ce39fbcdb6d7bc8a06f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Mar 2017 22:40:06 +0100 Subject: pack: Honor symlinks in the Docker back-end. * guix/docker.scm (symlink-source, topmost-component): New procedures. (build-docker-image): Add #:symlinks parameter and honor it. Remove hard-coded /bin symlink. * guix/scripts/pack.scm (docker-image): Pass #:symlinks to 'build-docker-image'. --- guix/docker.scm | 46 ++++++++++++++++++++++++++++++++++++---------- guix/scripts/pack.scm | 3 ++- 2 files changed, 38 insertions(+), 11 deletions(-) (limited to 'guix/scripts') diff --git a/guix/docker.scm b/guix/docker.scm index 9b7a28f6f3..290ad3dcf1 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -21,7 +21,8 @@ (define-module (guix docker) #:use-module (guix hash) #:use-module (guix base16) #:use-module ((guix build utils) - #:select (delete-file-recursively + #:select (mkdir-p + delete-file-recursively with-directory-excursion)) #:use-module (guix build store-copy) #:use-module (srfi srfi-19) @@ -89,14 +90,30 @@ (define %tar-determinism-options '("--sort=name" "--mtime=@1" "--owner=root:0" "--group=root:0")) +(define symlink-source + (match-lambda + ((source '-> target) + (string-trim source #\/)))) + +(define (topmost-component file) + "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", +return \"a\"." + (match (string-tokenize file (char-set-complement (char-set #\/))) + ((first rest ...) + first))) + (define* (build-docker-image image path #:key closure compressor + (symlinks '()) (creation-time (current-time time-utc))) "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. Use CREATION-TIME, a SRFI-19 time-utc object, as the -creation time in metadata." +#:references-graphs). SYMLINKS must be a list of (SOURCE -> TARGET) tuples +describing symlinks to be created in the image, where each TARGET is relative +to PATH. + +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." (let ((directory "/tmp/docker-image") ;temporary working directory (closure (canonicalize-path closure)) (id (docker-id path)) @@ -110,9 +127,6 @@ (define* (build-docker-image image path (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" @@ -120,13 +134,25 @@ (define* (build-docker-image image path (with-output-to-file "json" (lambda () (scm->json (image-description id time)))) - ;; Wrap it up + ;; Wrap it up. (let ((items (call-with-input-file closure read-reference-graph))) + ;; Create SYMLINKS. + (for-each (match-lambda + ((source '-> target) + (let ((source (string-trim source #\/))) + (mkdir-p (dirname source)) + (symlink (string-append path "/" target) + source)))) + symlinks) + (and (zero? (apply system* "tar" "-cf" "layer.tar" (append %tar-determinism-options - (cons "../bin" items)))) - (delete-file "../bin")))) + items + (map symlink-source symlinks)))) + (for-each delete-file-recursively + (map (compose topmost-component symlink-source) + symlinks))))) (with-output-to-file "config.json" (lambda () diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 694b2f2aee..edeb82fafd 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -189,7 +189,7 @@ (define* (docker-image name profile "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?. + ;; FIXME: Honor LOCALSTATEDIR?. (define not-config? (match-lambda (('guix 'config) #f) @@ -227,6 +227,7 @@ (define build (build-docker-image #$output #$profile #:closure "profile" + #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1))))) -- cgit v1.2.3 From db3f2b61adfe56d69029ec5f6d962462a50a1f33 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Mar 2017 22:46:43 +0100 Subject: pack: Allow for "-S /opt/foo=". Reported by Andy Wingo. * guix/scripts/pack.scm (%options): Use 'string-split' instead of 'string-tokenize'. --- guix/scripts/pack.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index edeb82fafd..74d4ee6d4d 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -283,9 +283,10 @@ (define %options result))) (option '(#\S "symlink") #t #f (lambda (opt name arg result) - (match (string-tokenize arg - (char-set-complement - (char-set #\=))) + ;; Note: Using 'string-split' allows us to handle empty + ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is + ;; a symlink to the profile) correctly. + (match (string-split arg (char-set #\=)) ((source target) (let ((symlinks (assoc-ref result 'symlinks))) (alist-cons 'symlinks -- cgit v1.2.3 From 48b444304e206c35cf2c8e0d87a4711f1aac4fd4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Mar 2017 17:37:00 +0100 Subject: pack: Move absolute file name to . * guix/scripts/pack.scm ()[package]: Remove. [command]: Document as being a gexp with an absolute file name. (%compressors): Adjust accordingly. (self-contained-tarball): Simplify PATH expression. Move 'string-join' for the compressor command on the build side. (docker-image): Simplify PATH expression. * tests/pack.scm (%gzip-compressor): Adjust accordingly. --- guix/scripts/pack.scm | 31 ++++++++++++++++--------------- tests/pack.scm | 3 ++- 2 files changed, 18 insertions(+), 16 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 74d4ee6d4d..ce7613e4a0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -46,19 +46,22 @@ (define-module (guix scripts pack) ;; Type of a compression tool. (define-record-type - (compressor name package extension command) + (compressor name extension command) compressor? - (name compressor-name) ;string (e.g., "gzip") - (package compressor-package) ;package - (extension compressor-extension) ;string (e.g., "lz") - (command compressor-command)) ;list (e.g., '("gzip" "-9n")) + (name compressor-name) ;string (e.g., "gzip") + (extension compressor-extension) ;string (e.g., "lz") + (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n")) (define %compressors ;; Available compression tools. - (list (compressor "gzip" gzip "gz" '("gzip" "-9n")) - (compressor "lzip" lzip "lz" '("lzip" "-9")) - (compressor "xz" xz "xz" '("xz" "-e")) - (compressor "bzip2" bzip2 "bz2" '("bzip2" "-9")))) + (list (compressor "gzip" "gz" + #~(#+(file-append gzip "/bin/gzip") "-9n")) + (compressor "lzip" "lz" + #~(#+(file-append lzip "/bin/lzip") "-9")) + (compressor "xz" "xz" + #~(#+(file-append xz "/bin/xz") "-e")) + (compressor "bzip2" "bz2" + #~(#+(file-append bzip2 "/bin/bzip2") "-9")))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -121,8 +124,7 @@ (define tar-supports-sort? (string-append #$(if localstatedir? (file-append guix "/sbin:") "") - #$tar "/bin:" - #$(compressor-package compressor) "/bin")) + #$tar "/bin")) ;; Note: there is not much to gain here with deduplication and ;; there is the overhead of the '.links' directory, so turn it @@ -142,7 +144,8 @@ (define tar-supports-sort? (with-directory-excursion %root (exit (zero? (apply system* "tar" - "-I" #$(string-join (compressor-command compressor)) + "-I" + (string-join '#+(compressor-command compressor)) "--format=gnu" ;; Avoid non-determinism in the archive. Use @@ -221,9 +224,7 @@ (define build (use-modules (guix docker) (srfi srfi-19)) - (setenv "PATH" - (string-append #$tar "/bin:" - #$(compressor-package compressor) "/bin")) + (setenv "PATH" (string-append #$tar "/bin")) (build-docker-image #$output #$profile #:closure "profile" diff --git a/tests/pack.scm b/tests/pack.scm index de9ef8e6ab..eb643c3229 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -42,7 +42,8 @@ (define-syntax-rule (test-assertm name exp) (define %gzip-compressor ;; Compressor that uses the bootstrap 'gzip'. ((@ (guix scripts pack) compressor) "gzip" - %bootstrap-coreutils&co "gz" '("gzip" "-6n"))) + "gz" + #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) (define %tar-bootstrap %bootstrap-coreutils&co) -- cgit v1.2.3 From 5461115e8fd9a3181506307b6090716a0d5c202c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Mar 2017 22:45:32 +0100 Subject: pack: Add '--target'. * guix/scripts/pack.scm (self-contained-tarball): Add #:target. (docker-image): Add #:target. [build]: Pass it to 'build-docker-image'. (%options, show-help): Add '--target'. (guix-pack): Pass TARGET to 'profile-derivation' and to 'build-image'. * guix/docker.scm (build-docker-image): Add #:system parameter and honor it. * doc/guix.texi (Invoking guix pack): Document '--target'. (Additional Build Options): Refer to the Autoconf manual instead of the obsolete 'configure.info' for cross-compilation. --- doc/guix.texi | 10 ++++++++-- guix/docker.scm | 21 +++++++++++++++------ guix/scripts/pack.scm | 23 +++++++++++++++++++---- 3 files changed, 42 insertions(+), 12 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 3db6dad5f3..0a09bba06f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2476,6 +2476,12 @@ Docker Image Specification}. Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of the system type of the build host. +@item --target=@var{triplet} +@cindex cross-compilation +Cross-build for @var{triplet}, which must be a valid GNU triplet, such +as @code{"mips64el-linux-gnu"} (@pxref{Specifying target triplets, GNU +configuration triplets,, autoconf, Autoconf}). + @item --compression=@var{tool} @itemx -C @var{tool} Compress the resulting tarball using @var{tool}---one of @code{gzip}, @@ -5063,8 +5069,8 @@ to build packages in a complete 32-bit environment. @item --target=@var{triplet} @cindex cross-compilation Cross-build for @var{triplet}, which must be a valid GNU triplet, such -as @code{"mips64el-linux-gnu"} (@pxref{Configuration Names, GNU -configuration triplets,, configure, GNU Configure and Build System}). +as @code{"mips64el-linux-gnu"} (@pxref{Specifying target triplets, GNU +configuration triplets,, autoconf, Autoconf}). @anchor{build-check} @item --check diff --git a/guix/docker.scm b/guix/docker.scm index 290ad3dcf1..060232148e 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -105,12 +105,14 @@ (define (topmost-component file) (define* (build-docker-image image path #:key closure compressor (symlinks '()) + (system (utsname:machine (uname))) (creation-time (current-time time-utc))) "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). SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be created in the image, where each TARGET is relative -to PATH. +to PATH. SYSTEM is a GNU triplet (or prefix thereof) of the system the +binaries at PATH 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." @@ -118,11 +120,18 @@ (define* (build-docker-image image path (closure (canonicalize-path closure)) (id (docker-id path)) (time (date->string (time-utc->date creation-time) "~4")) - (arch (match (utsname:machine (uname)) - ("x86_64" "amd64") - ("i686" "386") - ("armv7l" "arm") - ("mips64" "mips64le")))) + (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) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ce7613e4a0..626c592e1c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -73,7 +73,8 @@ (define (lookup-compressor name) (leave (_ "~a: compressor not found~%") name))) (define* (self-contained-tarball name profile - #:key deduplicate? + #:key target + deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -184,14 +185,17 @@ (define tar-supports-sort? #:references-graphs `(("profile" ,profile)))) (define* (docker-image name profile - #:key deduplicate? + #:key target + 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'." +with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it +must a be a GNU triplet and it is used to derive the architecture metadata in +the image." ;; FIXME: Honor LOCALSTATEDIR?. (define not-config? (match-lambda @@ -227,6 +231,7 @@ (define build (setenv "PATH" (string-append #$tar "/bin")) (build-docker-image #$output #$profile + #:system (or #$target (utsname:machine (uname))) #:closure "profile" #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) @@ -278,6 +283,10 @@ (define %options (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) (option '(#\C "compression") #t #f (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) @@ -314,6 +323,8 @@ (define (show-help) -f, --format=FORMAT build a pack in the given FORMAT")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) (display (_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) (display (_ " @@ -354,6 +365,7 @@ (define opts (pack-format (assoc-ref opts 'format)) (name (string-append (symbol->string pack-format) "-pack")) + (target (assoc-ref opts 'target)) (compressor (assoc-ref opts 'compressor)) (symlinks (assoc-ref opts 'symlinks)) (build-image (match (assq-ref %formats pack-format) @@ -368,8 +380,11 @@ (define opts (run-with-store store (mlet* %store-monad ((profile (profile-derivation - (packages->manifest packages))) + (packages->manifest packages) + #:target target)) (drv (build-image name profile + #:target + target #:compressor compressor #:symlinks -- cgit v1.2.3 From 4fd06a4dd1d4a894b96e586cef594270f8bbb88f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Mar 2017 23:41:37 +0100 Subject: http-client: Avoid name clash with 'open-connection-for-uri' in 2.2.0. * guix/build/download.scm (open-connection-for-uri): Add note about same-named binding in Guile 2.2.0. * guix/http-client.scm: Use 'guix:open-connection-for-uri' for the procedure coming from (guix build download). * guix/scripts/lint.scm: Likewise. * guix/scripts/substitute.scm: Likewise. --- guix/build/download.scm | 3 +++ guix/http-client.scm | 10 ++++++---- guix/scripts/lint.scm | 6 ++++-- guix/scripts/substitute.scm | 23 +++++++++++++---------- 4 files changed, 26 insertions(+), 16 deletions(-) (limited to 'guix/scripts') diff --git a/guix/build/download.scm b/guix/build/download.scm index d956a9f33e..36c815c167 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -464,6 +464,9 @@ (define* (open-connection-for-uri uri "Like 'open-socket-for-uri', but also handle HTTPS connections. The resulting port must be closed with 'close-connection'. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." + ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually + ;; undefined. See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047. + (define https? (eq? 'https (uri-scheme uri))) diff --git a/guix/http-client.scm b/guix/http-client.scm index 855ae95a43..6874c51db6 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -38,7 +38,9 @@ (define-module (guix http-client) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (open-socket-for-uri - open-connection-for-uri resolve-uri-reference)) + (open-connection-for-uri + . guix:open-connection-for-uri) + resolve-uri-reference)) #:re-export (open-socket-for-uri) #:export (&http-get-error http-get-error? @@ -234,9 +236,9 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t) (let loop ((uri (if (string? uri) (string->uri uri) uri))) - (let ((port (or port (open-connection-for-uri uri - #:verify-certificate? - verify-certificate?))) + (let ((port (or port (guix:open-connection-for-uri uri + #:verify-certificate? + verify-certificate?))) (headers (match (uri-userinfo uri) ((? string? str) (cons (cons 'Authorization diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 776e7332c5..66c82f0409 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -44,7 +44,8 @@ (define-module (guix scripts lint) #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors - open-connection-for-uri + (open-connection-for-uri + . guix:open-connection-for-uri) close-connection)) #:use-module (web request) #:use-module (web response) @@ -377,7 +378,8 @@ (define headers ((or 'http 'https) (catch #t (lambda () - (let ((port (open-connection-for-uri uri #:timeout timeout)) + (let ((port (guix:open-connection-for-uri + uri #:timeout timeout)) (request (build-request uri #:headers headers))) (define response (dynamic-wind diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 524b019a31..faeb019120 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2014 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -34,7 +34,8 @@ (define-module (guix scripts substitute) #:use-module ((guix build download) #:select (current-terminal-columns progress-proc uri-abbreviation nar-uri-abbreviation - open-connection-for-uri + (open-connection-for-uri + . guix:open-connection-for-uri) close-connection store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) @@ -210,8 +211,8 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t)) (close-connection port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-connection-for-uri uri - #:verify-certificate? #f)) + (set! port (guix:open-connection-for-uri + uri #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port @@ -247,9 +248,10 @@ (define (read-cache-info port) read-cache-info) #f)) ((http https) - (let ((port (open-connection-for-uri uri - #:verify-certificate? #f - #:timeout %fetch-timeout))) + (let ((port (guix:open-connection-for-uri + uri + #:verify-certificate? #f + #:timeout %fetch-timeout))) (guard (c ((http-get-error? c) (warning (_ "while fetching '~a': ~a (~s)~%") (uri->string (http-get-error-uri c)) @@ -533,9 +535,10 @@ (define* (http-multiple-get base-uri proc seed requests (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (or port (open-connection-for-uri base-uri - #:verify-certificate? - verify-certificate?)))) + (let ((p (or port (guix:open-connection-for-uri + base-uri + #:verify-certificate? + verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p _IOFBF (expt 2 16))) -- cgit v1.2.3