From 01445711db6771cea6122859c3f717f130359f55 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 7 Jan 2017 00:48:11 +0100
Subject: [PATCH] guix archive: '-f docker' supports package names as
arguments.
This allows users to type:
guix archive -f docker emacs
as was already the case for the 'nar' format.
Reported by David Thompson.
* guix/scripts/archive.scm (%default-options): Add 'format'.
(export-from-store): Dispatch based on the 'format' key in OPTS.
(guix-archive): Call 'export-from-store' in all cases when the 'export'
key is in OPTS.
---
guix/scripts/archive.scm | 30 ++++++++++++++++++------------
1 file changed, 18 insertions(+), 12 deletions(-)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 6eba9e00087..3e056fda9bb 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -53,7 +53,8 @@ (define-module (guix scripts archive)
(define %default-options
;; Alist of default option values.
- `((system . ,(%current-system))
+ `((format . "nar")
+ (system . ,(%current-system))
(substitutes? . #t)
(graft? . #t)
(max-silent-time . 3600)
@@ -253,8 +254,21 @@ (define (export-from-store store opts)
(if (or (assoc-ref opts 'dry-run?)
(build-derivations store drv))
- (export-paths store files (current-output-port)
- #:recursive? (assoc-ref opts 'export-recursive?))
+ (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))))
+ (_
+ ;; TODO: Remove this restriction.
+ (leave (_ "only a single item can be exported to Docker~%")))))
+ (format
+ (leave (_ "~a: unknown archive format~%") format)))
(leave (_ "unable to export the given packages~%")))))
(define (generate-key-pair parameters)
@@ -338,15 +352,7 @@ (define (lines port)
(else
(with-store store
(cond ((assoc-ref opts 'export)
- (cond ((equal? (assoc-ref opts 'format) "docker")
- (match (car opts)
- (('argument . (? store-path? item))
- (format #t "~a\n"
- (build-docker-image
- item
- #:system (assoc-ref opts 'system))))
- (_ (leave (_ "argument must be a direct store path~%")))))
- (_ (export-from-store store opts))))
+ (export-from-store store opts))
((assoc-ref opts 'import)
(import-paths store (current-input-port)))
((assoc-ref opts 'missing)
--
GitLab