nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 1545a012cb,
01445711db, and
03476a23ff.
* doc/guix.texi (Invoking guix pack): Document '--format'.
(Invoking guix archive): Remove documentation of '--format'.
This commit is contained in:
Ludovic Courtès 2017-03-16 18:02:59 +01:00
parent 2971f39c33
commit b1edfbc37f
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 158 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
doc/guix.texi
View File

@ -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

97
guix/docker.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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")
(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)
(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))))
(and (with-directory-excursion directory
;; Add symlink from /bin to /gnu/store/.../bin
(symlink (string-append path "/bin") "bin")
;; 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"))))
(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))))
(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)))
;; 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)))))

31
guix/scripts/archive.scm
View File

@ -1,6 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 <http://bugs.gnu.org/12202>.
(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)

95
guix/scripts/pack.scm
View File

@ -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 <http://bugs.gnu.org/15602>.
(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?