05/10: pack: 'docker' backend records the profile's search paths.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b9fcf0c82a14df48c7c6f36a08dbdcd3184fcbf8
Author: Ludovic Courtès <address@hidden>
Date:   Tue Jul 2 09:19:48 2019 +0200

    pack: 'docker' backend records the profile's search paths.
    
    * guix/docker.scm (config): Add #:environment parameter and honor it.
    (build-docker-image): Likewise, and pass it to 'config'.
    * guix/scripts/pack.scm (docker-image): Import (guix profiles) and (guix
    search-paths).  Call 'profile-search-paths' and pass #:environment to
    'build-docker-image'.
    * gnu/tests/docker.scm (run-docker-test)["Load docker image and run it"]:
    Add example that expects (json) to be available.
    * gnu/tests/docker.scm (build-tarball&run-docker-test): Replace
    %BOOTSTRAP-GUILE by GUILE-2.2 and GUILE-JSON in the environment.
---
 gnu/tests/docker.scm  | 18 ++++++++++++------
 guix/docker.scm       | 17 +++++++++++++----
 guix/scripts/pack.scm | 23 +++++++++++++++++++----
 3 files changed, 44 insertions(+), 14 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index f2674cd..3ec5c3d 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -27,7 +27,6 @@
   #:use-module (gnu services networking)
   #:use-module (gnu services docker)
   #:use-module (gnu services desktop)
-  #:use-module (gnu packages bootstrap) ; %bootstrap-guile
   #:use-module (gnu packages docker)
   #:use-module (gnu packages guile)
   #:use-module (guix gexp)
@@ -101,7 +100,7 @@ inside %DOCKER-OS."
              marionette))
 
           (test-equal "Load docker image and run it"
-            '("hello world" "hi!")
+            '("hello world" "hi!" "JSON!")
             (marionette-eval
              `(begin
                 (define slurp
@@ -125,8 +124,15 @@ inside %DOCKER-OS."
                        (response2 (slurp          ;default entry point
                                    ,(string-append #$docker-cli "/bin/docker")
                                    "run" repository&tag
-                                   "-c" "(display \"hi!\")")))
-                  (list response1 response2)))
+                                   "-c" "(display \"hi!\")"))
+
+                       ;; Check whether (json) is in $GUILE_LOAD_PATH.
+                       (response3 (slurp    ;default entry point + environment
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" repository&tag
+                                   "-c" "(use-modules (json))
+  (display (json-string->scm (scm->json-string \"JSON!\")))")))
+                  (list response1 response2 response3)))
              marionette))
 
           (test-end)
@@ -144,7 +150,7 @@ inside %DOCKER-OS."
           (version "0")
           (source #f)
           (build-system trivial-build-system)
-          (arguments `(#:guile ,%bootstrap-guile
+          (arguments `(#:guile ,guile-2.2
                        #:builder
                        (let ((out (assoc-ref %outputs "out")))
                          (mkdir out)
@@ -158,7 +164,7 @@ standard output device and then enters a new line.")
           (home-page #f)
           (license license:public-domain)))
        (profile (profile-derivation (packages->manifest
-                                     (list %bootstrap-guile
+                                     (list guile-2.2 guile-json
                                            guest-script-package))
                                     #:hooks '()
                                     #:locales? #f))
diff --git a/guix/docker.scm b/guix/docker.scm
index 7fe83d9..b1bd226 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -73,7 +73,7 @@
   `((,(generate-tag path) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define* (config layer time arch #:key entry-point)
+(define* (config layer time arch #:key entry-point (environment '()))
   "Generate a minimal image configuration for the given LAYER file."
   ;; "architecture" must be values matching "platform.arch" in the
   ;; runtime-spec at
@@ -81,9 +81,13 @@
   `((architecture . ,arch)
     (comment . "Generated by GNU Guix")
     (created . ,time)
-    (config . ,(if entry-point
-                   `((entrypoint . ,entry-point))
-                   #nil))
+    (config . ,`((env . ,(map (match-lambda
+                                ((name . value)
+                                 (string-append name "=" value)))
+                              environment))
+                 ,@(if entry-point
+                       `((entrypoint . ,entry-point))
+                       '())))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
@@ -113,6 +117,7 @@ return \"a\"."
                              (system (utsname:machine (uname)))
                              database
                              entry-point
+                             (environment '())
                              compressor
                              (creation-time (current-time time-utc)))
   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
@@ -124,6 +129,9 @@ When DATABASE is true, copy it to /var/guix/db in the image 
and create
 When ENTRY-POINT is true, it must be a list of strings; it is stored as the
 entry point in the Docker image JSON structure.
 
+ENVIRONMENT must be a list of name/value pairs.  It specifies the environment
+variables that must be defined in the resulting image.
+
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
 created in the image, where each TARGET is relative to PREFIX.
 TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
@@ -234,6 +242,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
         (lambda ()
           (scm->json (config (string-append id "/layer.tar")
                              time arch
+                             #:environment environment
                              #:entry-point entry-point))))
       (with-output-to-file "manifest.json"
         (lambda ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c90b777..bb6a8cd 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -27,6 +27,7 @@
   #:use-module (guix utils)
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
+  #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (guix grafts)
   #:autoload   (guix inferior) (inferior-package?)
   #:use-module (guix monads)
@@ -440,11 +441,24 @@ the image."
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
     (with-extensions (list guile-json guile-gcrypt)
-      (with-imported-modules (source-module-closure '((guix docker)
-                                                      (guix build store-copy))
-                                                    #:select? not-config?)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ,@(source-module-closure
+                                  `((guix docker)
+                                    (guix build store-copy)
+                                    (guix profiles)
+                                    (guix search-paths))
+                                  #:select? not-config?))
         #~(begin
-            (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+            (use-modules (guix docker) (guix build store-copy)
+                         (guix profiles) (guix search-paths)
+                         (srfi srfi-19) (ice-9 match))
+
+            (define environment
+              (map (match-lambda
+                     ((spec . value)
+                      (cons (search-path-specification-variable spec)
+                            value)))
+                   (profile-search-paths #$profile)))
 
             (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -455,6 +469,7 @@ the image."
                                 #$profile
                                 #:database #+database
                                 #:system (or #$target (utsname:machine 
(uname)))
+                                #:environment environment
                                 #:entry-point #$(and entry-point
                                                      #~(string-append 
#$profile "/"
                                                                       
#$entry-point))