Merge branch 'master' into core-updates

7 files changed, 149 insertions, 72 deletions

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 <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)
@@ -70,8 +63,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 (_ "
       --import           import from the archive passed on stdin"))
@@ -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/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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,7 +21,7 @@
   #: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 @@
   #: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)
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 @@
   #: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 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
       ((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/pack.scm b/guix/scripts/pack.scm
index 067b1227e0..626c592e1c 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)
@@ -43,19 +46,22 @@
 
 ;; Type of a compression tool.
 (define-record-type <compressor>
-  (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
@@ -67,7 +73,8 @@ found."
       (leave (_ "~a: compressor not found~%") name)))
 
 (define* (self-contained-tarball name profile
-                                 #:key deduplicate?
+                                 #:key target
+                                 deduplicate?
                                  (compressor (first %compressors))
                                  localstatedir?
                                  (symlinks '())
@@ -118,8 +125,7 @@ added to the pack."
                   (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
@@ -139,7 +145,8 @@ added to the pack."
           (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
@@ -177,6 +184,63 @@ added to the pack."
                     build
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (docker-image name profile
+                       #: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'.  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
+      (('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) (srfi srfi-19))
+
+          (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)
+                              #:creation-time (make-time time-utc 0 1)))))
+
+  (gexp->derivation (string-append name ".tar."
+                                   (compressor-extension compressor))
+                    build
+                    #:references-graphs `(("profile" ,profile))))
 
 
 ;;;
@@ -185,7 +249,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 +258,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,19 +276,27 @@ 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
                                (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)
                                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
@@ -242,8 +320,12 @@ 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 (_ "
+      --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
+  (display (_ "
   -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
   (display (_ "
   -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
@@ -280,20 +362,35 @@ 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"))
+             (target      (assoc-ref opts 'target))
+             (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.
+          (set-build-options-from-command-line store 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?)))
+                                           (packages->manifest packages)
+                                           #:target target))
+                                 (drv (build-image name profile
+                                                   #:target
+                                                   target
+                                                   #:compressor
+                                                   compressor
+                                                   #:symlinks
+                                                   symlinks
+                                                   #:localstatedir?
+                                                   localstatedir?)))
               (mbegin %store-monad
                 (show-what-to-build* (list drv)
                                      #:use-substitutes?
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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -34,7 +34,8 @@
   #: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 @@ provide."
                  (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 @@ failure, return #f and #f."
                    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 @@ initial connection on which HTTP requests are sent."
                 (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)))