03/06: pack: Add '--target'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 5461115e8fd9a3181506307b6090716a0d5c202c
Author: Ludovic Courtès <address@hidden>
Date:   Fri Mar 17 22:45:32 2017 +0100

    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(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3db6dad..0a09bba 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.
 
address@hidden address@hidden
address@hidden 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 address@hidden
 @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 address@hidden
 @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 290ad3d..0602321 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -105,12 +105,14 @@ return \"a\"."
 (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 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation 
time in metadata."
         (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 ce7613e..626c592 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -73,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 '())
@@ -184,14 +185,17 @@ added to the pack."
                     #: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 @@ with COMPRESSOR.  It can be passed to 'docker load'."
           (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 @@ with COMPRESSOR.  It can be passed to 'docker load'."
                  (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)
@@ -315,6 +324,8 @@ Create a bundle of PACKAGE.\n"))
   (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"))
@@ -354,6 +365,7 @@ Create a bundle of PACKAGE.\n"))
              (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 @@ Create a bundle of PACKAGE.\n"))
 
           (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