unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
Search results ordered by [date|relevance]  view[summary|nested|Atom feed]
thread overview below | download mbox.gz: |
* [bug#71324] [PATCH 1/2] services: containerd: Provision separately from docker service.
  @ 2024-06-03 22:30 65% ` Oleg Pykhalov
  0 siblings, 0 replies; 149+ results
From: Oleg Pykhalov @ 2024-06-03 22:30 UTC (permalink / raw)
  To: 71324
  Cc: Oleg Pykhalov, Florian Pelz, Ludovic Courtès,
	Matthew Trzcinski, Maxim Cournoyer

containerd can operate independently without relying on Docker for its
configuration.

* gnu/services/docker.scm (docker-configuration): Deprecate containerd field.
(containerd-configuration, containerd-service-type): New variables.
(docker-shepherd-service): Use containerd-configuration.  Delete duplicated
variable binding.  Allow to configure environment variables.
(docker-service-type): Delete extension with containerd-service-type.
* gnu/tests/docker.scm (%docker-os, %oci-os): Add containerd service.
(run-docker-test, run-docker-system-test, run-oci-container-test): Run
containerd service.
* doc/guix.texi (Miscellaneous Services): Document containerd-service-type.

Change-Id: Ife0924e50a3e0aa2302d6592dae51ed894600004
---
 doc/guix.texi           | 44 +++++++++++++++++++++++++-
 gnu/services/docker.scm | 68 ++++++++++++++++++++++++++++-------------
 gnu/tests/docker.scm    | 46 +++++++++++++++++++++++++++-
 3 files changed, 135 insertions(+), 23 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 1224104038..d2ba6784de 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40484,12 +40484,54 @@ Miscellaneous Services
 
 The @code{(gnu services docker)} module provides the following services.
 
+@cindex containerd, container runtime
+@defvar containerd-service-type
+
+This service type operates containerd
+@url{https://containerd.io,containerd}, a daemon responsible for
+overseeing the entire container lifecycle on its host system. This
+includes image handling, storage management, container execution,
+supervision, low-level storage operations, network connections, and
+more.
+
+@end defvar
+
+@deftp {Data Type} containerd-configuration
+This is the data type representing the configuration of containerd.
+
+@table @asis
+
+@item @code{containerd} (default: @code{containerd})
+The containerd daemon package to use.
+
+@item @code{debug?} (default @code{#f})
+Enable or disable debug output.
+
+@item @code{environment-variables} (default: @code{'()})
+List of environment variables to set for @command{containerd}.
+
+This must be a list of strings where each string has the form
+@samp{@var{key}=@var{value}} as in this example:
+
+@lisp
+(list "HTTP_PROXY=socks5://127.0.0.1:9150"
+      "HTTPS_PROXY=socks5://127.0.0.1:9150")
+@end lisp
+
+@end table
+@end deftp
+
 @defvar docker-service-type
 
 This is the type of the service that runs @url{https://www.docker.com,Docker},
 a daemon that can execute application bundles (sometimes referred to as
 ``containers'') in isolated environments.
 
+The @code{containerd-service-type} service need to be added to a system
+configuration, otherwise a message about not any service provides
+@code{containerd} will be displayed during @code{guix system
+reconfigure}.
+
 @end defvar
 
 @deftp {Data Type} docker-configuration
@@ -40504,7 +40546,7 @@ Miscellaneous Services
 The Docker client package to use.
 
 @item @code{containerd} (default: @var{containerd})
-The Containerd package to use.
+This field is deprecated in favor of @code{containerd-service-type} service.
 
 @item @code{proxy} (default @var{docker-libnetwork-cmd-proxy})
 The Docker user-land networking proxy package to use.
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 7aff8dcc5f..a5375d1ccc 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -49,7 +49,9 @@ (define-module (gnu services docker)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
 
-  #:export (docker-configuration
+  #:export (containerd-configuration
+            containerd-service-type
+            docker-configuration
             docker-service-type
             singularity-service-type
             oci-image
@@ -95,7 +97,7 @@ (define-configuration docker-configuration
    "Docker client package.")
   (containerd
    (file-like containerd)
-   "containerd package.")
+   "Deprecated.  Do not use.")
   (proxy
    (file-like docker-libnetwork-cmd-proxy)
    "The proxy package to support inter-container and outside-container
@@ -117,6 +119,18 @@ (define-configuration docker-configuration
    "JSON configuration file to pass to dockerd")
   (no-serialization))
 
+(define-configuration containerd-configuration
+  (containerd
+   (file-like containerd)
+   "containerd package.")
+  (debug?
+   (boolean #f)
+   "Enable or disable debug output.")
+  (environment-variables
+   (list '())
+   "Environment variables to set for containerd.")
+  (no-serialization))
+
 (define %docker-accounts
   (list (user-group (name "docker") (system? #t))))
 
@@ -134,24 +148,37 @@ (define (%docker-activation config)
         (mkdir-p #$state-dir))))
 
 (define (containerd-shepherd-service config)
-  (let* ((package (docker-configuration-containerd config))
-         (debug? (docker-configuration-debug? config))
-         (containerd (docker-configuration-containerd config)))
+  (match-record config <containerd-configuration>
+                (containerd debug? environment-variables)
     (shepherd-service
-           (documentation "containerd daemon.")
-           (provision '(containerd))
-           (start #~(make-forkexec-constructor
-                     (list (string-append #$package "/bin/containerd")
-                           #$@(if debug?
-                                  '("--log-level=debug")
-                                  '()))
-                     ;; For finding containerd-shim binary.
-                     #:environment-variables
-                     (list (string-append "PATH=" #$containerd "/bin"))
-                     #:pid-file "/run/containerd/containerd.pid"
-                     #:pid-file-timeout 300
-                     #:log-file "/var/log/containerd.log"))
-           (stop #~(make-kill-destructor)))))
+     (documentation "containerd daemon.")
+     (provision '(containerd))
+     (start #~(make-forkexec-constructor
+               (list (string-append #$containerd "/bin/containerd")
+                     #$@(if debug?
+                            '("--log-level=debug")
+                            '()))
+               ;; For finding containerd-shim binary.
+               #:environment-variables
+               (list #$@environment-variables
+                     (string-append "PATH=" #$containerd "/bin"))
+               #:pid-file "/run/containerd/containerd.pid"
+               #:pid-file-timeout 300
+               #:log-file "/var/log/containerd.log"))
+     (stop #~(make-kill-destructor)))))
+
+(define containerd-service-type
+  (service-type (name 'containerd)
+                (description "Run containerd container runtime.")
+                (extensions
+                 (list
+                  ;; Make sure the 'ctr' command is available.
+                  (service-extension profile-service-type
+                                     (compose list containerd-configuration-containerd))
+                  (service-extension shepherd-root-service-type
+                                     (lambda (config)
+                                       (list (containerd-shepherd-service config))))))
+                (default-value (containerd-configuration))))
 
 (define (docker-shepherd-service config)
   (let* ((docker (docker-configuration-docker config))
@@ -208,8 +235,7 @@ (define docker-service-type
                                      %docker-activation)
                   (service-extension shepherd-root-service-type
                                      (lambda (config)
-                                       (list (containerd-shepherd-service config)
-                                             (docker-shepherd-service config))))
+                                       (list (docker-shepherd-service config))))
                   (service-extension account-service-type
                                      (const %docker-accounts))))
                 (default-value (docker-configuration))))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index d550136b4a..46c886580c 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -54,6 +54,7 @@ (define %docker-os
    (service dbus-root-service-type)
    (service polkit-service-type)
    (service elogind-service-type)
+   (service containerd-service-type)
    (service docker-service-type)))
 
 (define (run-docker-test docker-tarball)
@@ -88,7 +89,21 @@ (define (run-docker-test docker-tarball)
           (test-runner-current (system-test-runner #$output))
           (test-begin "docker")
 
-          (test-assert "service running"
+          (test-assert "containerd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'containerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "containerd PID file present"
+            (wait-for-file "/run/containerd/containerd.pid" marionette))
+
+          (test-assert "dockerd service running"
             (marionette-eval
              '(begin
                 (use-modules (gnu services herd))
@@ -234,6 +249,20 @@ (define (run-docker-system-test tarball)
           (test-runner-current (system-test-runner #$output))
           (test-begin "docker")
 
+          (test-assert "containerd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'containerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "containerd PID file present"
+            (wait-for-file "/run/containerd/containerd.pid" marionette))
+
           (test-assert "service running"
             (marionette-eval
              '(begin
@@ -327,6 +356,7 @@ (define %oci-os
    (service dbus-root-service-type)
    (service polkit-service-type)
    (service elogind-service-type)
+   (service containerd-service-type)
    (service docker-service-type)
    (extra-special-file "/shared.txt"
                        (plain-file "shared.txt" "hello"))
@@ -384,6 +414,20 @@ (define (run-oci-container-test)
           (test-runner-current (system-test-runner #$output))
           (test-begin "oci-container")
 
+          (test-assert "containerd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'containerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "containerd PID file present"
+            (wait-for-file "/run/containerd/containerd.pid" marionette))
+
           (test-assert "dockerd running"
             (marionette-eval
              '(begin

base-commit: bc06affabcf68bbe93e9afee13bef8cc8c6336a2
-- 
2.41.0





^ permalink raw reply related	[relevance 65%]

* [bug#71324] [PATCH] services: containerd: Provision separately from docker service.
  @ 2024-06-02 13:15 67% ` Oleg Pykhalov
  0 siblings, 0 replies; 149+ results
From: Oleg Pykhalov @ 2024-06-02 13:15 UTC (permalink / raw)
  To: 71324
  Cc: Oleg Pykhalov, Florian Pelz, Ludovic Courtès,
	Matthew Trzcinski, Maxim Cournoyer

containerd can operate independently without relying on Docker for its
configuration.

* gnu/services/docker.scm (docker-configuration): Deprecate containerd field.
(containerd-configuration, containerd-service-type): New variables.
(docker-shepherd-service): Use containerd-configuration.  Delete duplicated
variable binding.  Allow to configure environment variables.
(docker-service-type): Delete extension with containerd-service-type.
* gnu/tests/docker.scm (%docker-os, %oci-os): Add containerd service.
(run-docker-test, run-docker-system-test, run-oci-container-test): Run
containerd service.

Change-Id: Ife0924e50a3e0aa2302d6592dae51ed894600004
---
 doc/guix.texi           | 39 ++++++++++++++++++++++-
 gnu/services/docker.scm | 68 ++++++++++++++++++++++++++++-------------
 gnu/tests/docker.scm    | 46 +++++++++++++++++++++++++++-
 3 files changed, 130 insertions(+), 23 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index c1ff049f03..d210a04d3a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40465,6 +40465,43 @@ Miscellaneous Services
 
 The @code{(gnu services docker)} module provides the following services.
 
+@cindex containerd, container runtime
+@defvar containerd-service-type
+
+This service type operates containerd
+@url{https://containerd.io,containerd}, a daemon responsible for
+overseeing the entire container lifecycle on its host system. This
+includes image handling, storage management, container execution,
+supervision, low-level storage operations, network connections, and
+more.
+
+@end defvar
+
+@deftp {Data Type} containerd-configuration
+This is the data type representing the configuration of containerd.
+
+@table @asis
+
+@item @code{containerd} (default: @code{containerd})
+The containerd daemon package to use.
+
+@item @code{debug?} (default @code{#f})
+Enable or disable debug output.
+
+@item @code{environment-variables} (default: @code{'()})
+List of environment variables to set for @command{containerd}.
+
+This must be a list of strings where each string has the form
+@samp{@var{key}=@var{value}} as in this example:
+
+@lisp
+(list "HTTP_PROXY=socks5://127.0.0.1:9150"
+      "HTTPS_PROXY=socks5://127.0.0.1:9150")
+@end lisp
+
+@end table
+@end deftp
+
 @defvar docker-service-type
 
 This is the type of the service that runs @url{https://www.docker.com,Docker},
@@ -40485,7 +40522,7 @@ Miscellaneous Services
 The Docker client package to use.
 
 @item @code{containerd} (default: @var{containerd})
-The Containerd package to use.
+This field is deprecated in favor of @code{containerd-service-type} service.
 
 @item @code{proxy} (default @var{docker-libnetwork-cmd-proxy})
 The Docker user-land networking proxy package to use.
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 7aff8dcc5f..a5375d1ccc 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -49,7 +49,9 @@ (define-module (gnu services docker)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
 
-  #:export (docker-configuration
+  #:export (containerd-configuration
+            containerd-service-type
+            docker-configuration
             docker-service-type
             singularity-service-type
             oci-image
@@ -95,7 +97,7 @@ (define-configuration docker-configuration
    "Docker client package.")
   (containerd
    (file-like containerd)
-   "containerd package.")
+   "Deprecated.  Do not use.")
   (proxy
    (file-like docker-libnetwork-cmd-proxy)
    "The proxy package to support inter-container and outside-container
@@ -117,6 +119,18 @@ (define-configuration docker-configuration
    "JSON configuration file to pass to dockerd")
   (no-serialization))
 
+(define-configuration containerd-configuration
+  (containerd
+   (file-like containerd)
+   "containerd package.")
+  (debug?
+   (boolean #f)
+   "Enable or disable debug output.")
+  (environment-variables
+   (list '())
+   "Environment variables to set for containerd.")
+  (no-serialization))
+
 (define %docker-accounts
   (list (user-group (name "docker") (system? #t))))
 
@@ -134,24 +148,37 @@ (define (%docker-activation config)
         (mkdir-p #$state-dir))))
 
 (define (containerd-shepherd-service config)
-  (let* ((package (docker-configuration-containerd config))
-         (debug? (docker-configuration-debug? config))
-         (containerd (docker-configuration-containerd config)))
+  (match-record config <containerd-configuration>
+                (containerd debug? environment-variables)
     (shepherd-service
-           (documentation "containerd daemon.")
-           (provision '(containerd))
-           (start #~(make-forkexec-constructor
-                     (list (string-append #$package "/bin/containerd")
-                           #$@(if debug?
-                                  '("--log-level=debug")
-                                  '()))
-                     ;; For finding containerd-shim binary.
-                     #:environment-variables
-                     (list (string-append "PATH=" #$containerd "/bin"))
-                     #:pid-file "/run/containerd/containerd.pid"
-                     #:pid-file-timeout 300
-                     #:log-file "/var/log/containerd.log"))
-           (stop #~(make-kill-destructor)))))
+     (documentation "containerd daemon.")
+     (provision '(containerd))
+     (start #~(make-forkexec-constructor
+               (list (string-append #$containerd "/bin/containerd")
+                     #$@(if debug?
+                            '("--log-level=debug")
+                            '()))
+               ;; For finding containerd-shim binary.
+               #:environment-variables
+               (list #$@environment-variables
+                     (string-append "PATH=" #$containerd "/bin"))
+               #:pid-file "/run/containerd/containerd.pid"
+               #:pid-file-timeout 300
+               #:log-file "/var/log/containerd.log"))
+     (stop #~(make-kill-destructor)))))
+
+(define containerd-service-type
+  (service-type (name 'containerd)
+                (description "Run containerd container runtime.")
+                (extensions
+                 (list
+                  ;; Make sure the 'ctr' command is available.
+                  (service-extension profile-service-type
+                                     (compose list containerd-configuration-containerd))
+                  (service-extension shepherd-root-service-type
+                                     (lambda (config)
+                                       (list (containerd-shepherd-service config))))))
+                (default-value (containerd-configuration))))
 
 (define (docker-shepherd-service config)
   (let* ((docker (docker-configuration-docker config))
@@ -208,8 +235,7 @@ (define docker-service-type
                                      %docker-activation)
                   (service-extension shepherd-root-service-type
                                      (lambda (config)
-                                       (list (containerd-shepherd-service config)
-                                             (docker-shepherd-service config))))
+                                       (list (docker-shepherd-service config))))
                   (service-extension account-service-type
                                      (const %docker-accounts))))
                 (default-value (docker-configuration))))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index d550136b4a..46c886580c 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -54,6 +54,7 @@ (define %docker-os
    (service dbus-root-service-type)
    (service polkit-service-type)
    (service elogind-service-type)
+   (service containerd-service-type)
    (service docker-service-type)))
 
 (define (run-docker-test docker-tarball)
@@ -88,7 +89,21 @@ (define (run-docker-test docker-tarball)
           (test-runner-current (system-test-runner #$output))
           (test-begin "docker")
 
-          (test-assert "service running"
+          (test-assert "containerd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'containerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "containerd PID file present"
+            (wait-for-file "/run/containerd/containerd.pid" marionette))
+
+          (test-assert "dockerd service running"
             (marionette-eval
              '(begin
                 (use-modules (gnu services herd))
@@ -234,6 +249,20 @@ (define (run-docker-system-test tarball)
           (test-runner-current (system-test-runner #$output))
           (test-begin "docker")
 
+          (test-assert "containerd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'containerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "containerd PID file present"
+            (wait-for-file "/run/containerd/containerd.pid" marionette))
+
           (test-assert "service running"
             (marionette-eval
              '(begin
@@ -327,6 +356,7 @@ (define %oci-os
    (service dbus-root-service-type)
    (service polkit-service-type)
    (service elogind-service-type)
+   (service containerd-service-type)
    (service docker-service-type)
    (extra-special-file "/shared.txt"
                        (plain-file "shared.txt" "hello"))
@@ -384,6 +414,20 @@ (define (run-oci-container-test)
           (test-runner-current (system-test-runner #$output))
           (test-begin "oci-container")
 
+          (test-assert "containerd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'containerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "containerd PID file present"
+            (wait-for-file "/run/containerd/containerd.pid" marionette))
+
           (test-assert "dockerd running"
             (marionette-eval
              '(begin
-- 
2.41.0





^ permalink raw reply related	[relevance 67%]

* [bug#71263] [PATCH 4/5] gnu: docker: Allow setting Shepherd respawn? in oci-container-configuration.
    2024-05-29 21:38 60% ` [bug#71263] [PATCH 2/5] gnu: docker: Allow setting Shepherd log-file in oci-container-configuration Giacomo Leidi via Guix-patches via
  2024-05-29 21:38 64% ` [bug#71263] [PATCH 3/5] gnu: docker: Allow setting Shepherd auto-start? " Giacomo Leidi via Guix-patches via
@ 2024-05-29 21:38 65% ` Giacomo Leidi via Guix-patches via
  2024-05-29 21:38 62% ` [bug#71263] [PATCH 5/5] gnu: docker: Allow setting Shepherd actions " Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-29 21:38 UTC (permalink / raw)
  To: 71263
  Cc: Giacomo Leidi, Florian Pelz, Ludovic Courtès,
	Matthew Trzcinski, Maxim Cournoyer

* gnu/services/docker.scm (oci-container-configuration)
[respawn?]: New field;
(oci-container-shepherd-service): use it.

Change-Id: I0d6367607fd0fd41f90a54b33d80bf4d4f43dd8b
---
 doc/guix.texi           | 4 ++++
 gnu/services/docker.scm | 9 ++++++++-
 2 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index dfc4d65349..9abdc77869 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40653,6 +40653,10 @@ Miscellaneous Services
 Whether this service should be started automatically by the Shepherd.  If it
 is @code{#f} the service has to be started manually with @command{herd start}.
 
+@item @code{respawn?} (default: @code{#f}) (type: boolean)
+Whether to have Shepherd restart the service when it stops, for instance when
+the underlying process dies.
+
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 712ca14cba..bc566e6316 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -76,6 +76,7 @@ (define-module (gnu services docker)
             oci-container-configuration-requirement
             oci-container-configuration-log-file
             oci-container-configuration-auto-start?
+            oci-container-configuration-respawn?
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
@@ -472,6 +473,10 @@ (define-configuration/no-serialization oci-container-configuration
    (boolean #t)
    "Whether this service should be started automatically by the Shepherd.  If it
 is @code{#f} the service has to be started manually with @command{herd start}.")
+  (respawn?
+   (boolean #f)
+   "Whether to restart the service when it stops, for instance when the
+underlying process dies.")
   (network
    (maybe-string)
    "Set a Docker network for the spawned container.")
@@ -685,6 +690,8 @@ (define (oci-container-shepherd-service config)
          (log-file (oci-container-configuration-log-file config))
          (provision (oci-container-configuration-provision config))
          (requirement (oci-container-configuration-requirement config))
+         (respawn?
+          (oci-container-configuration-respawn? config))
          (image (oci-container-configuration-image config))
          (image-reference (oci-image-reference image))
          (options (oci-container-configuration->options config))
@@ -697,7 +704,7 @@ (define (oci-container-shepherd-service config)
 
     (shepherd-service (provision `(,(string->symbol name)))
                       (requirement `(dockerd user-processes ,@requirement))
-                      (respawn? #f)
+                      (respawn? respawn?)
                       (auto-start? auto-start?)
                       (documentation
                        (string-append
-- 
2.41.0





^ permalink raw reply related	[relevance 65%]

* [bug#71263] [PATCH 3/5] gnu: docker: Allow setting Shepherd auto-start? in oci-container-configuration.
    2024-05-29 21:38 60% ` [bug#71263] [PATCH 2/5] gnu: docker: Allow setting Shepherd log-file in oci-container-configuration Giacomo Leidi via Guix-patches via
@ 2024-05-29 21:38 64% ` Giacomo Leidi via Guix-patches via
  2024-05-29 21:38 65% ` [bug#71263] [PATCH 4/5] gnu: docker: Allow setting Shepherd respawn? " Giacomo Leidi via Guix-patches via
  2024-05-29 21:38 62% ` [bug#71263] [PATCH 5/5] gnu: docker: Allow setting Shepherd actions " Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-29 21:38 UTC (permalink / raw)
  To: 71263
  Cc: Giacomo Leidi, Florian Pelz, Ludovic Courtès,
	Matthew Trzcinski, Maxim Cournoyer

* gnu/services/docker.scm (oci-container-configuration)
[auto-start?]: New field;
(oci-container-shepherd-service): use it.

Change-Id: Id093d93effbbec3e1be757f8be83cf5f62eaeda7
---
 doc/guix.texi           | 4 ++++
 gnu/services/docker.scm | 8 ++++++++
 2 files changed, 12 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 954196b14c..dfc4d65349 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40649,6 +40649,10 @@ Miscellaneous Services
 standard output and standard error are redirected.  @code{log-file} is created
 if it does not exist, otherwise it is appended to.
 
+@item @code{auto-start?} (default: @code{#t}) (type: boolean)
+Whether this service should be started automatically by the Shepherd.  If it
+is @code{#f} the service has to be started manually with @command{herd start}.
+
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 678e8b1139..712ca14cba 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -75,6 +75,7 @@ (define-module (gnu services docker)
             oci-container-configuration-provision
             oci-container-configuration-requirement
             oci-container-configuration-log-file
+            oci-container-configuration-auto-start?
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
@@ -467,6 +468,10 @@ (define-configuration/no-serialization oci-container-configuration
    "When @code{log-file} is set, it names the file to which the service’s
 standard output and standard error are redirected.  @code{log-file} is created
 if it does not exist, otherwise it is appended to.")
+  (auto-start?
+   (boolean #t)
+   "Whether this service should be started automatically by the Shepherd.  If it
+is @code{#f} the service has to be started manually with @command{herd start}.")
   (network
    (maybe-string)
    "Set a Docker network for the spawned container.")
@@ -670,6 +675,8 @@ (define (oci-container-shepherd-service config)
                             (oci-image-repository image))))))
 
   (let* ((docker (file-append docker-cli "/bin/docker"))
+         (auto-start?
+          (oci-container-configuration-auto-start? config))
          (user (oci-container-configuration-user config))
          (group (oci-container-configuration-group config))
          (host-environment
@@ -691,6 +698,7 @@ (define (oci-container-shepherd-service config)
     (shepherd-service (provision `(,(string->symbol name)))
                       (requirement `(dockerd user-processes ,@requirement))
                       (respawn? #f)
+                      (auto-start? auto-start?)
                       (documentation
                        (string-append
                         "Docker backed Shepherd service for "
-- 
2.41.0





^ permalink raw reply related	[relevance 64%]

* [bug#71263] [PATCH 5/5] gnu: docker: Allow setting Shepherd actions in oci-container-configuration.
                     ` (2 preceding siblings ...)
  2024-05-29 21:38 65% ` [bug#71263] [PATCH 4/5] gnu: docker: Allow setting Shepherd respawn? " Giacomo Leidi via Guix-patches via
@ 2024-05-29 21:38 62% ` Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-29 21:38 UTC (permalink / raw)
  To: 71263
  Cc: Giacomo Leidi, Florian Pelz, Ludovic Courtès,
	Matthew Trzcinski, Maxim Cournoyer

* gnu/services/docker.scm (oci-container-configuration)
[shepherd-actions]: New field;
(sanitize-shepherd-actions): sanitize it;
(oci-container-shepherd-service): use it.

Change-Id: I0ca9826542be7cb8ca280a07a9bff1a262c2a8a7
---
 doc/guix.texi           |  4 ++++
 gnu/services/docker.scm | 38 +++++++++++++++++++++++++++++---------
 2 files changed, 33 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 9abdc77869..4c137ee31e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40657,6 +40657,10 @@ Miscellaneous Services
 Whether to have Shepherd restart the service when it stops, for instance when
 the underlying process dies.
 
+@item @code{shepherd-actions} (default: @code{'()}) (type: list-of-symbols)
+This is a list of @code{shepherd-action} records defining actions supported
+by the service.
+
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index bc566e6316..78d7e2f04e 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -77,6 +77,7 @@ (define-module (gnu services docker)
             oci-container-configuration-log-file
             oci-container-configuration-auto-start?
             oci-container-configuration-respawn?
+            oci-container-configuration-shepherd-actions
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
@@ -328,6 +329,17 @@ (define (oci-sanitize-volumes value)
   ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
   (oci-sanitize-mixed-list "volumes" value ":"))
 
+(define (oci-sanitize-shepherd-actions value)
+  (map
+   (lambda (el)
+     (if (shepherd-action? el)
+         el
+         (raise
+          (formatted-message
+           (G_ "shepherd-actions may only be shepherd-action records
+but ~a was found") el))))
+   value))
+
 (define (oci-sanitize-extra-arguments value)
   (define (valid? member)
     (or (string? member)
@@ -477,6 +489,11 @@ (define-configuration/no-serialization oci-container-configuration
    (boolean #f)
    "Whether to restart the service when it stops, for instance when the
 underlying process dies.")
+  (shepherd-actions
+   (list '())
+   "This is a list of @code{shepherd-action} records defining actions supported
+by the service."
+   (sanitizer oci-sanitize-shepherd-actions))
   (network
    (maybe-string)
    "Set a Docker network for the spawned container.")
@@ -680,6 +697,7 @@ (define (oci-container-shepherd-service config)
                             (oci-image-repository image))))))
 
   (let* ((docker (file-append docker-cli "/bin/docker"))
+         (actions (oci-container-configuration-shepherd-actions config))
          (auto-start?
           (oci-container-configuration-auto-start? config))
          (user (oci-container-configuration-user config))
@@ -732,15 +750,17 @@ (define (oci-container-shepherd-service config)
                       (actions
                        (if (oci-image? image)
                            '()
-                           (list
-                            (shepherd-action
-                             (name 'pull)
-                             (documentation
-                              (format #f "Pull ~a's image (~a)."
-                                      name image))
-                             (procedure
-                              #~(lambda _
-                                  (invoke #$docker "pull" #$image))))))))))
+                           (append
+                            (list
+                             (shepherd-action
+                              (name 'pull)
+                              (documentation
+                               (format #f "Pull ~a's image (~a)."
+                                       name image))
+                              (procedure
+                               #~(lambda _
+                                   (invoke #$docker "pull" #$image)))))
+                            actions))))))
 
 (define %oci-container-accounts
   (list (user-account
-- 
2.41.0





^ permalink raw reply related	[relevance 62%]

* [bug#71263] [PATCH 2/5] gnu: docker: Allow setting Shepherd log-file in oci-container-configuration.
  @ 2024-05-29 21:38 60% ` Giacomo Leidi via Guix-patches via
  2024-05-29 21:38 64% ` [bug#71263] [PATCH 3/5] gnu: docker: Allow setting Shepherd auto-start? " Giacomo Leidi via Guix-patches via
                   ` (2 subsequent siblings)
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-29 21:38 UTC (permalink / raw)
  To: 71263
  Cc: Giacomo Leidi, Florian Pelz, Ludovic Courtès,
	Matthew Trzcinski, Maxim Cournoyer

* gnu/services/docker.scm (oci-container-configuration)
[log-file]: New field;
(oci-container-shepherd-service): use it.

Change-Id: Icad29ac6342b6f5bafc0d9be13a93cee99674185
---
 doc/guix.texi           |  5 +++++
 gnu/services/docker.scm | 36 ++++++++++++++++++++++++------------
 2 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 8662586b46..954196b14c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40644,6 +40644,11 @@ Miscellaneous Services
 Set additional Shepherd services dependencies to the provisioned
 Shepherd service.
 
+@item @code{log-file} (default: @code{""}) (type: string)
+When @code{log-file} is set, it names the file to which the service's
+standard output and standard error are redirected.  @code{log-file} is created
+if it does not exist, otherwise it is appended to.
+
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 7aff8dcc5f..678e8b1139 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -74,6 +74,7 @@ (define-module (gnu services docker)
             oci-container-configuration-image
             oci-container-configuration-provision
             oci-container-configuration-requirement
+            oci-container-configuration-log-file
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
@@ -461,6 +462,11 @@ (define-configuration/no-serialization oci-container-configuration
    (list-of-symbols '())
    "Set additional Shepherd services dependencies to the provisioned Shepherd
 service.")
+  (log-file
+   (maybe-string)
+   "When @code{log-file} is set, it names the file to which the service’s
+standard output and standard error are redirected.  @code{log-file} is created
+if it does not exist, otherwise it is appended to.")
   (network
    (maybe-string)
    "Set a Docker network for the spawned container.")
@@ -669,12 +675,16 @@ (define (oci-container-shepherd-service config)
          (host-environment
           (oci-container-configuration-host-environment config))
          (command (oci-container-configuration-command config))
+         (log-file (oci-container-configuration-log-file config))
          (provision (oci-container-configuration-provision config))
          (requirement (oci-container-configuration-requirement config))
          (image (oci-container-configuration-image config))
          (image-reference (oci-image-reference image))
          (options (oci-container-configuration->options config))
          (name (guess-name provision image))
+         (loader (if (oci-image? image)
+                     (%oci-image-loader name image image-reference)
+                     #f))
          (extra-arguments
           (oci-container-configuration-extra-arguments config)))
 
@@ -687,18 +697,20 @@ (define (oci-container-shepherd-service config)
                         (if (oci-image? image) name image) "."))
                       (start
                        #~(lambda ()
-                          (when #$(oci-image? image)
-                            (invoke #$(%oci-image-loader
-                                       name image image-reference)))
-                          (fork+exec-command
-                           ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
-                           (list #$docker "run" "--rm" "--name" #$name
-                                 #$@options #$@extra-arguments
-                                 #$image-reference #$@command)
-                           #:user #$user
-                           #:group #$group
-                           #:environment-variables
-                           (list #$@host-environment))))
+                           (when #$(oci-image? image)
+                             (invoke #$loader))
+                           (fork+exec-command
+                            ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                            (list #$docker "run" "--rm" "--name" #$name
+                                  #$@options #$@extra-arguments
+                                  #$image-reference #$@command)
+                            #:user #$user
+                            #:group #$group
+                            #$@(if (maybe-value-set? log-file)
+                                   (list #:log-file log-file)
+                                   '())
+                            #:environment-variables
+                            (list #$@host-environment))))
                       (stop
                        #~(lambda _
                            (invoke #$docker "rm" "-f" #$name)))
-- 
2.41.0





^ permalink raw reply related	[relevance 60%]

* [bug#71254] [PATCH] services: oci-container: fix provided image is string.
@ 2024-05-29  4:17 72% Zheng Junjie
  0 siblings, 0 replies; 149+ results
From: Zheng Junjie @ 2024-05-29  4:17 UTC (permalink / raw)
  To: 71254

gnu/services/docker.scm (oci-container-shepherd-service): when image is
oci-image, call %oci-image-loader.

Change-Id: I26105e82643affe9e7037975e42ec9690089545b
---
 gnu/services/docker.scm | 25 +++++++++++++------------
 1 file changed, 13 insertions(+), 12 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 7aff8dcc5f..cc1201508c 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -687,18 +687,19 @@ (define (oci-container-shepherd-service config)
                         (if (oci-image? image) name image) "."))
                       (start
                        #~(lambda ()
-                          (when #$(oci-image? image)
-                            (invoke #$(%oci-image-loader
-                                       name image image-reference)))
-                          (fork+exec-command
-                           ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
-                           (list #$docker "run" "--rm" "--name" #$name
-                                 #$@options #$@extra-arguments
-                                 #$image-reference #$@command)
-                           #:user #$user
-                           #:group #$group
-                           #:environment-variables
-                           (list #$@host-environment))))
+                           #$@(if (oci-image? image)
+                                  #~((invoke #$(%oci-image-loader
+                                                name image image-reference)))
+                                  #~())
+                           (fork+exec-command
+                            ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                            (list #$docker "run" "--rm" "--name" #$name
+                                  #$@options #$@extra-arguments
+                                  #$image-reference #$@command)
+                            #:user #$user
+                            #:group #$group
+                            #:environment-variables
+                            (list #$@host-environment))))
                       (stop
                        #~(lambda _
                            (invoke #$docker "rm" "-f" #$name)))

base-commit: 473cdecd8965a301ef6817027090bc61c6907a18
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#70855] [PATCH 12/92] gnu: python-docker-pycreds: Move to pyproject-build-system.
  @ 2024-05-09 22:53 67% ` Nicolas Graves via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Nicolas Graves via Guix-patches via @ 2024-05-09 22:53 UTC (permalink / raw)
  To: 70855; +Cc: ngraves

* gnu/packages/docker.scm (python-docker-pycreds):
  [build-system]: Move to pyproject-build-system.
  [arguments]<#:test-flags>: Use it.
  <#:phases>: Remove uneeded field.
  [native-inputs]: Remove python-pytest-cov and python-flake8. Add
  python-setuptools, python-wheel.

Change-Id: Idde93a366fa187d2af915ed15801da2cdbaa3792
---
 gnu/packages/docker.scm | 18 +++++++-----------
 1 file changed, 7 insertions(+), 11 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index b18de182fe5..de1baa15172 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021, 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.com>
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,6 +36,7 @@ (define-module (gnu packages docker)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
+  #:use-module (guix build-system pyproject)
   #:use-module (guix utils)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages base)
@@ -47,6 +49,7 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages networking)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-build)
   #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
   #:use-module (gnu packages python-xyz)
@@ -151,19 +154,12 @@ (define-public python-docker-pycreds
         (sha256
          (base32
           "1m44smrggnqghxkqfl7vhapdw89m1p3vdr177r6cq17lr85jgqvc"))))
-    (build-system python-build-system)
+    (build-system pyproject-build-system)
     (arguments
-     `(#:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'fix-versioning
-           (lambda _
-             (substitute* "test-requirements.txt"
-               (("3.0.2") ,(package-version python-pytest))
-               (("2.3.1") ,(package-version python-pytest-cov))
-               (("2.4.1") ,(package-version python-flake8)))
-             #t)))))
+     (list  ; XXX: These tests require docker credentials to run.
+      #:test-flags '(list "--ignore=tests/store_test.py")))
     (native-inputs
-     (list python-flake8 python-pytest python-pytest-cov))
+     (list python-pytest python-setuptools python-wheel))
     (propagated-inputs
      (list python-six))
     (home-page "https://github.com/shin-/dockerpy-creds")
-- 
2.41.0





^ permalink raw reply related	[relevance 67%]

* [bug#70735] [PATCH 047/714] gnu: python-docker-pycreds: Remove python-flake8 native-input.
  @ 2024-05-03 22:18 72% ` Nicolas Graves via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Nicolas Graves via Guix-patches via @ 2024-05-03 22:18 UTC (permalink / raw)
  To: 70735; +Cc: ngraves

* gnu/packages/docker.scm (python-docker-pycreds):
  [native-inputs]: Remove python-flake8.

Change-Id: I98966a387f433b47698ffa8c8dec952b354dbd7a
---
 gnu/packages/docker.scm | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index b18de182fe..adeff26af4 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -159,11 +159,9 @@ (define-public python-docker-pycreds
            (lambda _
              (substitute* "test-requirements.txt"
                (("3.0.2") ,(package-version python-pytest))
-               (("2.3.1") ,(package-version python-pytest-cov))
-               (("2.4.1") ,(package-version python-flake8)))
-             #t)))))
+               (("2.3.1") ,(package-version python-pytest-cov))))))))
     (native-inputs
-     (list python-flake8 python-pytest python-pytest-cov))
+     (list python-pytest python-pytest-cov))
     (propagated-inputs
      (list python-six))
     (home-page "https://github.com/shin-/dockerpy-creds")
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration.
    2023-12-03 21:56 70% ` [bug#67613] [PATCH] tests: Add oci-container-service-type unit tests Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
@ 2024-05-03 22:11 45% ` Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
                     ` (3 more replies)
  2 siblings, 4 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-03 22:11 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/services/docker.scm (exports): Add missing procedures;
(oci-container-service-type)[description]: Docker and OCI images should
mean the same thing;
(oci-container-configuration): clarify field types;
[extra-arguments]: new field;
(oci-sanitize-extra-arguments): sanitize it;
(oci-container-shepherd-service): use it.
* doc/guix.texi: Document it.

Change-Id: I64e9d82c8ae538d59d1c482f23070a880156ddf7
---
 doc/guix.texi           | 21 ++++++++++++-------
 gnu/services/docker.scm | 46 +++++++++++++++++++++++++++++++++--------
 2 files changed, 51 insertions(+), 16 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3f5d4e7f0d..19b7563916 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40430,13 +40430,13 @@ Miscellaneous Services
 @item @code{group} (default: @code{"docker"}) (type: string)
 The group under whose authority docker commands will be run.
 
-@item @code{command} (default: @code{()}) (type: list-of-strings)
+@item @code{command} (default: @code{'()}) (type: list-of-strings)
 Overwrite the default command (@code{CMD}) of the image.
 
 @item @code{entrypoint} (default: @code{""}) (type: string)
 Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
 
-@item @code{environment} (default: @code{()}) (type: list)
+@item @code{environment} (default: @code{'()}) (type: list)
 Set environment variables. This can be a list of pairs or strings, even mixed:
 
 @lisp
@@ -40444,7 +40444,8 @@ Miscellaneous Services
       "JAVA_HOME=/opt/java")
 @end lisp
 
-String are passed directly to the Docker CLI. You can refer to the
+Pair members can be strings, gexps or file-like objects.
+Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
 documentation for semantics.
 
@@ -40459,7 +40460,7 @@ Miscellaneous Services
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
-@item @code{ports} (default: @code{()}) (type: list)
+@item @code{ports} (default: @code{'()}) (type: list)
 Set the port or port ranges to expose from the spawned container.  This can be a
 list of pairs or strings, even mixed:
 
@@ -40468,11 +40469,12 @@ Miscellaneous Services
       "10443:443")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects.
+Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
 documentation for semantics.
 
-@item @code{volumes} (default: @code{()}) (type: list)
+@item @code{volumes} (default: @code{'()}) (type: list)
 Set volume mappings for the spawned container.  This can be a
 list of pairs or strings, even mixed:
 
@@ -40481,7 +40483,8 @@ Miscellaneous Services
       "/gnu/store:/gnu/store")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects.
+Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
 documentation for semantics.
 
@@ -40496,6 +40499,10 @@ Miscellaneous Services
 @url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
 documentation for semantics.
 
+@item @code{extra-arguments} (default: @code{'()}) (type: list)
+A list of strings, gexps or file-like objects that will be directly
+passed to the @command{docker run} invokation.
+
 @end table
 
 @end deftp
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 4d32b96847..824c4ecbe6 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -58,6 +58,9 @@ (define-module (gnu services docker)
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
+            oci-container-configuration-container-user
+            oci-container-configuration-workdir
+            oci-container-configuration-extra-arguments
             oci-container-service-type
             oci-container-shepherd-service))
 
@@ -297,6 +300,21 @@ (define (oci-sanitize-volumes value)
   ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
   (oci-sanitize-mixed-list "volumes" value ":"))
 
+(define (oci-sanitize-extra-arguments value)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (map
+   (lambda (el)
+     (if (valid? el)
+         el
+         (raise
+          (formatted-message
+           (G_ "extra arguments may only be strings, gexps or file-like objects
+but ~a was found") el))))
+   value))
+
 (define-maybe/no-serialization string)
 
 (define-configuration/no-serialization oci-container-configuration
@@ -314,15 +332,16 @@ (define-configuration/no-serialization oci-container-configuration
    "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
   (environment
    (list '())
-   "Set environment variables.  This can be a list of pairs or strings, even
-mixed:
+   "Set environment variables inside the container.  This can be a list of pairs
+or strings, even mixed:
 
 @lisp
 (list '(\"LANGUAGE\" . \"eo:ca:eu\")
       \"JAVA_HOME=/opt/java\")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI.  You can refer to the
 @url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
 documentation for semantics."
    (sanitizer oci-sanitize-environment))
@@ -347,7 +366,8 @@ (define-configuration/no-serialization oci-container-configuration
       \"10443:443\")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI.  You can refer to the
 @url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
 documentation for semantics."
    (sanitizer oci-sanitize-ports))
@@ -361,7 +381,8 @@ (define-configuration/no-serialization oci-container-configuration
       \"/gnu/store:/gnu/store\")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI.  You can refer to the
 @url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
 documentation for semantics."
    (sanitizer oci-sanitize-volumes))
@@ -375,7 +396,12 @@ (define-configuration/no-serialization oci-container-configuration
    "Set the current working for the spawned Shepherd service.
 You can refer to the
 @url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
-documentation for semantics."))
+documentation for semantics.")
+  (extra-arguments
+   (list '())
+   "A list of strings, gexps or file-like objects that will be directly passed
+to the @command{docker run} invokation."
+   (sanitizer oci-sanitize-extra-arguments)))
 
 (define oci-container-configuration->options
   (lambda (config)
@@ -428,7 +454,9 @@ (define (oci-container-shepherd-service config)
          (provision (oci-container-configuration-provision config))
          (image (oci-container-configuration-image config))
          (options (oci-container-configuration->options config))
-         (name (guess-name provision image)))
+         (name (guess-name provision image))
+         (extra-arguments
+          (oci-container-configuration-extra-arguments config)))
 
     (shepherd-service (provision `(,(string->symbol name)))
                       (requirement '(dockerd user-processes))
@@ -441,7 +469,7 @@ (define (oci-container-shepherd-service config)
                           ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
                           (list #$docker-command "run" "--rm"
                                 "--name" #$name
-                                #$@options #$image #$@command)
+                                #$@options #$@extra-arguments #$image #$@command)
                           #:user #$user
                           #:group #$group))
                       (stop
@@ -482,5 +510,5 @@ (define oci-container-service-type
                 (extend append)
                 (compose concatenate)
                 (description
-                 "This service allows the management of Docker and OCI
+                 "This service allows the management of OCI
 containers as Shepherd services.")))

base-commit: 7d4ae2fca723114fb1df56de33b82177fbc4d0a6
-- 
2.41.0





^ permalink raw reply related	[relevance 45%]

* [bug#67613] [PATCH v3 2/5] gnu: docker: Allow setting host environment variables in oci-container-configuration.
  2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
@ 2024-05-03 22:11 57%   ` Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 67%   ` [bug#67613] [PATCH v3 3/5] gnu: docker: Allow setting Shepherd dependencies " Giacomo Leidi via Guix-patches via
                     ` (2 subsequent siblings)
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-03 22:11 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration)
[host-environment]: New field;
(oci-sanitize-host-environment): sanitize it;
(oci-container-shepherd-service): use it.
* doc/guix.texi: Document it.

Change-Id: I4d54d37736cf09f042a71cb0b6e673abc0948d9c
---
 doc/guix.texi           | 17 +++++++++++++++++
 gnu/services/docker.scm | 31 +++++++++++++++++++++++++++++--
 2 files changed, 46 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 19b7563916..fad0bf8c7c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40436,6 +40436,23 @@ Miscellaneous Services
 @item @code{entrypoint} (default: @code{""}) (type: string)
 Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
 
+@item @code{host-environment} (default: @code{'()}) (type: list)
+Set environment variables in the host environment where @command{docker
+run} is invoked.  This is especially useful to pass secrets from the
+host to the container without having them on the @command{docker run}'s
+command line: by setting the @code{MYSQL_PASSWORD} on the host and by passing
+@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
+possible to securely set values in the container environment.  This field's
+value can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to @code{make-forkexec-constructor}.
+
 @item @code{environment} (default: @code{'()}) (type: list)
 Set environment variables. This can be a list of pairs or strings, even mixed:
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 824c4ecbe6..df5884aca1 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,7 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
-;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
+;;; Copyright © 2023, 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -285,6 +285,11 @@ (define (oci-sanitize-mixed-list name value delimiter)
               name el)))))
    value))
 
+(define (oci-sanitize-host-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "host-environment" value "="))
+
 (define (oci-sanitize-environment value)
   ;; Expected spec format:
   ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
@@ -330,6 +335,24 @@ (define-configuration/no-serialization oci-container-configuration
   (entrypoint
    (maybe-string)
    "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+  (host-environment
+   (list '())
+   "Set environment variables in the host environment where @command{docker run}
+is invoked.  This is especially useful to pass secrets from the host to the
+container without having them on the @command{docker run}'s command line: by
+setting the @code{MYSQL_PASSWORD} on the host and by passing
+@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
+possible to securely set values in the container environment.  This field's
+value can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to @code{make-forkexec-constructor}."
+   (sanitizer oci-sanitize-host-environment))
   (environment
    (list '())
    "Set environment variables inside the container.  This can be a list of pairs
@@ -450,6 +473,8 @@ (define (oci-container-shepherd-service config)
   (let* ((docker-command (file-append docker-cli "/bin/docker"))
          (user (oci-container-configuration-user config))
          (group (oci-container-configuration-group config))
+         (host-environment
+          (oci-container-configuration-host-environment config))
          (command (oci-container-configuration-command config))
          (provision (oci-container-configuration-provision config))
          (image (oci-container-configuration-image config))
@@ -471,7 +496,9 @@ (define (oci-container-shepherd-service config)
                                 "--name" #$name
                                 #$@options #$@extra-arguments #$image #$@command)
                           #:user #$user
-                          #:group #$group))
+                          #:group #$group
+                          #:environment-variables
+                          (list #$@host-environment)))
                       (stop
                        #~(lambda _
                            (invoke #$docker-command "rm" "-f" #$name)))
-- 
2.41.0





^ permalink raw reply related	[relevance 57%]

* [bug#67613] [PATCH v3 5/5] gnu: Add tests for oci-container-service-type.
  2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
                     ` (2 preceding siblings ...)
  2024-05-03 22:11 34%   ` [bug#67613] [PATCH v3 4/5] gnu: docker: Allow passing tarballs for images " Giacomo Leidi via Guix-patches via
@ 2024-05-03 22:11 57%   ` Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-03 22:11 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/tests/docker.scm (run-oci-container-test): New variable;
(%test-oci-container): new variable.

Change-Id: Idefc3840bdc6e0ed4264e8f27373cd9a670f87a0
---
 gnu/tests/docker.scm | 131 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 130 insertions(+), 1 deletion(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 9e9d2e2d07..d550136b4a 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (gnu tests docker)
   #:use-module (gnu services networking)
   #:use-module (gnu services docker)
   #:use-module (gnu services desktop)
+  #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (glibc))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages docker)
@@ -43,7 +45,8 @@ (define-module (gnu tests docker)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (%test-docker
-            %test-docker-system))
+            %test-docker-system
+            %test-oci-container))
 
 (define %docker-os
   (simple-operating-system
@@ -316,3 +319,129 @@ (define %test-docker-system
                                    (locale-libcs (list glibc)))
                                  #:type docker-image-type)))
                  run-docker-system-test)))))
+
+\f
+(define %oci-os
+  (simple-operating-system
+   (service dhcp-client-service-type)
+   (service dbus-root-service-type)
+   (service polkit-service-type)
+   (service elogind-service-type)
+   (service docker-service-type)
+   (extra-special-file "/shared.txt"
+                       (plain-file "shared.txt" "hello"))
+   (service oci-container-service-type
+            (list
+             (oci-container-configuration
+              (image
+               (oci-image
+                (repository "guile")
+                (value
+                 (specifications->manifest '("guile")))
+                (pack-options
+                 '(#:symlinks (("/bin" -> "bin"))))))
+              (entrypoint
+               "/bin/guile")
+              (command
+               '("-c" "(let l ((c 300))(display c)(sleep 1)(when(positive? c)(l (- c 1))))"))
+              (host-environment
+               '(("VARIABLE" . "value")))
+              (volumes
+               '(("/shared.txt" . "/shared.txt:ro")))
+              (extra-arguments
+               '("--env" "VARIABLE")))))))
+
+(define (run-oci-container-test)
+  "Run IMAGE as an OCI backed Shepherd service, inside OS."
+
+  (define os
+    (marionette-operating-system
+     (operating-system-with-gc-roots
+      %oci-os
+      (list))
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (volatile? #f)
+     (memory-size 1024)
+     (disk-image-size (* 3000 (expt 2 20)))
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            ;; Relax timeout to accommodate older systems and
+            ;; allow for pulling the image.
+            (make-marionette (list #$vm) #:timeout 60))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "oci-container")
+
+          (test-assert "dockerd running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'dockerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (sleep 10) ; let service start
+
+          (test-assert "docker-guile running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'docker-guile)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-equal "passing host environment variables and volumes"
+            '("value" "hello")
+            (marionette-eval
+             `(begin
+                (use-modules (ice-9 popen)
+                             (ice-9 rdelim))
+
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (let ((line (read-line port)))
+                                     (if (eof-object? line)
+                                         ""
+                                         line)))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((response1 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "exec" "docker-guile"
+                                   "/bin/guile" "-c" "(display (getenv \"VARIABLE\"))"))
+                       (response2 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "exec" "docker-guile"
+                                   "/bin/guile" "-c" "(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(display (call-with-input-file \"/shared.txt\" read-line)))")))
+                  (list response1 response2)))
+             marionette))
+
+          (test-end))))
+
+  (gexp->derivation "oci-container-test" test))
+
+(define %test-oci-container
+  (system-test
+   (name "oci-container")
+   (description "Test OCI backed Shepherd service.")
+   (value (run-oci-container-test))))
-- 
2.41.0





^ permalink raw reply related	[relevance 57%]

* [bug#67613] [PATCH v3 3/5] gnu: docker: Allow setting Shepherd dependencies in oci-container-configuration.
  2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
@ 2024-05-03 22:11 67%   ` Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 34%   ` [bug#67613] [PATCH v3 4/5] gnu: docker: Allow passing tarballs for images " Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 5/5] gnu: Add tests for oci-container-service-type Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-03 22:11 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration)
[requirement]: New field;
(list-of-symbols): sanitize it;
(oci-container-shepherd-service): use it.
* doc/guix.texi: Document it.

Change-Id: Ic0ba336a2257d6ef7c658cfc6cd630116661f581
---
 doc/guix.texi           |  4 ++++
 gnu/services/docker.scm | 10 +++++++++-
 2 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fad0bf8c7c..2b9cc5602c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40474,6 +40474,10 @@ Miscellaneous Services
 @item @code{provision} (default: @code{""}) (type: string)
 Set the name of the provisioned Shepherd service.
 
+@item @code{requirement} (default: @code{'()}) (type: list-of-symbols)
+Set additional Shepherd services dependencies to the provisioned
+Shepherd service.
+
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index df5884aca1..a5b1614fa9 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -320,6 +320,9 @@ (define (oci-sanitize-extra-arguments value)
 but ~a was found") el))))
    value))
 
+(define list-of-symbols?
+  (list-of symbol?))
+
 (define-maybe/no-serialization string)
 
 (define-configuration/no-serialization oci-container-configuration
@@ -376,6 +379,10 @@ (define-configuration/no-serialization oci-container-configuration
   (provision
    (maybe-string)
    "Set the name of the provisioned Shepherd service.")
+  (requirement
+   (list-of-symbols '())
+   "Set additional Shepherd services dependencies to the provisioned Shepherd
+service.")
   (network
    (maybe-string)
    "Set a Docker network for the spawned container.")
@@ -477,6 +484,7 @@ (define (oci-container-shepherd-service config)
           (oci-container-configuration-host-environment config))
          (command (oci-container-configuration-command config))
          (provision (oci-container-configuration-provision config))
+         (requirement (oci-container-configuration-requirement config))
          (image (oci-container-configuration-image config))
          (options (oci-container-configuration->options config))
          (name (guess-name provision image))
@@ -484,7 +492,7 @@ (define (oci-container-shepherd-service config)
           (oci-container-configuration-extra-arguments config)))
 
     (shepherd-service (provision `(,(string->symbol name)))
-                      (requirement '(dockerd user-processes))
+                      (requirement `(dockerd user-processes ,@requirement))
                       (respawn? #f)
                       (documentation
                        (string-append
-- 
2.41.0





^ permalink raw reply related	[relevance 67%]

* [bug#67613] [PATCH v3 4/5] gnu: docker: Allow passing tarballs for images in oci-container-configuration.
  2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 67%   ` [bug#67613] [PATCH v3 3/5] gnu: docker: Allow setting Shepherd dependencies " Giacomo Leidi via Guix-patches via
@ 2024-05-03 22:11 34%   ` Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 5/5] gnu: Add tests for oci-container-service-type Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-05-03 22:11 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

This commit allows for loading an OCI image tarball before running an
OCI backed Shepherd service. It does so by adding a one shot Shepherd
service to the dependencies of the OCI backed service that at boot runs
docker load on the tarball.

* gnu/services/docker.scm (oci-image): New record;
(lower-oci-image): new variable, lower it;
(string-or-oci-image?): sanitize it;
(oci-container-configuration)[image]: allow also for oci-image records;
(oci-container-shepherd-service): use it;
(%oci-image-loader): new variable.

Change-Id: Ie504f479ea0d47f74b0ec5df9085673ffd3f639d
---
 doc/guix.texi           |  70 +++++++++++-
 gnu/services/docker.scm | 244 ++++++++++++++++++++++++++++++++++++----
 2 files changed, 286 insertions(+), 28 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 2b9cc5602c..451bee5615 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -40390,6 +40390,17 @@ Miscellaneous Services
 @lisp
 (service oci-container-service-type
          (list
+          (oci-container-configuration
+           (image
+            (oci-image
+             (repository "guile")
+             (tag "3")
+             (value (specifications->manifest '("guile")))
+             (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
+                             #:max-layers 2))))
+           (entrypoint "/bin/guile")
+           (command
+            '("-c" "(display \"hello!\n\")")))
           (oci-container-configuration
            (image "prom/prometheus")
            (network "host")
@@ -40466,9 +40477,10 @@ Miscellaneous Services
 @uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
 documentation for semantics.
 
-@item @code{image} (type: string)
-The image used to build the container.  Images are resolved by the
-Docker Engine, and follow the usual format
+@item @code{image} (type: string-or-oci-image)
+The image used to build the container.  It can be a string or an
+@code{oci-image} record.  Strings are resolved by the Docker Engine, and
+follow the usual format
 @code{myregistry.local:5000/testing/test-image:tag}.
 
 @item @code{provision} (default: @code{""}) (type: string)
@@ -40529,6 +40541,58 @@ Miscellaneous Services
 @end deftp
 
 
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} oci-image
+Available @code{oci-image} fields are:
+
+@table @asis
+@item @code{repository} (type: string)
+A string like @code{myregistry.local:5000/testing/test-image} that names
+the OCI image.
+
+@item @code{tag} (default: @code{"latest"}) (type: string)
+A string representing the OCI image tag.  Defaults to @code{latest}.
+
+@item @code{value} (type: oci-lowerable-image)
+A @code{manifest} or @code{operating-system} record that will be lowered
+into an OCI compatible tarball.  Otherwise this field's value can be a
+gexp or a file-like object that evaluates to an OCI compatible tarball.
+
+@item @code{pack-options} (default: @code{'()}) (type: list)
+An optional set of keyword arguments that will be passed to the
+@code{docker-image} procedure from @code{guix scripts pack}.  They can
+be used to replicate @command{guix pack} behavior:
+
+@lisp
+(oci-image
+  (repository "guile")
+  (tag "3")
+  (value
+    (specifications->manifest '("guile")))
+  (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
+                  #:max-layers 2)))
+@end lisp
+
+If the @code{value} field is an @code{operating-system} record, this field's
+value will be ignored.
+
+@item @code{system} (default: @code{""}) (type: string)
+Attempt to build for a given system, e.g. "i686-linux"
+
+@item @code{target} (default: @code{""}) (type: string)
+Attempt to cross-build for a given triple, e.g. "aarch64-linux-gnu"
+
+@item @code{grafts?} (default: @code{#f}) (type: boolean)
+Whether to allow grafting or not in the pack build.
+
+@end table
+
+@end deftp
+
+
 @c %end of fragment
 
 @cindex Audit
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index a5b1614fa9..7aff8dcc5f 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -23,11 +23,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services docker)
+  #:use-module (gnu image)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (gnu system image)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages admin)               ;shadow
@@ -37,7 +40,11 @@ (define-module (gnu services docker)
   #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
+  #:use-module (guix monads)
   #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module ((guix scripts pack) #:prefix pack:)
+  #:use-module (guix store)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -45,6 +52,16 @@ (define-module (gnu services docker)
   #:export (docker-configuration
             docker-service-type
             singularity-service-type
+            oci-image
+            oci-image?
+            oci-image-fields
+            oci-image-repository
+            oci-image-tag
+            oci-image-value
+            oci-image-pack-options
+            oci-image-target
+            oci-image-system
+            oci-image-grafts?
             oci-container-configuration
             oci-container-configuration?
             oci-container-configuration-fields
@@ -52,9 +69,11 @@ (define-module (gnu services docker)
             oci-container-configuration-group
             oci-container-configuration-command
             oci-container-configuration-entrypoint
+            oci-container-configuration-host-environment
             oci-container-configuration-environment
             oci-container-configuration-image
             oci-container-configuration-provision
+            oci-container-configuration-requirement
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
@@ -62,7 +81,8 @@ (define-module (gnu services docker)
             oci-container-configuration-workdir
             oci-container-configuration-extra-arguments
             oci-container-service-type
-            oci-container-shepherd-service))
+            oci-container-shepherd-service
+            %oci-container-accounts))
 
 (define-maybe file-like)
 
@@ -320,11 +340,68 @@ (define (oci-sanitize-extra-arguments value)
 but ~a was found") el))))
    value))
 
+(define (oci-image-reference image)
+  (if (string? image)
+      image
+      (string-append (oci-image-repository image)
+                     ":" (oci-image-tag image))))
+
+(define (oci-lowerable-image? image)
+  (or (manifest? image)
+      (operating-system? image)
+      (gexp? image)
+      (file-like? image)))
+
+(define (string-or-oci-image? image)
+  (or (string? image)
+      (oci-image? image)))
+
 (define list-of-symbols?
   (list-of symbol?))
 
 (define-maybe/no-serialization string)
 
+(define-configuration/no-serialization oci-image
+  (repository
+   (string)
+   "A string like @code{myregistry.local:5000/testing/test-image} that names
+the OCI image.")
+  (tag
+   (string "latest")
+   "A string representing the OCI image tag. Defaults to @code{latest}.")
+  (value
+   (oci-lowerable-image)
+   "A @code{manifest} or @code{operating-system} record that will be lowered
+into an OCI compatible tarball.  Otherwise this field's value can be a gexp
+or a file-like object that evaluates to an OCI compatible tarball.")
+  (pack-options
+   (list '())
+   "An optional set of keyword arguments that will be passed to the
+@code{docker-image} procedure from @code{guix scripts pack}.  They can be used
+to replicate @command{guix pack} behavior:
+
+@lisp
+(oci-image
+  (repository \"guile\")
+  (tag \"3\")
+  (manifest (specifications->manifest '(\"guile\")))
+  (pack-options
+    '(#:symlinks ((\"/bin/guile\" -> \"bin/guile\"))
+      #:max-layers 2)))
+@end lisp
+
+If the @code{value} field is an @code{operating-system} record, this field's
+value will be ignored.")
+  (system
+   (maybe-string)
+   "Attempt to build for a given system, e.g. \"i686-linux\"")
+  (target
+   (maybe-string)
+   "Attempt to cross-build for a given triple, e.g. \"aarch64-linux-gnu\"")
+  (grafts?
+   (boolean #f)
+   "Whether to allow grafting or not in the pack build."))
+
 (define-configuration/no-serialization oci-container-configuration
   (user
    (string "oci-container")
@@ -372,8 +449,9 @@ (define-configuration/no-serialization oci-container-configuration
 documentation for semantics."
    (sanitizer oci-sanitize-environment))
   (image
-   (string)
-   "The image used to build the container.  Images are resolved by the Docker
+   (string-or-oci-image)
+   "The image used to build the container.  It can be a string or an
+@code{oci-image} record.  Strings are resolved by the Docker
 Engine, and follow the usual format
 @code{myregistry.local:5000/testing/test-image:tag}.")
   (provision
@@ -470,14 +548,122 @@ (define oci-container-configuration->options
                            (list "-v" spec))
                          (oci-container-configuration-volumes config))))))))
 
+(define* (get-keyword-value args keyword #:key (default #f))
+  (let ((kv (memq keyword args)))
+    (if (and kv (>= (length kv) 2))
+        (cadr kv)
+        default)))
+
+(define (lower-operating-system os target system)
+  (mlet* %store-monad
+      ((tarball
+        (lower-object
+         (system-image (os->image os #:type docker-image-type))
+         system
+         #:target target)))
+    (return tarball)))
+
+(define (lower-manifest name image target system)
+  (define value (oci-image-value image))
+  (define options (oci-image-pack-options image))
+  (define image-reference
+    (oci-image-reference image))
+  (define image-tag
+    (let* ((extra-options
+            (get-keyword-value options #:extra-options))
+           (image-tag-option
+            (and extra-options
+                 (get-keyword-value extra-options #:image-tag))))
+      (if image-tag-option
+          '()
+          `(#:extra-options (#:image-tag ,image-reference)))))
+
+  (mlet* %store-monad
+      ((_ (set-grafting
+           (oci-image-grafts? image)))
+       (guile (set-guile-for-build (default-guile)))
+       (profile
+        (profile-derivation value
+                            #:target target
+                            #:system system
+                            #:hooks '()
+                            #:locales? #f))
+       (tarball (apply pack:docker-image
+                       `(,name ,profile
+                         ,@options
+                         ,@image-tag
+                         #:localstatedir? #t))))
+    (return tarball)))
+
+(define (lower-oci-image name image)
+  (define value (oci-image-value image))
+  (define image-target (oci-image-target image))
+  (define image-system (oci-image-system image))
+  (define target
+    (if (maybe-value-set? image-target)
+        image-target
+        (%current-target-system)))
+  (define system
+    (if (maybe-value-set? image-system)
+        image-system
+        (%current-system)))
+  (with-store store
+   (run-with-store store
+     (match value
+       ((? manifest? value)
+        (lower-manifest name image target system))
+       ((? operating-system? value)
+        (lower-operating-system value target system))
+       ((or (? gexp? value)
+            (? file-like? value))
+        value)
+       (_
+        (raise
+         (formatted-message
+          (G_ "oci-image value must contain only manifest,
+operating-system, gexp or file-like records but ~a was found")
+          value))))
+     #:target target
+     #:system system)))
+
+(define (%oci-image-loader name image tag)
+  (let ((docker (file-append docker-cli "/bin/docker"))
+        (tarball (lower-oci-image name image)))
+    (with-imported-modules '((guix build utils))
+      (program-file (format #f "~a-image-loader" name)
+       #~(begin
+           (use-modules (guix build utils)
+                        (ice-9 popen)
+                        (ice-9 rdelim))
+
+           (format #t "Loading image for ~a from ~a...~%" #$name #$tarball)
+           (define line
+             (read-line
+              (open-input-pipe
+               (string-append #$docker " load -i " #$tarball))))
+
+           (unless (or (eof-object? line)
+                       (string-null? line))
+             (format #t "~a~%" line)
+             (let ((repository&tag
+                    (string-drop line
+                                 (string-length
+                                   "Loaded image: "))))
+
+               (invoke #$docker "tag" repository&tag #$tag)
+               (format #t "Tagged ~a with ~a...~%" #$tarball #$tag))))))))
+
 (define (oci-container-shepherd-service config)
   (define (guess-name name image)
     (if (maybe-value-set? name)
         name
         (string-append "docker-"
-                       (basename (car (string-split image #\:))))))
+                       (basename
+                        (if (string? image)
+                            (first (string-split image #\:))
+                            (oci-image-repository image))))))
 
-  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+  (let* ((docker (file-append docker-cli "/bin/docker"))
          (user (oci-container-configuration-user config))
          (group (oci-container-configuration-group config))
          (host-environment
@@ -486,6 +672,7 @@ (define (oci-container-shepherd-service config)
          (provision (oci-container-configuration-provision config))
          (requirement (oci-container-configuration-requirement config))
          (image (oci-container-configuration-image config))
+         (image-reference (oci-image-reference image))
          (options (oci-container-configuration->options config))
          (name (guess-name provision image))
          (extra-arguments
@@ -496,30 +683,37 @@ (define (oci-container-shepherd-service config)
                       (respawn? #f)
                       (documentation
                        (string-append
-                        "Docker backed Shepherd service for image: " image))
+                        "Docker backed Shepherd service for "
+                        (if (oci-image? image) name image) "."))
                       (start
-                       #~(make-forkexec-constructor
-                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
-                          (list #$docker-command "run" "--rm"
-                                "--name" #$name
-                                #$@options #$@extra-arguments #$image #$@command)
-                          #:user #$user
-                          #:group #$group
-                          #:environment-variables
-                          (list #$@host-environment)))
+                       #~(lambda ()
+                          (when #$(oci-image? image)
+                            (invoke #$(%oci-image-loader
+                                       name image image-reference)))
+                          (fork+exec-command
+                           ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                           (list #$docker "run" "--rm" "--name" #$name
+                                 #$@options #$@extra-arguments
+                                 #$image-reference #$@command)
+                           #:user #$user
+                           #:group #$group
+                           #:environment-variables
+                           (list #$@host-environment))))
                       (stop
                        #~(lambda _
-                           (invoke #$docker-command "rm" "-f" #$name)))
+                           (invoke #$docker "rm" "-f" #$name)))
                       (actions
-                       (list
-                        (shepherd-action
-                         (name 'pull)
-                         (documentation
-                          (format #f "Pull ~a's image (~a)."
-                                  name image))
-                         (procedure
-                          #~(lambda _
-                              (invoke #$docker-command "pull" #$image)))))))))
+                       (if (oci-image? image)
+                           '()
+                           (list
+                            (shepherd-action
+                             (name 'pull)
+                             (documentation
+                              (format #f "Pull ~a's image (~a)."
+                                      name image))
+                             (procedure
+                              #~(lambda _
+                                  (invoke #$docker "pull" #$image))))))))))
 
 (define %oci-container-accounts
   (list (user-account
-- 
2.41.0





^ permalink raw reply related	[relevance 34%]

* [bug#70739] [PATCH 047/714] gnu: python-docker-pycreds: Remove python-flake8 native-input.
  @ 2024-05-03 16:55 72% ` Nicolas Graves via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Nicolas Graves via Guix-patches via @ 2024-05-03 16:55 UTC (permalink / raw)
  To: 70739; +Cc: ngraves

* gnu/packages/docker.scm (python-docker-pycreds):
  [native-inputs]: Remove python-flake8.

Change-Id: I98966a387f433b47698ffa8c8dec952b354dbd7a
---
 gnu/packages/docker.scm | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index b18de182fe..adeff26af4 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -159,11 +159,9 @@ (define-public python-docker-pycreds
            (lambda _
              (substitute* "test-requirements.txt"
                (("3.0.2") ,(package-version python-pytest))
-               (("2.3.1") ,(package-version python-pytest-cov))
-               (("2.4.1") ,(package-version python-flake8)))
-             #t)))))
+               (("2.3.1") ,(package-version python-pytest-cov))))))))
     (native-inputs
-     (list python-flake8 python-pytest python-pytest-cov))
+     (list python-pytest python-pytest-cov))
     (propagated-inputs
      (list python-six))
     (home-page "https://github.com/shin-/dockerpy-creds")
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#70265] [PATCH 1/3] gnu: Add docker-credential-secretservice.
  @ 2024-04-07 20:57 56% ` Giacomo Leidi via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-04-07 20:57 UTC (permalink / raw)
  To: 70265
  Cc: Giacomo Leidi, Liliana Marie Prikler, Maxim Cournoyer,
	Raghav Gururajan, Vivien Kraus

* gnu/packages/docker.scm (docker-credential-helpers): New variable.
* gnu/packages/gnome.scm (docker-credential-secretservice): New variable.

Change-Id: I6c46d429fa2842969b0fcde58ded72e5b04ee321
---
 gnu/packages/docker.scm | 70 ++++++++++++++++++++++++++++++++++++++++-
 gnu/packages/gnome.scm  |  6 +++-
 2 files changed, 74 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 0fe1f2c1c7..31501e50b9 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021, 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.com>
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,7 +52,8 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages python-web)
   #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages version-control)
-  #:use-module (gnu packages virtualization))
+  #:use-module (gnu packages virtualization)
+  #:export (docker-credential-helpers))
 
 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
@@ -670,6 +672,72 @@ (define-public docker-cli
     (home-page "https://www.docker.com/")
     (license license:asl2.0)))
 
+;; Actual users of this procedure are
+;; docker-credentials-secretservice and docker-credential-pass, they live in
+;; different modules to avoid circular imports.
+(define* (docker-credential-helpers plugin-name #:key (inputs '()))
+  (package
+    (name (string-append "docker-credential-" plugin-name))
+    (version "0.8.1")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/docker/docker-credential-helpers")
+             (commit (string-append "v" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "1kric2yrgypdqncqfrmrh7l7904km5zisygi3fg6zlfkyh6rsm23"))))
+    (build-system go-build-system)
+    (arguments
+     (list
+      #:install-source? #f
+      #:go go-1.19
+      #:unpack-path "github.com/docker/docker-credential-helpers"
+      #:import-path
+      (string-append "github.com/docker/docker-credential-helpers/"
+                     plugin-name "/cmd")
+      #:phases
+      #~(modify-phases %standard-phases
+          (replace 'build
+            (lambda* (#:key unpack-path import-path build-flags #:allow-other-keys)
+              (apply invoke "go" "build"
+                     "-v"
+                     "-x"
+                     (string-append "-ldflags=-s -w "
+                                    "-X github.com/docker/docker-credential-helpers"
+                                    "/credentials.Version=" #$version " "
+                                    "-X github.com/docker/docker-credential-helpers"
+                                    "/credentials.Package=" unpack-path " "
+                                    "-X github.com/docker/docker-credential-helpers"
+                                    "/credentials.Name=" #$name)
+                     "-o" (string-append "bin/" #$name)
+                     `(,@build-flags ,import-path))))
+          (replace 'install
+            (lambda _
+              (let* ((bin
+                     (string-append #$output "/bin"))
+                    (lib
+                     (string-append #$output "/libexec/docker/cli-plugins"))
+                    (entrypoint
+                     (string-append lib "/" #$name)))
+                (mkdir-p bin)
+                (mkdir-p lib)
+                (copy-file (string-append "bin/" #$name) entrypoint)
+                (symlink entrypoint
+                         (string-append bin "/" #$name))))))))
+    (native-inputs
+     (list pkg-config))
+    (inputs inputs)
+    (home-page "https://github.com/docker/docker-credential-helpers")
+    (synopsis "Store Docker login credentials in platform keystores")
+    (description
+     (string-append "docker-credential-helpers is a suite of programs to use native stores to keep
+Docker credentials safe.
+
+This package provides the @code{" name "} plugin."))
+    (license license:expat)))
+
 (define-public cqfd
   (package
     (name "cqfd")
diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm
index 06256066bc..58b53aba22 100644
--- a/gnu/packages/gnome.scm
+++ b/gnu/packages/gnome.scm
@@ -36,7 +36,7 @@
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019, 2020, 2022 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2019 Florian Pelz <pelzflorian@pelzflorian.de>
-;;; Copyright © 2019 Giacomo Leidi <goodoldpaul@autistici.org>
+;;; Copyright © 2019, 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;; Copyright © 2019 Jelle Licht <jlicht@fsfe.org>
 ;;; Copyright © 2019 Jonathan Frederickson <jonathan@terracrypt.net>
 ;;; Copyright © 2019, 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -5229,6 +5229,10 @@ (define-public libsecret
 and other secrets.  It communicates with the \"Secret Service\" using DBus.")
     (license license:lgpl2.1+)))
 
+(define-public docker-credential-secretservice
+  (docker-credential-helpers "secretservice"
+                             #:inputs (list libsecret)))
+
 (define-public five-or-more
   (package
     (name "five-or-more")

base-commit: 69951a61a1d8f1f2135ea2dc836738be282b97bc
-- 
2.41.0





^ permalink raw reply related	[relevance 56%]

* [bug#69042] [PATCH v2 06/30] gnu: go-golang-org-x-sys: Move to golang-build.
  @ 2024-02-12 18:48 42% ` Sharlatan Hellseher
  0 siblings, 0 replies; 149+ results
From: Sharlatan Hellseher @ 2024-02-12 18:48 UTC (permalink / raw)
  To: 69042
  Cc: Sharlatan Hellseher, Katherine Cox-Buday, Leo Famulari,
	Sharlatan Hellseher, Tobias Geerinckx-Rice, Wilko Meyer

* gnu/packages/golang.scm (go-golang-org-x-sys): Move
from here ...
* gnu/packages/golang-build.scm: ... to here.

* gnu/packages/curl.scm: Add (gnu packages golang-build) module.
* gnu/packages/databases.scm: As above.
* gnu/packages/docker.scm: As above.
* gnu/packages/golang-build.scm: As above.
* gnu/packages/golang.scm: As above.
* gnu/packages/irc.scm: As above.
* gnu/packages/linux.scm: As above.
* gnu/packages/password-utils.scm: As above.
* gnu/packages/syncthing.scm: As above.
* gnu/packages/textutils.scm: As above.
* gnu/packages/vpn.scm: As above.
* gnu/packages/weather.scm: As above.
* gnu/packages/web.scm: As above.

Change-Id: I161e89cacb9aa87b4fbb643ecd9ad32cfe49c9d7
---
 gnu/packages/curl.scm           |  1 +
 gnu/packages/databases.scm      |  1 +
 gnu/packages/docker.scm         |  1 +
 gnu/packages/golang-build.scm   | 31 +++++++++++++++++++++++++++++++
 gnu/packages/golang.scm         | 31 -------------------------------
 gnu/packages/irc.scm            |  1 +
 gnu/packages/linux.scm          |  1 +
 gnu/packages/password-utils.scm |  1 +
 gnu/packages/syncthing.scm      |  1 +
 gnu/packages/textutils.scm      |  1 +
 gnu/packages/vpn.scm            |  1 +
 gnu/packages/weather.scm        |  3 ++-
 gnu/packages/web.scm            |  1 +
 13 files changed, 43 insertions(+), 32 deletions(-)

diff --git a/gnu/packages/curl.scm b/gnu/packages/curl.scm
index 0fb83a7a12..02a602a66d 100644
--- a/gnu/packages/curl.scm
+++ b/gnu/packages/curl.scm
@@ -49,6 +49,7 @@ (define-module (gnu packages curl)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages kerberos)
   #:use-module (gnu packages logging)
diff --git a/gnu/packages/databases.scm b/gnu/packages/databases.scm
index 903088ed4b..dc4a91f14d 100644
--- a/gnu/packages/databases.scm
+++ b/gnu/packages/databases.scm
@@ -107,6 +107,7 @@ (define-module (gnu packages databases)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages golang-web)
   #:use-module (gnu packages gperf)
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index fbe8edeef0..0fe1f2c1c7 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -42,6 +42,7 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages networking)
   #:use-module (gnu packages pkg-config)
diff --git a/gnu/packages/golang-build.scm b/gnu/packages/golang-build.scm
index 2601dec27a..eeab951f1e 100644
--- a/gnu/packages/golang-build.scm
+++ b/gnu/packages/golang-build.scm
@@ -101,6 +101,37 @@ (define-public go-golang-org-x-net-html
     (description
      "This package provides an HTML5-compliant tokenizer and parser.")))
 
+(define-public go-golang-org-x-sys
+  (let ((commit "ca59edaa5a761e1d0ea91d6c07b063f85ef24f78")
+        (revision "0"))
+    (package
+      (name "go-golang-org-x-sys")
+      (version (git-version "0.8.0" revision commit))
+      (source
+       (origin
+         (method git-fetch)
+         (uri (git-reference
+               (url "https://go.googlesource.com/sys")
+               (commit commit)))
+         (file-name (git-file-name name version))
+         (sha256
+          (base32 "1p81niiin8dwyrjl2xsc95136w3vdw4kmj0w3mlh0vh5v134s4xq"))))
+      (build-system go-build-system)
+      (arguments
+       (list
+        #:import-path "golang.org/x/sys"
+        ;; Source-only package
+        #:tests? #f
+        #:phases
+        #~(modify-phases %standard-phases
+            ;; Source-only package
+            (delete 'build))))
+      (home-page "https://go.googlesource.com/sys")
+      (synopsis "Go support for low-level system interaction")
+      (description "This package provides supplemental libraries offering Go
+support for low-level interaction with the operating system.")
+      (license license:bsd-3))))
+
 ;;;
 ;;; Avoid adding new packages to the end of this file. To reduce the chances
 ;;; of a merge conflict, place them above by existing packages with similar
diff --git a/gnu/packages/golang.scm b/gnu/packages/golang.scm
index 73e7077eac..373b57c5ad 100644
--- a/gnu/packages/golang.scm
+++ b/gnu/packages/golang.scm
@@ -3712,37 +3712,6 @@ (define-public go-golang-org-x-sync
       (home-page "https://go.googlesource.com/sync/")
       (license license:bsd-3))))
 
-(define-public go-golang-org-x-sys
-  (let ((commit "ca59edaa5a761e1d0ea91d6c07b063f85ef24f78")
-        (revision "0"))
-    (package
-      (name "go-golang-org-x-sys")
-      (version (git-version "0.8.0" revision commit))
-      (source (origin
-                (method git-fetch)
-                (uri (git-reference
-                      (url "https://go.googlesource.com/sys")
-                      (commit commit)))
-                (file-name (git-file-name name version))
-                (sha256
-                 (base32
-                  "1p81niiin8dwyrjl2xsc95136w3vdw4kmj0w3mlh0vh5v134s4xq"))))
-      (build-system go-build-system)
-      (arguments
-       (list
-        #:import-path "golang.org/x/sys"
-        ;; Source-only package
-        #:tests? #f
-        #:phases
-        #~(modify-phases %standard-phases
-            ;; Source-only package
-            (delete 'build))))
-      (synopsis "Go support for low-level system interaction")
-      (description "This package provides supplemental libraries offering Go
-support for low-level interaction with the operating system.")
-      (home-page "https://go.googlesource.com/sys")
-      (license license:bsd-3))))
-
 (define-public go-golang-org-x-text
   (package
     (name "go-golang-org-x-text")
diff --git a/gnu/packages/irc.scm b/gnu/packages/irc.scm
index 3200ccc135..c211fa6595 100644
--- a/gnu/packages/irc.scm
+++ b/gnu/packages/irc.scm
@@ -67,6 +67,7 @@ (define-module (gnu packages irc)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages guile)
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index b8b119e474..d798c44a8f 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -134,6 +134,7 @@ (define-module (gnu packages linux)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages gperf)
   #:use-module (gnu packages graphviz)
   #:use-module (gnu packages gstreamer)
diff --git a/gnu/packages/password-utils.scm b/gnu/packages/password-utils.scm
index 6dc257dc0e..3a2bb410f2 100644
--- a/gnu/packages/password-utils.scm
+++ b/gnu/packages/password-utils.scm
@@ -91,6 +91,7 @@ (define-module (gnu packages password-utils)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-crypto)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages guile)
diff --git a/gnu/packages/syncthing.scm b/gnu/packages/syncthing.scm
index c0270b87e5..dbca1e5e90 100644
--- a/gnu/packages/syncthing.scm
+++ b/gnu/packages/syncthing.scm
@@ -38,6 +38,7 @@ (define-module (gnu packages syncthing)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-compression)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages linux)
diff --git a/gnu/packages/textutils.scm b/gnu/packages/textutils.scm
index be5cb15cb8..25de916fcb 100644
--- a/gnu/packages/textutils.scm
+++ b/gnu/packages/textutils.scm
@@ -67,6 +67,7 @@ (define-module (gnu packages textutils)
   #:use-module (gnu packages gcc)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages golang-crypto)
   #:use-module (gnu packages java)
diff --git a/gnu/packages/vpn.scm b/gnu/packages/vpn.scm
index 0070eaab6f..7823ef19eb 100644
--- a/gnu/packages/vpn.scm
+++ b/gnu/packages/vpn.scm
@@ -71,6 +71,7 @@ (define-module (gnu packages vpn)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages libevent)
   #:use-module (gnu packages linux)
diff --git a/gnu/packages/weather.scm b/gnu/packages/weather.scm
index 6ba656017f..5a58b97a30 100644
--- a/gnu/packages/weather.scm
+++ b/gnu/packages/weather.scm
@@ -22,7 +22,8 @@ (define-module (gnu packages weather)
   #:use-module (guix git-download)
   #:use-module (guix packages)
   #:use-module (gnu packages)
-  #:use-module (gnu packages golang))
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build))
 
 (define-public wego
   (package
diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm
index a1039b9e0c..0c67e7d6e4 100644
--- a/gnu/packages/web.scm
+++ b/gnu/packages/web.scm
@@ -143,6 +143,7 @@ (define-module (gnu packages web)
   #:use-module (gnu packages gnunet)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-web)
   #:use-module (gnu packages gperf)
   #:use-module (gnu packages graphviz)
-- 
2.41.0





^ permalink raw reply related	[relevance 42%]

* [bug#69042] [PATCH 06/30] gnu: go-golang-org-x-sys: Move to (gnu packages golang-build).
  @ 2024-02-11 10:52 42% ` Sharlatan Hellseher
  0 siblings, 0 replies; 149+ results
From: Sharlatan Hellseher @ 2024-02-11 10:52 UTC (permalink / raw)
  To: 69042
  Cc: Sharlatan Hellseher, Katherine Cox-Buday, Leo Famulari,
	Sharlatan Hellseher, Tobias Geerinckx-Rice, Wilko Meyer

* gnu/packages/golang.scm (go-golang-org-x-sys): Move
from here ...
* gnu/packages/golang-build.scm: ... to here.

* gnu/packages/curl.scm: Add (gnu packages golang-build) module.
* gnu/packages/databases.scm: As above.
* gnu/packages/docker.scm: As above.
* gnu/packages/golang-build.scm: As above.
* gnu/packages/golang.scm: As above.
* gnu/packages/irc.scm: As above.
* gnu/packages/linux.scm: As above.
* gnu/packages/password-utils.scm: As above.
* gnu/packages/syncthing.scm: As above.
* gnu/packages/textutils.scm: As above.
* gnu/packages/vpn.scm: As above.
* gnu/packages/weather.scm: As above.
* gnu/packages/web.scm: As above.

Change-Id: I161e89cacb9aa87b4fbb643ecd9ad32cfe49c9d7
---
 gnu/packages/curl.scm           |  1 +
 gnu/packages/databases.scm      |  1 +
 gnu/packages/docker.scm         |  1 +
 gnu/packages/golang-build.scm   | 31 +++++++++++++++++++++++++++++++
 gnu/packages/golang.scm         | 31 -------------------------------
 gnu/packages/irc.scm            |  1 +
 gnu/packages/linux.scm          |  1 +
 gnu/packages/password-utils.scm |  1 +
 gnu/packages/syncthing.scm      |  1 +
 gnu/packages/textutils.scm      |  1 +
 gnu/packages/vpn.scm            |  1 +
 gnu/packages/weather.scm        |  3 ++-
 gnu/packages/web.scm            |  1 +
 13 files changed, 43 insertions(+), 32 deletions(-)

diff --git a/gnu/packages/curl.scm b/gnu/packages/curl.scm
index 0fb83a7a12..02a602a66d 100644
--- a/gnu/packages/curl.scm
+++ b/gnu/packages/curl.scm
@@ -49,6 +49,7 @@ (define-module (gnu packages curl)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages kerberos)
   #:use-module (gnu packages logging)
diff --git a/gnu/packages/databases.scm b/gnu/packages/databases.scm
index 903088ed4b..dc4a91f14d 100644
--- a/gnu/packages/databases.scm
+++ b/gnu/packages/databases.scm
@@ -107,6 +107,7 @@ (define-module (gnu packages databases)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages golang-web)
   #:use-module (gnu packages gperf)
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index fbe8edeef0..0fe1f2c1c7 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -42,6 +42,7 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages networking)
   #:use-module (gnu packages pkg-config)
diff --git a/gnu/packages/golang-build.scm b/gnu/packages/golang-build.scm
index 2601dec27a..eeab951f1e 100644
--- a/gnu/packages/golang-build.scm
+++ b/gnu/packages/golang-build.scm
@@ -101,6 +101,37 @@ (define-public go-golang-org-x-net-html
     (description
      "This package provides an HTML5-compliant tokenizer and parser.")))
 
+(define-public go-golang-org-x-sys
+  (let ((commit "ca59edaa5a761e1d0ea91d6c07b063f85ef24f78")
+        (revision "0"))
+    (package
+      (name "go-golang-org-x-sys")
+      (version (git-version "0.8.0" revision commit))
+      (source
+       (origin
+         (method git-fetch)
+         (uri (git-reference
+               (url "https://go.googlesource.com/sys")
+               (commit commit)))
+         (file-name (git-file-name name version))
+         (sha256
+          (base32 "1p81niiin8dwyrjl2xsc95136w3vdw4kmj0w3mlh0vh5v134s4xq"))))
+      (build-system go-build-system)
+      (arguments
+       (list
+        #:import-path "golang.org/x/sys"
+        ;; Source-only package
+        #:tests? #f
+        #:phases
+        #~(modify-phases %standard-phases
+            ;; Source-only package
+            (delete 'build))))
+      (home-page "https://go.googlesource.com/sys")
+      (synopsis "Go support for low-level system interaction")
+      (description "This package provides supplemental libraries offering Go
+support for low-level interaction with the operating system.")
+      (license license:bsd-3))))
+
 ;;;
 ;;; Avoid adding new packages to the end of this file. To reduce the chances
 ;;; of a merge conflict, place them above by existing packages with similar
diff --git a/gnu/packages/golang.scm b/gnu/packages/golang.scm
index 73e7077eac..373b57c5ad 100644
--- a/gnu/packages/golang.scm
+++ b/gnu/packages/golang.scm
@@ -3712,37 +3712,6 @@ (define-public go-golang-org-x-sync
       (home-page "https://go.googlesource.com/sync/")
       (license license:bsd-3))))
 
-(define-public go-golang-org-x-sys
-  (let ((commit "ca59edaa5a761e1d0ea91d6c07b063f85ef24f78")
-        (revision "0"))
-    (package
-      (name "go-golang-org-x-sys")
-      (version (git-version "0.8.0" revision commit))
-      (source (origin
-                (method git-fetch)
-                (uri (git-reference
-                      (url "https://go.googlesource.com/sys")
-                      (commit commit)))
-                (file-name (git-file-name name version))
-                (sha256
-                 (base32
-                  "1p81niiin8dwyrjl2xsc95136w3vdw4kmj0w3mlh0vh5v134s4xq"))))
-      (build-system go-build-system)
-      (arguments
-       (list
-        #:import-path "golang.org/x/sys"
-        ;; Source-only package
-        #:tests? #f
-        #:phases
-        #~(modify-phases %standard-phases
-            ;; Source-only package
-            (delete 'build))))
-      (synopsis "Go support for low-level system interaction")
-      (description "This package provides supplemental libraries offering Go
-support for low-level interaction with the operating system.")
-      (home-page "https://go.googlesource.com/sys")
-      (license license:bsd-3))))
-
 (define-public go-golang-org-x-text
   (package
     (name "go-golang-org-x-text")
diff --git a/gnu/packages/irc.scm b/gnu/packages/irc.scm
index 3200ccc135..c211fa6595 100644
--- a/gnu/packages/irc.scm
+++ b/gnu/packages/irc.scm
@@ -67,6 +67,7 @@ (define-module (gnu packages irc)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages guile)
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index b8b119e474..d798c44a8f 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -134,6 +134,7 @@ (define-module (gnu packages linux)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages gperf)
   #:use-module (gnu packages graphviz)
   #:use-module (gnu packages gstreamer)
diff --git a/gnu/packages/password-utils.scm b/gnu/packages/password-utils.scm
index 6dc257dc0e..3a2bb410f2 100644
--- a/gnu/packages/password-utils.scm
+++ b/gnu/packages/password-utils.scm
@@ -91,6 +91,7 @@ (define-module (gnu packages password-utils)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-crypto)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages guile)
diff --git a/gnu/packages/syncthing.scm b/gnu/packages/syncthing.scm
index c0270b87e5..dbca1e5e90 100644
--- a/gnu/packages/syncthing.scm
+++ b/gnu/packages/syncthing.scm
@@ -38,6 +38,7 @@ (define-module (gnu packages syncthing)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-compression)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages linux)
diff --git a/gnu/packages/textutils.scm b/gnu/packages/textutils.scm
index be5cb15cb8..25de916fcb 100644
--- a/gnu/packages/textutils.scm
+++ b/gnu/packages/textutils.scm
@@ -67,6 +67,7 @@ (define-module (gnu packages textutils)
   #:use-module (gnu packages gcc)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages golang-crypto)
   #:use-module (gnu packages java)
diff --git a/gnu/packages/vpn.scm b/gnu/packages/vpn.scm
index 02c1ee1043..5df50280c3 100644
--- a/gnu/packages/vpn.scm
+++ b/gnu/packages/vpn.scm
@@ -70,6 +70,7 @@ (define-module (gnu packages vpn)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages libevent)
   #:use-module (gnu packages linux)
diff --git a/gnu/packages/weather.scm b/gnu/packages/weather.scm
index 6ba656017f..5a58b97a30 100644
--- a/gnu/packages/weather.scm
+++ b/gnu/packages/weather.scm
@@ -22,7 +22,8 @@ (define-module (gnu packages weather)
   #:use-module (guix git-download)
   #:use-module (guix packages)
   #:use-module (gnu packages)
-  #:use-module (gnu packages golang))
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build))
 
 (define-public wego
   (package
diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm
index a1039b9e0c..0c67e7d6e4 100644
--- a/gnu/packages/web.scm
+++ b/gnu/packages/web.scm
@@ -143,6 +143,7 @@ (define-module (gnu packages web)
   #:use-module (gnu packages gnunet)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-build)
   #:use-module (gnu packages golang-web)
   #:use-module (gnu packages gperf)
   #:use-module (gnu packages graphviz)
-- 
2.41.0





^ permalink raw reply related	[relevance 42%]

* [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration.
    2023-12-03 21:56 70% ` [bug#67613] [PATCH] tests: Add oci-container-service-type unit tests Giacomo Leidi via Guix-patches via
@ 2024-01-11 20:39 50% ` Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 63%   ` [bug#67613] [PATCH v2 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
                     ` (3 more replies)
  2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2 siblings, 4 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-01-11 20:39 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration)
[extra-arguments]: New field;
(oci-sanitize-extra-arguments): sanitize it;
(oci-container-shepherd-service): use it;
* doc/guix.texi: document it.

Change-Id: I54c74ac2fe0f5ca65ca5a1d0d7f3fb55ff428063
---
 doc/guix.texi           | 13 ++++++++++---
 gnu/services/docker.scm | 42 ++++++++++++++++++++++++++++++++++-------
 2 files changed, 45 insertions(+), 10 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 395545bed7..ce239c603d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39844,7 +39844,8 @@ Set environment variables. This can be a list of pairs or strings, even mixed:
       "JAVA_HOME=/opt/java")
 @end lisp
 
-String are passed directly to the Docker CLI. You can refer to the
+Pair members can be strings, gexps or file-like objects.
+Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
 documentation for semantics.
 
@@ -39868,7 +39869,8 @@ list of pairs or strings, even mixed:
       "10443:443")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects.
+Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
 documentation for semantics.
 
@@ -39881,7 +39883,8 @@ list of pairs or strings, even mixed:
       "/gnu/store:/gnu/store")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects.
+Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
 documentation for semantics.
 
@@ -39896,6 +39899,10 @@ You can refer to the
 @url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
 documentation for semantics.
 
+@item @code{extra-arguments} (default: @code{()}) (type: list)
+A list of strings, gexps or file-like objects that will be directly
+passed to the @command{docker run} invokation.
+
 @end table
 
 @end deftp
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 4d32b96847..b4fd94d1fd 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -58,6 +58,9 @@ (define-module (gnu services docker)
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
+            oci-container-configuration-container-user
+            oci-container-configuration-workdir
+            oci-container-configuration-extra-arguments
             oci-container-service-type
             oci-container-shepherd-service))
 
@@ -297,6 +300,21 @@ (define (oci-sanitize-volumes value)
   ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
   (oci-sanitize-mixed-list "volumes" value ":"))
 
+(define (oci-sanitize-extra-arguments value)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (map
+   (lambda (el)
+     (if (valid? el)
+         el
+         (raise
+          (formatted-message
+           (G_ "extra arguments may only be strings, gexps or file-like objects
+but ~a was found") el))))
+   value))
+
 (define-maybe/no-serialization string)
 
 (define-configuration/no-serialization oci-container-configuration
@@ -322,7 +340,8 @@ (define-configuration/no-serialization oci-container-configuration
       \"JAVA_HOME=/opt/java\")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI.  You can refer to the
 @url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
 documentation for semantics."
    (sanitizer oci-sanitize-environment))
@@ -347,7 +366,8 @@ (define-configuration/no-serialization oci-container-configuration
       \"10443:443\")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI.  You can refer to the
 @url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
 documentation for semantics."
    (sanitizer oci-sanitize-ports))
@@ -361,7 +381,8 @@ (define-configuration/no-serialization oci-container-configuration
       \"/gnu/store:/gnu/store\")
 @end lisp
 
-String are passed directly to the Docker CLI.  You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI.  You can refer to the
 @url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
 documentation for semantics."
    (sanitizer oci-sanitize-volumes))
@@ -375,7 +396,12 @@ (define-configuration/no-serialization oci-container-configuration
    "Set the current working for the spawned Shepherd service.
 You can refer to the
 @url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
-documentation for semantics."))
+documentation for semantics.")
+  (extra-arguments
+   (list '())
+   "A list of strings, gexps or file-like objects that will be directly passed
+to the @command{docker run} invokation."
+   (sanitizer oci-sanitize-extra-arguments)))
 
 (define oci-container-configuration->options
   (lambda (config)
@@ -428,7 +454,9 @@ (define (guess-name name image)
          (provision (oci-container-configuration-provision config))
          (image (oci-container-configuration-image config))
          (options (oci-container-configuration->options config))
-         (name (guess-name provision image)))
+         (name (guess-name provision image))
+         (extra-arguments
+          (oci-container-configuration-extra-arguments config)))
 
     (shepherd-service (provision `(,(string->symbol name)))
                       (requirement '(dockerd user-processes))
@@ -441,7 +469,7 @@ (define (guess-name name image)
                           ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
                           (list #$docker-command "run" "--rm"
                                 "--name" #$name
-                                #$@options #$image #$@command)
+                                #$@options #$@extra-arguments #$image #$@command)
                           #:user #$user
                           #:group #$group))
                       (stop
@@ -482,5 +510,5 @@ (define oci-container-service-type
                 (extend append)
                 (compose concatenate)
                 (description
-                 "This service allows the management of Docker and OCI
+                 "This service allows the management of OCI
 containers as Shepherd services.")))

base-commit: 637b72e2b83a6332849218ef1f193124fa8239eb
-- 
2.41.0





^ permalink raw reply related	[relevance 50%]

* [bug#67613] [PATCH v2 4/5] gnu: docker: Allow passing tarballs for images in oci-container-configuration.
  2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 63%   ` [bug#67613] [PATCH v2 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 70%   ` [bug#67613] [PATCH v2 3/5] gnu: docker: Allow setting Shepherd dependencies " Giacomo Leidi via Guix-patches via
@ 2024-01-11 20:39 39%   ` Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 60%   ` [bug#67613] [PATCH v2 5/5] gnu: Add tests and documentation for oci-container-service-type Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-01-11 20:39 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

This commit allows for loading an OCI image tarball before running an
OCI backed Shepherd service. It does so by adding a one shot Shepherd
service to the dependencies of the OCI backed service that at boot runs
docker load on the tarball.

* gnu/services/docker.scm (oci-image): New record;
(lower-oci-image): new variable, lower it;
(string-or-oci-image?): sanitize it;
(oci-container-configuration)[image]: allow also for oci-image records;
(oci-container-shepherd-service): use it;
(%oci-image-loader): new variable.

Change-Id: Ie504f479ea0d47f74b0ec5df9085673ffd3f639d
---
 gnu/services/docker.scm | 244 ++++++++++++++++++++++++++++++++++++----
 1 file changed, 219 insertions(+), 25 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 43ffb71901..58a725737c 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -23,11 +23,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services docker)
+  #:use-module (gnu image)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (gnu system image)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages admin)               ;shadow
@@ -37,7 +40,11 @@ (define-module (gnu services docker)
   #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
+  #:use-module (guix monads)
   #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module ((guix scripts pack) #:prefix pack:)
+  #:use-module (guix store)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -45,6 +52,16 @@ (define-module (gnu services docker)
   #:export (docker-configuration
             docker-service-type
             singularity-service-type
+            oci-image
+            oci-image?
+            oci-image-fields
+            oci-image-repository
+            oci-image-tag
+            oci-image-value
+            oci-image-pack-options
+            oci-image-target
+            oci-image-system
+            oci-image-grafts?
             oci-container-configuration
             oci-container-configuration?
             oci-container-configuration-fields
@@ -52,9 +69,11 @@ (define-module (gnu services docker)
             oci-container-configuration-group
             oci-container-configuration-command
             oci-container-configuration-entrypoint
+            oci-container-configuration-host-environment
             oci-container-configuration-environment
             oci-container-configuration-image
             oci-container-configuration-provision
+            oci-container-configuration-requirement
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
@@ -62,7 +81,8 @@ (define-module (gnu services docker)
             oci-container-configuration-workdir
             oci-container-configuration-extra-arguments
             oci-container-service-type
-            oci-container-shepherd-service))
+            oci-container-shepherd-service
+            %oci-container-accounts))
 
 (define-maybe file-like)
 
@@ -320,11 +340,68 @@ (define (valid? member)
 but ~a was found") el))))
    value))
 
+(define (oci-image-reference image)
+  (if (string? image)
+      image
+      (string-append (oci-image-repository image)
+                     ":" (oci-image-tag image))))
+
+(define (oci-lowerable-image? image)
+  (or (manifest? image)
+      (operating-system? image)
+      (gexp? image)
+      (file-like? image)))
+
+(define (string-or-oci-image? image)
+  (or (string? image)
+      (oci-image? image)))
+
 (define list-of-symbols?
   (list-of symbol?))
 
 (define-maybe/no-serialization string)
 
+(define-configuration/no-serialization oci-image
+  (repository
+   (string)
+   "A string like @code{myregistry.local:5000/testing/test-image} that names
+the OCI image.")
+  (tag
+   (string "latest")
+   "A string representing the OCI image tag. Defaults to @code{latest}.")
+  (value
+   (oci-lowerable-image)
+   "A @code{manifest} or @code{operating-system} record that will be lowered
+into an OCI compatible tarball.  Otherwise this field's value can be a gexp
+or a file-like object that evaluates to an OCI compatible tarball.")
+  (pack-options
+   (list '())
+   "An optional set of keyword arguments that will be passed to the
+@code{docker-image} procedure from @code{guix scripts pack}.  They can be used
+to replicate @command{guix pack} behavior:
+
+@lisp
+(oci-image
+  (repository \"guile\")
+  (tag \"3\")
+  (manifest (specifications->manifest '(\"guile\")))
+  (pack-options
+    '(#:symlinks ((\"/bin/guile\" -> \"bin/guile\"))
+      #:max-layers 2)))
+@end lisp
+
+If the @code{value} field is an @code{operating-system} record, this field's
+value will be ignored.")
+  (system
+   (maybe-string)
+   "Attempt to build for a given system, e.g. \"i686-linux\"")
+  (target
+   (maybe-string)
+   "Attempt to cross-build for a given triple, e.g. \"aarch64-linux-gnu\"")
+  (grafts?
+   (boolean #f)
+   "Whether to allow grafting or not in the pack build."))
+
 (define-configuration/no-serialization oci-container-configuration
   (user
    (string "oci-container")
@@ -372,8 +449,9 @@ (define-configuration/no-serialization oci-container-configuration
 documentation for semantics."
    (sanitizer oci-sanitize-environment))
   (image
-   (string)
-   "The image used to build the container.  Images are resolved by the Docker
+   (string-or-oci-image)
+   "The image used to build the container.  It can be a string or an
+@code{oci-image} record.  Strings are resolved by the Docker
 Engine, and follow the usual format
 @code{myregistry.local:5000/testing/test-image:tag}.")
   (provision
@@ -470,14 +548,122 @@ (define oci-container-configuration->options
                            (list "-v" spec))
                          (oci-container-configuration-volumes config))))))))
 
+(define* (get-keyword-value args keyword #:key (default #f))
+  (let ((kv (memq keyword args)))
+    (if (and kv (>= (length kv) 2))
+        (cadr kv)
+        default)))
+
+(define (lower-operating-system os target system)
+  (mlet* %store-monad
+      ((tarball
+        (lower-object
+         (system-image (os->image os #:type docker-image-type))
+         system
+         #:target target)))
+    (return tarball)))
+
+(define (lower-manifest name image target system)
+  (define value (oci-image-value image))
+  (define options (oci-image-pack-options image))
+  (define image-reference
+    (oci-image-reference image))
+  (define image-tag
+    (let* ((extra-options
+            (get-keyword-value options #:extra-options))
+           (image-tag-option
+            (and extra-options
+                 (get-keyword-value extra-options #:image-tag))))
+      (if image-tag-option
+          '()
+          `(#:extra-options (#:image-tag ,image-reference)))))
+
+  (mlet* %store-monad
+      ((_ (set-grafting
+           (oci-image-grafts? image)))
+       (guile (set-guile-for-build (default-guile)))
+       (profile
+        (profile-derivation value
+                            #:target target
+                            #:system system
+                            #:hooks '()
+                            #:locales? #f))
+       (tarball (apply pack:docker-image
+                       `(,name ,profile
+                         ,@options
+                         ,@image-tag
+                         #:localstatedir? #t))))
+    (return tarball)))
+
+(define (lower-oci-image name image)
+  (define value (oci-image-value image))
+  (define image-target (oci-image-target image))
+  (define image-system (oci-image-system image))
+  (define target
+    (if (maybe-value-set? image-target)
+        image-target
+        (%current-target-system)))
+  (define system
+    (if (maybe-value-set? image-system)
+        image-system
+        (%current-system)))
+  (with-store store
+   (run-with-store store
+     (match value
+       ((? manifest? value)
+        (lower-manifest name image target system))
+       ((? operating-system? value)
+        (lower-operating-system value target system))
+       ((or (? gexp? value)
+            (? file-like? value))
+        value)
+       (_
+        (raise
+         (formatted-message
+          (G_ "oci-image value must contain only manifest,
+operating-system, gexp or file-like records but ~a was found")
+          value))))
+     #:target target
+     #:system system)))
+
+(define (%oci-image-loader name image tag)
+  (let ((docker (file-append docker-cli "/bin/docker"))
+        (tarball (lower-oci-image name image)))
+    (with-imported-modules '((guix build utils))
+      (program-file (format #f "~a-image-loader" name)
+       #~(begin
+           (use-modules (guix build utils)
+                        (ice-9 popen)
+                        (ice-9 rdelim))
+
+           (format #t "Loading image for ~a from ~a...~%" #$name #$tarball)
+           (define line
+             (read-line
+              (open-input-pipe
+               (string-append #$docker " load -i " #$tarball))))
+
+           (unless (or (eof-object? line)
+                       (string-null? line))
+             (format #t "~a~%" line)
+             (let ((repository&tag
+                    (string-drop line
+                                 (string-length
+                                   "Loaded image: "))))
+
+               (invoke #$docker "tag" repository&tag #$tag)
+               (format #t "Tagged ~a with ~a...~%" #$tarball #$tag))))))))
+
 (define (oci-container-shepherd-service config)
   (define (guess-name name image)
     (if (maybe-value-set? name)
         name
         (string-append "docker-"
-                       (basename (car (string-split image #\:))))))
+                       (basename
+                        (if (string? image)
+                            (first (string-split image #\:))
+                            (oci-image-repository image))))))
 
-  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+  (let* ((docker (file-append docker-cli "/bin/docker"))
          (user (oci-container-configuration-user config))
          (group (oci-container-configuration-group config))
          (host-environment
@@ -486,6 +672,7 @@ (define (guess-name name image)
          (provision (oci-container-configuration-provision config))
          (requirement (oci-container-configuration-requirement config))
          (image (oci-container-configuration-image config))
+         (image-reference (oci-image-reference image))
          (options (oci-container-configuration->options config))
          (name (guess-name provision image))
          (extra-arguments
@@ -496,30 +683,37 @@ (define (guess-name name image)
                       (respawn? #f)
                       (documentation
                        (string-append
-                        "Docker backed Shepherd service for image: " image))
+                        "Docker backed Shepherd service for "
+                        (if (oci-image? image) name image) "."))
                       (start
-                       #~(make-forkexec-constructor
-                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
-                          (list #$docker-command "run" "--rm"
-                                "--name" #$name
-                                #$@options #$@extra-arguments #$image #$@command)
-                          #:user #$user
-                          #:group #$group
-                          #:environment-variables
-                          (list #$@host-environment)))
+                       #~(lambda ()
+                          (when #$(oci-image? image)
+                            (invoke #$(%oci-image-loader
+                                       name image image-reference)))
+                          (fork+exec-command
+                           ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                           (list #$docker "run" "--rm" "--name" #$name
+                                 #$@options #$@extra-arguments
+                                 #$image-reference #$@command)
+                           #:user #$user
+                           #:group #$group
+                           #:environment-variables
+                           (list #$@host-environment))))
                       (stop
                        #~(lambda _
-                           (invoke #$docker-command "rm" "-f" #$name)))
+                           (invoke #$docker "rm" "-f" #$name)))
                       (actions
-                       (list
-                        (shepherd-action
-                         (name 'pull)
-                         (documentation
-                          (format #f "Pull ~a's image (~a)."
-                                  name image))
-                         (procedure
-                          #~(lambda _
-                              (invoke #$docker-command "pull" #$image)))))))))
+                       (if (oci-image? image)
+                           '()
+                           (list
+                            (shepherd-action
+                             (name 'pull)
+                             (documentation
+                              (format #f "Pull ~a's image (~a)."
+                                      name image))
+                             (procedure
+                              #~(lambda _
+                                  (invoke #$docker "pull" #$image))))))))))
 
 (define %oci-container-accounts
   (list (user-account
-- 
2.41.0





^ permalink raw reply related	[relevance 39%]

* [bug#67613] [PATCH v2 2/5] gnu: docker: Allow setting host environment variables in oci-container-configuration.
  2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
@ 2024-01-11 20:39 63%   ` Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 70%   ` [bug#67613] [PATCH v2 3/5] gnu: docker: Allow setting Shepherd dependencies " Giacomo Leidi via Guix-patches via
                     ` (2 subsequent siblings)
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-01-11 20:39 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration)
[host-environment]: New field;
(oci-sanitize-host-environment): sanitize it;
(oci-container-shepherd-service): use it.

Change-Id: I4d54d37736cf09f042a71cb0b6e673abc0948d9c
---
 gnu/services/docker.scm | 31 +++++++++++++++++++++++++++++--
 1 file changed, 29 insertions(+), 2 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index b4fd94d1fd..7706b4a29a 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,7 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
-;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
+;;; Copyright © 2023, 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -285,6 +285,11 @@ (define (oci-sanitize-mixed-list name value delimiter)
               name el)))))
    value))
 
+(define (oci-sanitize-host-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "host-environment" value "="))
+
 (define (oci-sanitize-environment value)
   ;; Expected spec format:
   ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
@@ -330,6 +335,24 @@ (define-configuration/no-serialization oci-container-configuration
   (entrypoint
    (maybe-string)
    "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+  (host-environment
+   (list '())
+   "Set environment variables in the host environment where @command{docker run}
+is invoked.  This is especially useful to pass secrets from the host to the
+container without having them on the @command{docker run}'s command line: by
+setting the @{MYSQL_PASSWORD} on the host and by passing
+@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
+possible to securely set values in the container environment.  This field's
+value can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to @code{make-forkexec-constructor}."
+   (sanitizer oci-sanitize-host-environment))
   (environment
    (list '())
    "Set environment variables.  This can be a list of pairs or strings, even
@@ -450,6 +473,8 @@ (define (guess-name name image)
   (let* ((docker-command (file-append docker-cli "/bin/docker"))
          (user (oci-container-configuration-user config))
          (group (oci-container-configuration-group config))
+         (host-environment
+          (oci-container-configuration-host-environment config))
          (command (oci-container-configuration-command config))
          (provision (oci-container-configuration-provision config))
          (image (oci-container-configuration-image config))
@@ -471,7 +496,9 @@ (define (guess-name name image)
                                 "--name" #$name
                                 #$@options #$@extra-arguments #$image #$@command)
                           #:user #$user
-                          #:group #$group))
+                          #:group #$group
+                          #:environment-variables
+                          (list #$@host-environment)))
                       (stop
                        #~(lambda _
                            (invoke #$docker-command "rm" "-f" #$name)))
-- 
2.41.0





^ permalink raw reply related	[relevance 63%]

* [bug#67613] [PATCH v2 5/5] gnu: Add tests and documentation for oci-container-service-type.
  2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
                     ` (2 preceding siblings ...)
  2024-01-11 20:39 39%   ` [bug#67613] [PATCH v2 4/5] gnu: docker: Allow passing tarballs for images " Giacomo Leidi via Guix-patches via
@ 2024-01-11 20:39 60%   ` Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-01-11 20:39 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* doc/guix.texi: Add documentation for the oci-image record and update
the oci-container-configuration documentation.
* gnu/tests/docker.scm (run-oci-container-test): New variable;
(%test-oci-container): new variable.

Change-Id: Id8f4f5454aa3b88d8aa3fa47de823e921acece05
---
 doc/guix.texi           |  91 +++++++++++++++++++++++++++-
 gnu/services/docker.scm |   6 +-
 gnu/tests/docker.scm    | 131 +++++++++++++++++++++++++++++++++++++++-
 3 files changed, 221 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index ce239c603d..1916a00412 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39790,6 +39790,17 @@ processes as Shepherd Services.
 @lisp
 (service oci-container-service-type
          (list
+          (oci-container-configuration
+           (image
+            (oci-image
+             (repository "guile")
+             (tag "3")
+             (value (specifications->manifest '("guile")))
+             (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
+                             #:max-layers 2))))
+           (entrypoint "/bin/guile")
+           (command
+            '("-c" "(display \"hello!\n\")")))
           (oci-container-configuration
            (image "prom/prometheus")
            (network "host")
@@ -39836,6 +39847,23 @@ Overwrite the default command (@code{CMD}) of the image.
 @item @code{entrypoint} (default: @code{""}) (type: string)
 Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
 
+@item @code{host-environment} (default: @code{()}) (type: list)
+Set environment variables in the host environment where @command{docker
+run} is invoked.  This is especially useful to pass secrets from the
+host to the container without having them on the @command{docker run}'s
+command line: by setting the @code{MYSQL_PASSWORD} on the host and by passing
+@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
+possible to securely set values in the container environment.  This field's
+value can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to @code{make-forkexec-constructor}.
+
 @item @code{environment} (default: @code{()}) (type: list)
 Set environment variables. This can be a list of pairs or strings, even mixed:
 
@@ -39849,14 +39877,19 @@ Strings are passed directly to the Docker CLI.  You can refer to the
 @uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
 documentation for semantics.
 
-@item @code{image} (type: string)
-The image used to build the container.  Images are resolved by the
-Docker Engine, and follow the usual format
+@item @code{image} (type: string-or-oci-image)
+The image used to build the container.  It can be a string or an
+@code{oci-image} record.  Strings are resolved by the Docker Engine, and
+follow the usual format
 @code{myregistry.local:5000/testing/test-image:tag}.
 
 @item @code{provision} (default: @code{""}) (type: string)
 Set the name of the provisioned Shepherd service.
 
+@item @code{requirement} (default: @code{()}) (type: list-of-symbols)
+Set additional Shepherd services dependencies to the provisioned
+Shepherd service.
+
 @item @code{network} (default: @code{""}) (type: string)
 Set a Docker network for the spawned container.
 
@@ -39908,6 +39941,58 @@ passed to the @command{docker run} invokation.
 @end deftp
 
 
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} oci-image
+Available @code{oci-image} fields are:
+
+@table @asis
+@item @code{repository} (type: string)
+A string like @code{myregistry.local:5000/testing/test-image} that names
+the OCI image.
+
+@item @code{tag} (default: @code{"latest"}) (type: string)
+A string representing the OCI image tag.  Defaults to @code{latest}.
+
+@item @code{value} (type: oci-lowerable-image)
+A @code{manifest} or @code{operating-system} record that will be lowered
+into an OCI compatible tarball.  Otherwise this field's value can be a
+gexp or a file-like object that evaluates to an OCI compatible tarball.
+
+@item @code{pack-options} (default: @code{()}) (type: list)
+An optional set of keyword arguments that will be passed to the
+@code{docker-image} procedure from @code{guix scripts pack}.  They can
+be used to replicate @command{guix pack} behavior:
+
+@lisp
+(oci-image
+  (repository "guile")
+  (tag "3")
+  (value
+    (specifications->manifest '("guile")))
+  (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
+                  #:max-layers 2)))
+@end lisp
+
+If the @code{value} field is an @code{operating-system} record, this field's
+value will be ignored.
+
+@item @code{system} (default: @code{""}) (type: string)
+Attempt to build for a given system, e.g. "i686-linux"
+
+@item @code{target} (default: @code{""}) (type: string)
+Attempt to cross-build for a given triple, e.g. "aarch64-linux-gnu"
+
+@item @code{grafts?} (default: @code{#f}) (type: boolean)
+Whether to allow grafting or not in the pack build.
+
+@end table
+
+@end deftp
+
+
 @c %end of fragment
 
 @cindex Audit
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 58a725737c..7aff8dcc5f 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -420,7 +420,7 @@ (define-configuration/no-serialization oci-container-configuration
    "Set environment variables in the host environment where @command{docker run}
 is invoked.  This is especially useful to pass secrets from the host to the
 container without having them on the @command{docker run}'s command line: by
-setting the @{MYSQL_PASSWORD} on the host and by passing
+setting the @code{MYSQL_PASSWORD} on the host and by passing
 @code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
 possible to securely set values in the container environment.  This field's
 value can be a list of pairs or strings, even mixed:
@@ -435,8 +435,8 @@ (define-configuration/no-serialization oci-container-configuration
    (sanitizer oci-sanitize-host-environment))
   (environment
    (list '())
-   "Set environment variables.  This can be a list of pairs or strings, even
-mixed:
+   "Set environment variables inside the container.  This can be a list of pairs
+or strings, even mixed:
 
 @lisp
 (list '(\"LANGUAGE\" . \"eo:ca:eu\")
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 9e9d2e2d07..d550136b4a 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (gnu tests docker)
   #:use-module (gnu services networking)
   #:use-module (gnu services docker)
   #:use-module (gnu services desktop)
+  #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (glibc))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages docker)
@@ -43,7 +45,8 @@ (define-module (gnu tests docker)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (%test-docker
-            %test-docker-system))
+            %test-docker-system
+            %test-oci-container))
 
 (define %docker-os
   (simple-operating-system
@@ -316,3 +319,129 @@ (define %test-docker-system
                                    (locale-libcs (list glibc)))
                                  #:type docker-image-type)))
                  run-docker-system-test)))))
+
+\f
+(define %oci-os
+  (simple-operating-system
+   (service dhcp-client-service-type)
+   (service dbus-root-service-type)
+   (service polkit-service-type)
+   (service elogind-service-type)
+   (service docker-service-type)
+   (extra-special-file "/shared.txt"
+                       (plain-file "shared.txt" "hello"))
+   (service oci-container-service-type
+            (list
+             (oci-container-configuration
+              (image
+               (oci-image
+                (repository "guile")
+                (value
+                 (specifications->manifest '("guile")))
+                (pack-options
+                 '(#:symlinks (("/bin" -> "bin"))))))
+              (entrypoint
+               "/bin/guile")
+              (command
+               '("-c" "(let l ((c 300))(display c)(sleep 1)(when(positive? c)(l (- c 1))))"))
+              (host-environment
+               '(("VARIABLE" . "value")))
+              (volumes
+               '(("/shared.txt" . "/shared.txt:ro")))
+              (extra-arguments
+               '("--env" "VARIABLE")))))))
+
+(define (run-oci-container-test)
+  "Run IMAGE as an OCI backed Shepherd service, inside OS."
+
+  (define os
+    (marionette-operating-system
+     (operating-system-with-gc-roots
+      %oci-os
+      (list))
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (volatile? #f)
+     (memory-size 1024)
+     (disk-image-size (* 3000 (expt 2 20)))
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            ;; Relax timeout to accommodate older systems and
+            ;; allow for pulling the image.
+            (make-marionette (list #$vm) #:timeout 60))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "oci-container")
+
+          (test-assert "dockerd running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'dockerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (sleep 10) ; let service start
+
+          (test-assert "docker-guile running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'docker-guile)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-equal "passing host environment variables and volumes"
+            '("value" "hello")
+            (marionette-eval
+             `(begin
+                (use-modules (ice-9 popen)
+                             (ice-9 rdelim))
+
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (let ((line (read-line port)))
+                                     (if (eof-object? line)
+                                         ""
+                                         line)))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((response1 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "exec" "docker-guile"
+                                   "/bin/guile" "-c" "(display (getenv \"VARIABLE\"))"))
+                       (response2 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "exec" "docker-guile"
+                                   "/bin/guile" "-c" "(begin (use-modules (ice-9 popen) (ice-9 rdelim))
+(display (call-with-input-file \"/shared.txt\" read-line)))")))
+                  (list response1 response2)))
+             marionette))
+
+          (test-end))))
+
+  (gexp->derivation "oci-container-test" test))
+
+(define %test-oci-container
+  (system-test
+   (name "oci-container")
+   (description "Test OCI backed Shepherd service.")
+   (value (run-oci-container-test))))
-- 
2.41.0





^ permalink raw reply related	[relevance 60%]

* [bug#67613] [PATCH v2 3/5] gnu: docker: Allow setting Shepherd dependencies in oci-container-configuration.
  2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 63%   ` [bug#67613] [PATCH v2 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
@ 2024-01-11 20:39 70%   ` Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 39%   ` [bug#67613] [PATCH v2 4/5] gnu: docker: Allow passing tarballs for images " Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 60%   ` [bug#67613] [PATCH v2 5/5] gnu: Add tests and documentation for oci-container-service-type Giacomo Leidi via Guix-patches via
  3 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2024-01-11 20:39 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration)
[requirement]: New field;
(list-of-symbols): sanitize it;
(oci-container-shepherd-service): use it.

Change-Id: Ic0ba336a2257d6ef7c658cfc6cd630116661f581
---
 gnu/services/docker.scm | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 7706b4a29a..43ffb71901 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -320,6 +320,9 @@ (define (valid? member)
 but ~a was found") el))))
    value))
 
+(define list-of-symbols?
+  (list-of symbol?))
+
 (define-maybe/no-serialization string)
 
 (define-configuration/no-serialization oci-container-configuration
@@ -376,6 +379,10 @@ (define-configuration/no-serialization oci-container-configuration
   (provision
    (maybe-string)
    "Set the name of the provisioned Shepherd service.")
+  (requirement
+   (list-of-symbols '())
+   "Set additional Shepherd services dependencies to the provisioned Shepherd
+service.")
   (network
    (maybe-string)
    "Set a Docker network for the spawned container.")
@@ -477,6 +484,7 @@ (define (guess-name name image)
           (oci-container-configuration-host-environment config))
          (command (oci-container-configuration-command config))
          (provision (oci-container-configuration-provision config))
+         (requirement (oci-container-configuration-requirement config))
          (image (oci-container-configuration-image config))
          (options (oci-container-configuration->options config))
          (name (guess-name provision image))
@@ -484,7 +492,7 @@ (define (guess-name name image)
           (oci-container-configuration-extra-arguments config)))
 
     (shepherd-service (provision `(,(string->symbol name)))
-                      (requirement '(dockerd user-processes))
+                      (requirement `(dockerd user-processes ,@requirement))
                       (respawn? #f)
                       (documentation
                        (string-append
-- 
2.41.0





^ permalink raw reply related	[relevance 70%]

* [bug#68240] [PATCH] gnu: docker: Update to 20.10.27.
@ 2024-01-04  6:51 69% Christian Miller via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Christian Miller via Guix-patches via @ 2024-01-04  6:51 UTC (permalink / raw)
  To: 68240; +Cc: Christian Miller

Fixes <https://issues.guix.gnu.org/68053>.

* gnu/packages/docker.scm (%docker-version): Update to 20.10.27.
(docker-libnetwork): Update to 20.10-3.3797618.

Change-Id: Ie4cc54f62c89f3a6c83969d1e7e425189c370482
---
 gnu/packages/docker.scm | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index a69bbac168..e74115c4c5 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -54,7 +54,7 @@ (define-module (gnu packages docker)
 
 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "20.10.25")
+(define %docker-version "20.10.27")
 
 (define-public python-docker
   (package
@@ -264,9 +264,9 @@ (define docker-libnetwork
   ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
   ;; source file.  NOTE - It is important that this version is kept in sync
   ;; with the version of Docker being used.
-  (let ((commit "3f0048413d95802b9c6c836eba06bfc54f9dbd03")
+  (let ((commit "3797618f9a38372e8107d8c06f6ae199e1133ae8")
         (version (version-major+minor %docker-version))
-        (revision "2"))
+        (revision "3"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -279,7 +279,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "185i5ji7dwkv41zmb8s3d7i5gg72wivcj1l4bhr1lb3a1vy2hcxc"))
+                  "1km3p6ya9az0ax2zww8wb5vbifr1gj5n9l82i273m9f3z9f2mq2p"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(delete-file-recursively "vendor"))))
@@ -333,7 +333,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1q5vc6f5fzzxsvv1kwdky56fr1jiy9199m3vxqh4mz85qr067cmn"))))
+        (base32 "017frilx35w3m4dz3n6m2f293q4fq4jrk6hl8f7wg5xs3r8hswvq"))))
     (build-system gnu-build-system)
     (arguments
      (list
@@ -615,7 +615,7 @@ (define-public docker-cli
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0qy35vvnl4lf9w6dr9n7yfqvzhzm7m3sl2ai275apbhygwgcsbss"))))
+        (base32 "0szwaxiasy77mm90wj2qg747zb9lyiqndg5halg7qbi41ng6ry0h"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"

base-commit: 7b0863f07a113caef26fea13909bd97d250b629e
-- 
2.41.0





^ permalink raw reply related	[relevance 69%]

* [bug#68073] [PATCH v2] services: docker: Add config-file option.
  2023-12-27 20:20 66% [bug#68073] [PATCH] Add config-file configuration option to dockerd Connor Clark via Guix-patches via
@ 2023-12-29  4:47 66% ` Connor Clark via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Connor Clark via Guix-patches via @ 2023-12-29  4:47 UTC (permalink / raw)
  To: 68073; +Cc: Connor Clark

* gnu/services/docker.scm (docker-configuration)[config-file] Add file-like
field.
* doc/guix.texi (Docker Service): Add information about config-file.
---

Thanks for responding! This revision should fix the issues you raised. I added
documentation in guix.texi and revised the commit message to fit in with the
others. The tests file was a bit complex though, I couldn't figure out where I
would extend it if I wanted to :).

 doc/guix.texi           |  3 +++
 gnu/services/docker.scm | 12 +++++++++++-
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index a9a9272c35..a9488ff4b5 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39701,6 +39701,9 @@ This must be a list of strings where each string has the form
       "TMPDIR=/tmp/dockerd")
 @end lisp
 
+@item @code{config-file} (type: maybe-file-like)
+JSON configuration file pass to @command{dockerd}.
+
 @end table
 @end deftp
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 72ef7d74db..4d32b96847 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -61,6 +61,8 @@ (define-module (gnu services docker)
             oci-container-service-type
             oci-container-shepherd-service))
 
+(define-maybe file-like)
+
 (define-configuration docker-configuration
   (docker
    (file-like docker)
@@ -87,6 +89,9 @@ (define-configuration docker-configuration
   (environment-variables
    (list '())
    "Environment variables to set for dockerd")
+  (config-file
+   (maybe-file-like)
+   "JSON configuration file to pass to dockerd")
   (no-serialization))
 
 (define %docker-accounts
@@ -131,7 +136,8 @@ (define (docker-shepherd-service config)
          (enable-iptables? (docker-configuration-enable-iptables? config))
          (environment-variables (docker-configuration-environment-variables config))
          (proxy (docker-configuration-proxy config))
-         (debug? (docker-configuration-debug? config)))
+         (debug? (docker-configuration-debug? config))
+         (config-file (docker-configuration-config-file config)))
     (shepherd-service
            (documentation "Docker daemon.")
            (provision '(dockerd))
@@ -144,6 +150,10 @@ (define (docker-shepherd-service config)
            (start #~(make-forkexec-constructor
                      (list (string-append #$docker "/bin/dockerd")
                            "-p" "/var/run/docker.pid"
+                           #$@(if (not (eq? config-file %unset-value))
+                                  (list #~(string-append
+                                           "--config-file=" #$config-file))
+                                  '())
                            #$@(if debug?
                                   '("--debug" "--log-level=debug")
                                   '())

base-commit: 5bd80ccd69047b1777749e24d4adf2c951b5d14b
-- 
2.41.0





^ permalink raw reply related	[relevance 66%]

* [bug#68073] [PATCH] Add config-file configuration option to dockerd
@ 2023-12-27 20:20 66% Connor Clark via Guix-patches via
  2023-12-29  4:47 66% ` [bug#68073] [PATCH v2] services: docker: Add config-file option Connor Clark via Guix-patches via
  0 siblings, 1 reply; 149+ results
From: Connor Clark via Guix-patches via @ 2023-12-27 20:20 UTC (permalink / raw)
  To: 68073
  Cc: Connor Clark, paren, guix, ludo, othacehe, rg, rekado,
	zimon.toutoune, me, jgart

---

This is my first time submitting a patch here, so please let me know if I'm
missing something important, or my email is formatted incorrectly, or anything
else.

This patch adds an option to pass a json configuration file directly into
dockerd for options which aren't available in the docker-configuration record,
of which there are many. From what I've seen, some other packages use a
raw-configuration-string that gets appended into a file to accomplish similar
things, but I figured a file-like was better here because the rest of the
options are passed into the command invocation and not serialized into a file.

 gnu/services/docker.scm | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 72ef7d74db..4d32b96847 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -61,6 +61,8 @@ (define-module (gnu services docker)
             oci-container-service-type
             oci-container-shepherd-service))
 
+(define-maybe file-like)
+
 (define-configuration docker-configuration
   (docker
    (file-like docker)
@@ -87,6 +89,9 @@ (define-configuration docker-configuration
   (environment-variables
    (list '())
    "Environment variables to set for dockerd")
+  (config-file
+   (maybe-file-like)
+   "JSON configuration file to pass to dockerd")
   (no-serialization))
 
 (define %docker-accounts
@@ -131,7 +136,8 @@ (define (docker-shepherd-service config)
          (enable-iptables? (docker-configuration-enable-iptables? config))
          (environment-variables (docker-configuration-environment-variables config))
          (proxy (docker-configuration-proxy config))
-         (debug? (docker-configuration-debug? config)))
+         (debug? (docker-configuration-debug? config))
+         (config-file (docker-configuration-config-file config)))
     (shepherd-service
            (documentation "Docker daemon.")
            (provision '(dockerd))
@@ -144,6 +150,10 @@ (define (docker-shepherd-service config)
            (start #~(make-forkexec-constructor
                      (list (string-append #$docker "/bin/dockerd")
                            "-p" "/var/run/docker.pid"
+                           #$@(if (not (eq? config-file %unset-value))
+                                  (list #~(string-append
+                                           "--config-file=" #$config-file))
+                                  '())
                            #$@(if debug?
                                   '("--debug" "--log-level=debug")
                                   '())

base-commit: 5bd80ccd69047b1777749e24d4adf2c951b5d14b
-- 
2.41.0





^ permalink raw reply related	[relevance 66%]

* [bug#62153] [PATCH 3/5] guix: docker: Build layered images.
    2023-12-26  2:18 72% ` [bug#62153] [PATCH 2/5] tests: docker-system: Increase image size Oleg Pykhalov
@ 2023-12-26  2:18 37% ` Oleg Pykhalov
  1 sibling, 0 replies; 149+ results
From: Oleg Pykhalov @ 2023-12-26  2:18 UTC (permalink / raw)
  To: 62153
  Cc: Oleg Pykhalov, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

* guix/docker.scm (%docker-image-max-layers): New variable.
(size-sorted-store-items, create-empty-tar): New procedures.
(config, manifest, build-docker-image): Build layered images.

Change-Id: I4c8846bff0a3ceccb77e6bdf95d4942e5c3efe41
---
 guix/docker.scm | 212 +++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 166 insertions(+), 46 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..5deca2afdb 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,16 +30,27 @@ (define-module (guix docker)
                           with-directory-excursion
                           invoke))
   #:use-module (gnu build install)
+  #:use-module ((guix build store-copy)
+                #:select (file-size))
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
   #:use-module ((texinfo string-utils)
                 #:select (escape-special-chars))
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
-  #:export (build-docker-image))
+  #:export (%docker-image-max-layers
+            build-docker-image))
+
+;; The maximum number of layers allowed in a Docker image is typically around
+;; 128, although it may vary depending on the Docker daemon. However, we
+;; recommend setting the limit to 100 to ensure sufficient room for future
+;; extensions.
+(define %docker-image-max-layers
+  #f)
 
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
@@ -92,12 +104,12 @@ (define (canonicalize-repository-name name)
                       (make-string (- min-length l) padding-character)))
       (_ normalized-name))))
 
-(define* (manifest path id #:optional (tag "guix"))
+(define* (manifest path layers #:optional (tag "guix"))
   "Generate a simple image manifest."
   (let ((tag (canonicalize-repository-name tag)))
     `#(((Config . "config.json")
         (RepoTags . #(,(string-append tag ":latest")))
-        (Layers . #(,(string-append id "/layer.tar")))))))
+        (Layers . ,(list->vector layers))))))
 
 ;; According to the specifications this is required for backwards
 ;; compatibility.  It duplicates information provided by the manifest.
@@ -106,8 +118,8 @@ (define* (repositories path id #:optional (tag "guix"))
   `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define* (config layer time arch #:key entry-point (environment '()))
-  "Generate a minimal image configuration for the given LAYER file."
+(define* (config layers-diff-ids time arch #:key entry-point (environment '()))
+  "Generate a minimal image configuration for the given LAYERS files."
   ;; "architecture" must be values matching "platform.arch" in the
   ;; runtime-spec at
   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
@@ -125,7 +137,7 @@ (define* (config layer time arch #:key entry-point (environment '()))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
-               (diff_ids . #(,(layer-diff-id layer)))))))
+               (diff_ids . ,(list->vector layers-diff-ids))))))
 
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
@@ -136,6 +148,26 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define (size-sorted-store-items items max-layers)
+  "Split list of ITEMS at %MAX-LAYERS and sort by disk usage."
+  (let* ((items-length (length items))
+         (head tail
+               (split-at
+                (map (match-lambda ((size . item) item))
+                     (sort (map (lambda (item)
+                                  (cons (file-size item) item))
+                                items)
+                           (lambda (item1 item2)
+                             (< (match item2 ((size . _) size))
+                                (match item1 ((size . _) size))))))
+                (if (>= items-length max-layers)
+                    (- max-layers 2)
+                    (1- items-length)))))
+    (list head tail)))
+
+(define (create-empty-tar file)
+  (invoke "tar" "-cf" file "--files-from" "/dev/null"))
+
 (define* (build-docker-image image paths prefix
                              #:key
                              (repository "guix")
@@ -146,11 +178,13 @@ (define* (build-docker-image image paths prefix
                              entry-point
                              (environment '())
                              compressor
-                             (creation-time (current-time time-utc)))
-  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
-must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
-is a descriptive name that will show up in \"REPOSITORY\" column of the output
-of \"docker images\".
+                             (creation-time (current-time time-utc))
+                             max-layers
+                             root-system)
+  "Write to IMAGE a layerer Docker image archive containing the given PATHS.
+PREFIX must be a store path that is a prefix of any store paths in PATHS.
+REPOSITORY is a descriptive name that will show up in \"REPOSITORY\" column of
+the output of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -172,7 +206,14 @@ (define* (build-docker-image image paths prefix
 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 PATHS 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."
+SRFI-19 time-utc object, as the creation time in metadata.
+
+When MAX-LAYERS is not false build layered image, providing a Docker
+image with many of the store paths being on their own layer to improve sharing
+between images.
+
+ROOT-SYSTEM is a directory with a provisioned root file system, which will be
+added to image as a layer."
   (define (sanitize path-fragment)
     (escape-special-chars
      ;; GNU tar strips the leading slash off of absolute paths before applying
@@ -203,6 +244,59 @@ (define* (build-docker-image image paths prefix
     (if (eq? '() transformations)
         '()
         `("--transform" ,(transformations->expression transformations))))
+  (define (seal-layer)
+    ;; Add 'layer.tar' to 'image.tar' under the right name.  Return its hash.
+    (let* ((file-hash (layer-diff-id "layer.tar"))
+           (file-name (string-append file-hash "/layer.tar")))
+      (mkdir file-hash)
+      (rename-file "layer.tar" file-name)
+      (invoke "tar" "-rf" "image.tar" file-name)
+      (delete-file file-name)
+      file-hash))
+  (define layers-hashes
+    ;; Generate a tarball that includes container image layers as tarballs,
+    ;; along with a manifest.json file describing the layer and config file
+    ;; locations.
+    (match-lambda
+      (((head ...) (tail ...) id)
+       (create-empty-tar "image.tar")
+       (let* ((head-layers
+               (map
+                (lambda (file)
+                  (invoke "tar" "cf" "layer.tar" file)
+                  (seal-layer))
+                head))
+              (tail-layer
+               (begin
+                 (create-empty-tar "layer.tar")
+                 (for-each (lambda (file)
+                             (invoke "tar" "-rf" "layer.tar" file))
+                           tail)
+                 (let* ((file-hash (layer-diff-id "layer.tar"))
+                        (file-name (string-append file-hash "/layer.tar")))
+                   (mkdir file-hash)
+                   (rename-file "layer.tar" file-name)
+                   (invoke "tar" "-rf" "image.tar" file-name)
+                   (delete-file file-name)
+                   file-hash)))
+              (customization-layer
+               (let* ((file-id (string-append id "/layer.tar"))
+                      (file-hash (layer-diff-id file-id))
+                      (file-name (string-append file-hash "/layer.tar")))
+                 (mkdir file-hash)
+                 (rename-file file-id file-name)
+                 (invoke "tar" "-rf" "image.tar" file-name)
+                 file-hash))
+              (all-layers
+               (append head-layers (list tail-layer customization-layer))))
+         (with-output-to-file "manifest.json"
+           (lambda ()
+             (scm->json (manifest prefix
+                                  (map (cut string-append <> "/layer.tar")
+                                       all-layers)
+                                  repository))))
+         (invoke "tar" "-rf" "image.tar" "manifest.json")
+         all-layers))))
   (let* ((directory "/tmp/docker-image") ;temporary working directory
          (id (docker-id prefix))
          (time (date->string (time-utc->date creation-time) "~4"))
@@ -229,26 +323,39 @@ (define* (build-docker-image image paths prefix
         (with-output-to-file "json"
           (lambda () (scm->json (image-description id time))))
 
-        ;; Create a directory for the non-store files that need to go into the
-        ;; archive.
-        (mkdir "extra")
+        (if root-system
+            (let ((directory (getcwd)))
+              (with-directory-excursion root-system
+                (apply invoke "tar"
+                       "-cf" (string-append directory "/layer.tar")
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." "..")))))))))
+            (begin
+              ;; Create a directory for the non-store files that need to go
+              ;; into the archive.
+              (mkdir "extra")
 
-        (with-directory-excursion "extra"
-          ;; Create non-store files.
-          (for-each (cut evaluate-populate-directive <> "./")
-                    extra-files)
+              (with-directory-excursion "extra"
+                ;; Create non-store files.
+                (for-each (cut evaluate-populate-directive <> "./")
+                          extra-files)
 
-          (when database
-            ;; Initialize /var/guix, assuming PREFIX points to a profile.
-            (install-database-and-gc-roots "." database prefix))
+                (when database
+                  ;; Initialize /var/guix, assuming PREFIX points to a
+                  ;; profile.
+                  (install-database-and-gc-roots "." database prefix))
 
-          (apply invoke "tar" "-cf" "../layer.tar"
-                 `(,@transformation-options
-                   ,@(tar-base-options)
-                   ,@paths
-                   ,@(scandir "."
-                              (lambda (file)
-                                (not (member file '("." ".."))))))))
+                (apply invoke "tar" "-cf" "../layer.tar"
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(if max-layers '() paths)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." ".."))))))))
+              (delete-file-recursively "extra")))
 
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -261,24 +368,37 @@ (define* (build-docker-image image paths prefix
         ;; error messages.
         (with-error-to-port (%make-void-port "w")
           (lambda ()
-            (system* "tar" "--delete" "/" "-f" "layer.tar")))
-
-        (delete-file-recursively "extra"))
+            (system* "tar" "--delete" "/" "-f" "layer.tar"))))
 
       (with-output-to-file "config.json"
         (lambda ()
-          (scm->json (config (string-append id "/layer.tar")
-                             time arch
-                             #:environment environment
-                             #:entry-point entry-point))))
-      (with-output-to-file "manifest.json"
-        (lambda ()
-          (scm->json (manifest prefix id repository))))
-      (with-output-to-file "repositories"
-        (lambda ()
-          (scm->json (repositories prefix id repository)))))
-
-    (apply invoke "tar" "-cf" image "-C" directory
-           `(,@(tar-base-options #:compressor compressor)
-             "."))
+          (scm->json
+           (config (if max-layers
+                       (layers-hashes
+                        (append (size-sorted-store-items paths max-layers)
+                                (list id)))
+                       (list (layer-diff-id (string-append id "/layer.tar"))))
+                   time arch
+                   #:environment environment
+                   #:entry-point entry-point))))
+      (if max-layers
+          (begin
+            (invoke "tar" "-rf" "image.tar" "config.json")
+            (if compressor
+                (begin
+                  (apply invoke `(,@compressor "image.tar"))
+                  (copy-file "image.tar.gz" image))
+                (copy-file "image.tar" image)))
+          (begin
+            (with-output-to-file "manifest.json"
+              (lambda ()
+                (scm->json (manifest prefix
+                                     (list (string-append id "/layer.tar"))
+                                     repository))))
+            (with-output-to-file "repositories"
+              (lambda ()
+                (scm->json (repositories prefix id repository))))
+            (apply invoke "tar" "-cf" image
+                   `(,@(tar-base-options #:compressor compressor)
+                     ".")))))
     (delete-file-recursively directory)))
-- 
2.41.0





^ permalink raw reply related	[relevance 37%]

* [bug#62153] [PATCH 2/5] tests: docker-system: Increase image size.
  @ 2023-12-26  2:18 72% ` Oleg Pykhalov
  2023-12-26  2:18 37% ` [bug#62153] [PATCH 3/5] guix: docker: Build layered images Oleg Pykhalov
  1 sibling, 0 replies; 149+ results
From: Oleg Pykhalov @ 2023-12-26  2:18 UTC (permalink / raw)
  To: 62153; +Cc: Oleg Pykhalov

* gnu/tests/docker.scm (run-docker-system-test)[vm]: Increase
'disk-image-size'.

Change-Id: If88588d8981efdfdc539460900f1cbb9a663f9cb
---
 gnu/tests/docker.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index edc9804414..9e9d2e2d07 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -212,7 +212,7 @@ (define (run-docker-system-test tarball)
     (virtual-machine
      (operating-system os)
      (volatile? #f)
-     (disk-image-size (* 5500 (expt 2 20)))
+     (disk-image-size (* 6000 (expt 2 20)))
      (memory-size 2048)
      (port-forwardings '())))
 
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#67613] [PATCH] tests: Add oci-container-service-type unit tests.
  @ 2023-12-03 21:56 70% ` Giacomo Leidi via Guix-patches via
  2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
  2 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-12-03 21:56 UTC (permalink / raw)
  To: 67613; +Cc: Giacomo Leidi

This patch is a followup to issue #66160 and issue #67574. It introduces
unit tests for the oci-container-service-type. 8 out 11 tests depend on
issue #67574 being merged since issue #66160 was merged with a blocking
bug from the beginning.

* gnu/services/docker.scm: Export
oci-container-configuration-container-user and
oci-container-configuration-workdir.
* tests/services/docker.scm: New file.
* Makefile.am (SCM_TESTS): Register it.

Change-Id: I47ed0fe36060ba84dd50b548a66f36e3df8a3710
---
 Makefile.am               |   1 +
 gnu/services/docker.scm   |   2 +
 tests/services/docker.scm | 187 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 190 insertions(+)
 create mode 100644 tests/services/docker.scm

diff --git a/Makefile.am b/Makefile.am
index cbc3191dfc..91f7a77a94 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -564,6 +564,7 @@ SCM_TESTS =					\
   tests/services.scm				\
   tests/services/file-sharing.scm		\
   tests/services/configuration.scm		\
+  tests/services/docker.scm			\
   tests/services/lightdm.scm			\
   tests/services/linux.scm			\
   tests/services/pam-mount.scm			\
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index ebea0a473a..263cb41df3 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -58,6 +58,8 @@ (define-module (gnu services docker)
             oci-container-configuration-network
             oci-container-configuration-ports
             oci-container-configuration-volumes
+            oci-container-configuration-container-user
+            oci-container-configuration-workdir
             oci-container-service-type
             oci-container-shepherd-service))
 
diff --git a/tests/services/docker.scm b/tests/services/docker.scm
new file mode 100644
index 0000000000..fad28a228c
--- /dev/null
+++ b/tests/services/docker.scm
@@ -0,0 +1,187 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests services docker)
+  #:use-module (gnu packages docker)
+  #:use-module (gnu services docker)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix store)
+  #:use-module (guix tests)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64))
+
+
+;;; Commentary:
+;;;
+;;; Unit tests for the (gnu services docker) module.
+;;;
+;;; Code:
+
+
+;;;
+;;; Unit tests for the oci-container-service-type.
+;;;
+
+
+;;; Access some internals for whitebox testing.
+(define %store
+  (open-connection-for-tests))
+(define (gexp->sexp . x)
+  (apply (@@ (guix gexp) gexp->sexp) x))
+(define* (gexp->sexp* exp #:optional target)
+  (run-with-store %store (gexp->sexp exp (%current-system) target)
+                  #:guile-for-build (%guile-for-build)))
+(define (list->sexp-list* lst)
+  (map (lambda (el)
+         (if (gexp? el)
+             (gexp->sexp* el)
+             el))
+       lst))
+(define oci-sanitize-mixed-list
+  (@@ (gnu services docker) oci-sanitize-mixed-list))
+(define (oci-container-configuration->options config)
+  (list->sexp-list*
+   ((@@ (gnu services docker) oci-container-configuration->options) config)))
+
+(test-begin "oci-containers-service")
+
+(test-group "oci-sanitize-mixed-list"
+  (define delimiter "=")
+  (define file-like-key
+    (plain-file "oci-tests-file-like-key" "some-content"))
+  (define mixed-list
+    `("any kind of string"
+      ("KEY" . "VALUE")
+      (,#~(string-append "COMPUTED" "_KEY") . "VALUE")
+      (,file-like-key . "VALUE")))
+
+  (test-assertm "successfully lower mixed values"
+    (mlet* %store-monad ((ml ->             (oci-sanitize-mixed-list "field-name" mixed-list delimiter))
+                         (actual ->         (list->sexp-list* ml))
+                         (file-like-item    (lower-object file-like-key))
+                         (expected ->       `("any kind of string"
+                                              (string-append "KEY" "=" "VALUE")
+                                              (string-append (string-append "COMPUTED" "_KEY") "=" "VALUE")
+                                              (string-append ,file-like-item "=" "VALUE"))))
+      (mbegin %store-monad
+        (return
+         (every (lambda (pair)
+                  (apply (if (string? (first pair))
+                             string=?
+                             equal?)
+                         pair))
+                (zip expected actual))))))
+
+  (test-error
+   "illegal list values" #t
+   (oci-sanitize-mixed-list "field-name" '(("KEY" . "VALUE") #f) delimiter))
+
+  (test-error
+   "illegal pair member values" #t
+   (oci-sanitize-mixed-list "field-name" '(("KEY" . 1)) delimiter)))
+
+(test-group "oci-container-configuration->options"
+  (define config
+    (oci-container-configuration
+     (image "guix/guix:latest")))
+
+  (test-equal "entrypoint"
+    (list "--entrypoint" "entrypoint")
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (entrypoint "entrypoint"))))
+
+  (test-equal "environment"
+    (list "--env" '(string-append "key" "=" "value")
+          "--env" '(string-append "environment" "=" "variable"))
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (environment
+       '(("key" . "value")
+         ("environment" . "variable"))))))
+
+  (test-equal "network"
+    (list "--network" "host")
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (network "host"))))
+
+  (test-equal "container-user"
+    (list "--user" "service-account")
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (container-user "service-account"))))
+
+  (test-equal "workdir"
+    (list "--workdir" "/srv/http")
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (workdir "/srv/http"))))
+
+  (test-equal "ports"
+    (list "-p" '(string-append "10443" ":" "443")
+          "-p" '(string-append "9022" ":" "22"))
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (ports
+       '(("10443" . "443")
+         ("9022" . "22"))))))
+
+  (test-equal "volumes"
+    (list "-v" '(string-append "/gnu/store" ":" "/gnu/store")
+          "-v" '(string-append "/var/lib/guix" ":" "/var/lib/guix"))
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (volumes
+       '(("/gnu/store" . "/gnu/store")
+         ("/var/lib/guix" . "/var/lib/guix"))))))
+
+  (test-equal "complete configuration"
+    (list "--entrypoint" "entrypoint"
+          "--env" '(string-append "key" "=" "value")
+          "--network" "host"
+          "--user" "service-account"
+          "--workdir" "/srv/http"
+          "-p" '(string-append "10443" ":" "443")
+          "-v" '(string-append "/gnu/store" ":" "/gnu/store"))
+    (oci-container-configuration->options
+     (oci-container-configuration
+      (inherit config)
+      (entrypoint "entrypoint")
+      (environment
+       '(("key" . "value")))
+      (network "host")
+      (container-user "service-account")
+      (workdir "/srv/http")
+      (ports
+       '(("10443" . "443")))
+      (volumes
+       '(("/gnu/store" . "/gnu/store")))))))
+
+(test-end "oci-containers-service")

base-commit: 2c9ac9ab20c76abe570ff83f8746fa089fea3047
-- 
2.41.0





^ permalink raw reply related	[relevance 70%]

* [bug#67574] [PATCH] services: Fix oci-container-service-type container user.
  @ 2023-12-01 22:45 72% ` Giacomo Leidi via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-12-01 22:45 UTC (permalink / raw)
  To: 67574; +Cc: Giacomo Leidi

The oci-container-configuration supports two user fields: one is the
user, from the host system, under whose authority the OCI-backed
Shepherd service is run; the other is an optional user/UID that can be
passed to the docker run invokation to override the user defined in the
OCI image.

The user from the host system is incorrectly passed to docker run
command, this patches reverts the incorrect behavior and passes the
correct container-user field value.

* gnu/services/docker.scm (oci-container-configuration): Fix the user
passed to the docker run invokation.
---
 gnu/services/docker.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index ebea0a473a..72ef7d74db 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -374,7 +374,7 @@ (define oci-container-configuration->options
           (network
            (oci-container-configuration-network config))
           (user
-           (oci-container-configuration-user config))
+           (oci-container-configuration-container-user config))
           (workdir
            (oci-container-configuration-workdir config)))
       (apply append

base-commit: 842a11f1caa1bb929c427722ad9d7b7c1ff65727
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#66160] [PATCH v2] gnu: Add oci-container-service-type.
                     ` (4 preceding siblings ...)
  2023-10-14 21:47 36% ` Giacomo Leidi via Guix-patches via
@ 2023-10-24 20:59 34% ` Giacomo Leidi via Guix-patches via
  5 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-10-24 20:59 UTC (permalink / raw)
  To: 66160; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration): New variable;
(oci-container-shepherd-service): new variable;
(oci-container-service-type): new variable.
* doc/guix.texi: Document it.
---
 doc/guix.texi           | 131 ++++++++++++++++++++
 gnu/services/docker.scm | 260 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 390 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b90078be06..f6363a16a3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39518,6 +39518,137 @@ Miscellaneous Services
 @command{singularity run} and similar commands.
 @end defvar
 
+@cindex OCI-backed, Shepherd services
+@subsubheading OCI backed services
+
+Should you wish to manage your Docker containers with the same consistent
+interface you use for your other Shepherd services,
+@var{oci-container-service-type} is the tool to use: given an
+@acronym{Open Container Initiative, OCI} container image, it will run it in a
+Shepherd service.  One example where this is useful: it lets you run services
+that are available as Docker/OCI images but not yet packaged for Guix.
+
+@defvar oci-container-service-type
+
+This is a thin wrapper around Docker's CLI that executes OCI images backed
+processes as Shepherd Services.
+
+@lisp
+(service oci-container-service-type
+         (list
+          (oci-container-configuration
+           (image "prom/prometheus")
+           (network "host")
+           (ports
+             '(("9000" . "9000")
+               ("9090" . "9090"))))
+          (oci-container-configuration
+           (image "grafana/grafana:10.0.1")
+           (network "host")
+           (ports
+             '(("3000" . "3000")))
+           (volumes
+             '("/var/lib/grafana:/var/lib/grafana")))))
+@end lisp
+
+In this example two different Shepherd services are going be added to the
+system.  Each @code{oci-container-configuration} record translates to a
+@code{docker run} invocation and its fields directly map to options.  You can
+refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run,upstream},
+documentation for the semantics of each value.  If the images are not found they
+will be
+@url{https://docs.docker.com/engine/reference/commandline/pull/,pulled}.  The
+spawned services are going to be attached to the host network and are supposed
+to behave like other processes.
+
+@end defvar
+
+@c %start of fragment
+
+@deftp {Data Type} oci-container-configuration
+Available @code{oci-container-configuration} fields are:
+
+@table @asis
+@item @code{user} (default: @code{"oci-container"}) (type: string)
+The user under whose authority docker commands will be run.
+
+@item @code{group} (default: @code{"docker"}) (type: string)
+The group under whose authority docker commands will be run.
+
+@item @code{command} (default: @code{()}) (type: list-of-strings)
+Overwrite the default command (@code{CMD}) of the image.
+
+@item @code{entrypoint} (default: @code{""}) (type: string)
+Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
+
+@item @code{environment} (default: @code{()}) (type: list)
+Set environment variables. This can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '("LANGUAGE" . "eo:ca:eu")
+      "JAVA_HOME=/opt/java")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics.
+
+@item @code{image} (type: string)
+The image used to build the container.  Images are resolved by the
+Docker Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.
+
+@item @code{provision} (default: @code{""}) (type: string)
+Set the name of the provisioned Shepherd service.
+
+@item @code{network} (default: @code{""}) (type: string)
+Set a Docker network for the spawned container.
+
+@item @code{ports} (default: @code{()}) (type: list)
+Set the port or port ranges to expose from the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("8080" . "80")
+      "10443:443")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics.
+
+@item @code{volumes} (default: @code{()}) (type: list)
+Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("/root/data/grafana" . "/var/lib/grafana")
+      "/gnu/store:/gnu/store")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics.
+
+@item @code{container-user} (default: @code{""}) (type: string)
+Set the current user inside the spawned container.  You can refer to the
+@url{https://docs.docker.com/engine/reference/run/#user,upstream}
+documentation for semantics.
+
+@item @code{workdir} (default: @code{""}) (type: string)
+Set the current working for the spawned Shepherd service.
+You can refer to the
+@url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
+documentation for semantics.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
 @cindex Audit
 @subsubheading Auditd Service
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..ebea0a473a 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,15 +30,36 @@ (define-module (gnu services docker)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
+  #:use-module (gnu packages admin)               ;shadow
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-user
+            oci-container-configuration-group
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-provision
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +238,239 @@ (define singularity-service-type
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+\f
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (match pair
+    (((? valid? key) . (? valid? value))
+     #~(string-append #$key #$delimiter #$value))
+    (_
+     (raise
+      (formatted-message
+       (G_ "pair members must contain only strings, gexps or file-like objects
+but ~a was found")
+       pair)))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (raise
+             (formatted-message
+              (G_ "~a members must be either a string or a pair but ~a was
+found!")
+              name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization oci-container-configuration
+  (user
+   (string "oci-container")
+   "The user under whose authority docker commands will be run.")
+  (group
+   (string "docker")
+   "The group under whose authority docker commands will be run.")
+  (command
+   (list-of-strings '())
+   "Overwrite the default command (@code{CMD}) of the image.")
+  (entrypoint
+   (maybe-string)
+   "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+  (environment
+   (list '())
+   "Set environment variables.  This can be a list of pairs or strings, even
+mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.  Images are resolved by the Docker
+Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.")
+  (provision
+   (maybe-string)
+   "Set the name of the provisioned Shepherd service.")
+  (network
+   (maybe-string)
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container.  This can
+be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"8080\" . \"80\")
+      \"10443:443\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"/root/data/grafana\" . \"/var/lib/grafana\")
+      \"/gnu/store:/gnu/store\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-volumes))
+  (container-user
+   (maybe-string)
+   "Set the current user inside the spawned container.  You can refer to the
+@url{https://docs.docker.com/engine/reference/run/#user,upstream}
+documentation for semantics.")
+  (workdir
+   (maybe-string)
+   "Set the current working for the spawned Shepherd service.
+You can refer to the
+@url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
+documentation for semantics."))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config))
+          (user
+           (oci-container-configuration-user config))
+          (workdir
+           (oci-container-configuration-workdir config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(if (maybe-value-set? entrypoint)
+                            `("--entrypoint" ,entrypoint)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(if (maybe-value-set? network)
+                            `("--network" ,network)
+                            '())
+                       ,(if (maybe-value-set? user)
+                            `("--user" ,user)
+                            '())
+                       ,(if (maybe-value-set? workdir)
+                            `("--workdir" ,workdir)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (maybe-value-set? name)
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (user (oci-container-configuration-user config))
+         (group (oci-container-configuration-group config))
+         (command (oci-container-configuration-command config))
+         (provision (oci-container-configuration-provision config))
+         (image (oci-container-configuration-image config))
+         (options (oci-container-configuration->options config))
+         (name (guess-name provision image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd user-processes))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command "run" "--rm"
+                                "--name" #$name
+                                #$@options #$image #$@command)
+                          #:user #$user
+                          #:group #$group))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "rm" "-f" #$name)))
+                      (actions
+                       (list
+                        (shepherd-action
+                         (name 'pull)
+                         (documentation
+                          (format #f "Pull ~a's image (~a)."
+                                  name image))
+                         (procedure
+                          #~(lambda _
+                              (invoke #$docker-command "pull" #$image)))))))))
+
+(define %oci-container-accounts
+  (list (user-account
+         (name "oci-container")
+         (comment "OCI services account")
+         (group "docker")
+         (system? #t)
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension account-service-type
+                                                     (const %oci-container-accounts))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service allows the management of Docker and OCI
+containers as Shepherd services.")))

base-commit: 7e4324575c80cbe3c18c26b0507776b16ba3989e
-- 
2.41.0





^ permalink raw reply related	[relevance 34%]

* [bug#66160] [PATCH] gnu: Add oci-container-service-type.
                     ` (3 preceding siblings ...)
  2023-10-14 21:36 36% ` Giacomo Leidi via Guix-patches via
@ 2023-10-14 21:47 36% ` Giacomo Leidi via Guix-patches via
  2023-10-24 20:59 34% ` [bug#66160] [PATCH v2] " Giacomo Leidi via Guix-patches via
  5 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-10-14 21:47 UTC (permalink / raw)
  To: 66160; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration): New variable;
(oci-container-shepherd-service): new variable;
(oci-container-service-type): new variable.
* doc/guix.texi: Document it.
---
 doc/guix.texi           | 120 ++++++++++++++++++++
 gnu/services/docker.scm | 237 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 356 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 083504dcb8..6de46a1ebe 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39534,6 +39534,126 @@ Miscellaneous Services
 @command{singularity run} and similar commands.
 @end defvar
 
+@cindex OCI-backed, Shepherd services
+@subsubheading OCI backed services
+
+Should you wish to manage your Docker containers with the same consistent
+interface you use for your other Shepherd services,
+@var{oci-container-service-type} is the tool to use: given an
+@acronym{Open Container Initiative, OCI} container image, it will run it in a
+Shepherd service.  One example where this is useful: it lets you run services
+that are available as Docker/OCI images but not yet packaged for Guix.
+
+@defvar oci-container-service-type
+
+This is a thin wrapper around Docker's CLI that executes OCI images backed
+processes as Shepherd Services.
+
+@lisp
+(service oci-container-service-type
+         (list
+          (oci-container-configuration
+           (image "prom/prometheus")
+           (network "host")
+           (ports
+             '(("9000" . "9000")
+               ("9090" . "9090"))))
+          (oci-container-configuration
+           (image "grafana/grafana:10.0.1")
+           (network "host")
+           (ports
+             '(("3000" . "3000")))
+           (volumes
+             '("/var/lib/grafana:/var/lib/grafana")))))
+@end lisp
+
+In this example two different Shepherd services are going be added to the
+system.  Each @code{oci-container-configuration} record translates to a
+@code{docker run} invocation and its fields directly map to options.  You can
+refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run,upstream},
+documentation for the semantics of each value.  If the images are not found they
+will be
+@url{https://docs.docker.com/engine/reference/commandline/pull/,pulled}.  The
+spawned services are going to be attached to the host network and are supposed
+to behave like other processes.
+
+@end defvar
+
+@c %start of fragment
+
+@deftp {Data Type} oci-container-configuration
+Available @code{oci-container-configuration} fields are:
+
+@table @asis
+@item @code{user} (default: @code{"oci-container"}) (type: string)
+The user under whose authority docker commands will be run.
+
+@item @code{group} (default: @code{"docker"}) (type: string)
+The group under whose authority docker commands will be run.
+
+@item @code{command} (default: @code{()}) (type: list-of-strings)
+Overwrite the default command (@code{CMD}) of the image.
+
+@item @code{entrypoint} (default: @code{""}) (type: string)
+Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
+
+@item @code{environment} (default: @code{()}) (type: list)
+Set environment variables. This can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '("LANGUAGE" . "eo:ca:eu")
+      "JAVA_HOME=/opt/java")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics.
+
+@item @code{image} (type: string)
+The image used to build the container.  Images are resolved by the
+Docker Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.
+
+@item @code{name} (default: @code{""}) (type: string)
+Set a name for the spawned container.
+
+@item @code{network} (default: @code{""}) (type: string)
+Set a Docker network for the spawned container.
+
+@item @code{ports} (default: @code{()}) (type: list)
+Set the port or port ranges to expose from the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("8080" . "80")
+      "10443:443")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics.
+
+@item @code{volumes} (default: @code{()}) (type: list)
+Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("/root/data/grafana" . "/var/lib/grafana")
+      "/gnu/store:/gnu/store")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
 @cindex Audit
 @subsubheading Auditd Service
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..2d709bf2ce 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,15 +30,34 @@ (define-module (gnu services docker)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
+  #:use-module (gnu packages admin)               ;shadow
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-name
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +236,218 @@ (define singularity-service-type
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+\f
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (match pair
+    (((? valid? key) . (? valid? value))
+     #~(string-append #$key #$delimiter #$value))
+    (_
+     (raise
+      (formatted-message
+       (G_ "pair members must contain only strings, gexps or file-like objects
+but ~a was found")
+       pair)))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (raise
+             (formatted-message
+              (G_ "~a members must be either a string or a pair but ~a was
+found!")
+              name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization oci-container-configuration
+  (user
+   (string "oci-container")
+   "The user under whose authority docker commands will be run.")
+  (group
+   (string "docker")
+   "The group under whose authority docker commands will be run.")
+  (command
+   (list-of-strings '())
+   "Overwrite the default command (@code{CMD}) of the image.")
+  (entrypoint
+   (maybe-string)
+   "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+  (environment
+   (list '())
+   "Set environment variables.  This can be a list of pairs or strings, even
+mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.  Images are resolved by the Docker
+Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.")
+  (name
+   (maybe-string)
+   "Set a name for the spawned container.")
+  (network
+   (maybe-string)
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container.  This can
+be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"8080\" . \"80\")
+      \"10443:443\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"/root/data/grafana\" . \"/var/lib/grafana\")
+      \"/gnu/store:/gnu/store\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-volumes)))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(if (maybe-value-set? entrypoint)
+                            `("--entrypoint" ,entrypoint)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(if (maybe-value-set? network)
+                            `("--network" ,network)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (maybe-value-set? name)
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (user (oci-container-configuration-user config))
+         (group (oci-container-configuration-group config))
+         (command (oci-container-configuration-command config))
+         (config-name (oci-container-configuration-name config))
+         (image (oci-container-configuration-image config))
+         (options (oci-container-configuration->options config))
+         (name (guess-name config-name image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd user-processes))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command "run" "--rm"
+                                "--name" #$name
+                                #$@options #$image #$@command)
+                          #:user #$user
+                          #:group #$group))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "rm" "-f" #$name)))
+                      (actions
+                       (list
+                        (shepherd-action
+                         (name 'pull)
+                         (documentation
+                          (format #f "Pull ~a's image (~a)."
+                                  name image))
+                         (procedure
+                          #~(lambda _
+                              (invoke #$docker-command "pull" #$image)))))))))
+
+(define %oci-container-accounts
+  (list (user-account
+         (name "oci-container")
+         (comment "OCI services account")
+         (group "docker")
+         (system? #t)
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension account-service-type
+                                                     (const %oci-container-accounts))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service allows the management of Docker and OCI
+containers as Shepherd services.")))

base-commit: 8aad7210ea06992ee3f36ca7f57678240949e063
-- 
2.41.0





^ permalink raw reply related	[relevance 36%]

* [bug#66160] [PATCH] gnu: Add oci-container-service-type.
                     ` (2 preceding siblings ...)
  2023-10-13 22:57 40% ` Giacomo Leidi via Guix-patches via
@ 2023-10-14 21:36 36% ` Giacomo Leidi via Guix-patches via
  2023-10-14 21:47 36% ` Giacomo Leidi via Guix-patches via
  2023-10-24 20:59 34% ` [bug#66160] [PATCH v2] " Giacomo Leidi via Guix-patches via
  5 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-10-14 21:36 UTC (permalink / raw)
  To: 66160; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration): New variable;
(oci-container-shepherd-service): new variable;
(oci-container-service-type): new variable.
* doc/guix.texi: Document it.
---
 doc/guix.texi           | 123 +++++++++++++++++++++
 gnu/services/docker.scm | 237 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 359 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 083504dcb8..54d5074bd7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39534,6 +39534,129 @@ Miscellaneous Services
 @command{singularity run} and similar commands.
 @end defvar
 
+@cindex OCI-backed, Shepherd services
+@subsubheading OCI backed services
+
+Should you wish to manage your Docker containers with the same consistent
+interface you use for your other Shepherd services,
+@var{oci-container-service-type} is the tool to use: given an
+@acronym{Open Container Initiative, OCI} container image, it will run it in a
+Shepherd service.  One example where this is useful: it lets you run services
+that are available as Docker/OCI images but not yet packaged for Guix.
+
+@defvar oci-container-service-type
+
+This is a thin wrapper around Docker's CLI that executes OCI images backed
+processes as Shepherd Services.
+
+@lisp
+(service oci-container-service-type
+         (list
+          (oci-container-configuration
+           (image "prom/prometheus")
+           (network "host")
+           (ports
+             '(("9000" . "9000")
+               ("9090" . "9090"))))))
+
+(service oci-container-service-type
+         (list
+          (oci-container-configuration
+           (image "grafana/grafana:10.0.1")
+           (network "host")
+           (ports
+             '(("3000" . "3000")))
+           (volumes
+             '("/var/lib/grafana:/var/lib/grafana"))))))
+@end lisp
+
+In this example two different Shepherd services are going be added to the
+system.  Each @code{oci-container-configuration} record translates to a
+@code{docker run} invocation and its fields directly map to options.  You can
+refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run,upstream},
+documentation for the semantics of each value.  If the images are not found they
+will be
+@url{https://docs.docker.com/engine/reference/commandline/pull/,pulled}.  The
+spawned services are going to be attached to the host network and are supposed
+to behave like other processes.
+
+@end defvar
+
+@c %start of fragment
+
+@deftp {Data Type} oci-container-configuration
+Available @code{oci-container-configuration} fields are:
+
+@table @asis
+@item @code{user} (default: @code{"oci-container"}) (type: string)
+The user under whose authority docker commands will be run.
+
+@item @code{group} (default: @code{"docker"}) (type: string)
+The group under whose authority docker commands will be run.
+
+@item @code{command} (default: @code{()}) (type: list-of-strings)
+Overwrite the default command (@code{CMD}) of the image.
+
+@item @code{entrypoint} (default: @code{""}) (type: string)
+Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
+
+@item @code{environment} (default: @code{()}) (type: list)
+Set environment variables. This can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '("LANGUAGE" . "eo:ca:eu")
+      "JAVA_HOME=/opt/java")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics.
+
+@item @code{image} (type: string)
+The image used to build the container.  Images are resolved by the
+Docker Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.
+
+@item @code{name} (default: @code{""}) (type: string)
+Set a name for the spawned container.
+
+@item @code{network} (default: @code{""}) (type: string)
+Set a Docker network for the spawned container.
+
+@item @code{ports} (default: @code{()}) (type: list)
+Set the port or port ranges to expose from the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("8080" . "80")
+      "10443:443")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics.
+
+@item @code{volumes} (default: @code{()}) (type: list)
+Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("/root/data/grafana" . "/var/lib/grafana")
+      "/gnu/store:/gnu/store")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@uref{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics.
+
+@end table
+
+@end deftp
+
+
+@c %end of fragment
+
 @cindex Audit
 @subsubheading Auditd Service
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..2d709bf2ce 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,15 +30,34 @@ (define-module (gnu services docker)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
+  #:use-module (gnu packages admin)               ;shadow
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-name
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +236,218 @@ (define singularity-service-type
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+\f
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (match pair
+    (((? valid? key) . (? valid? value))
+     #~(string-append #$key #$delimiter #$value))
+    (_
+     (raise
+      (formatted-message
+       (G_ "pair members must contain only strings, gexps or file-like objects
+but ~a was found")
+       pair)))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (raise
+             (formatted-message
+              (G_ "~a members must be either a string or a pair but ~a was
+found!")
+              name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization oci-container-configuration
+  (user
+   (string "oci-container")
+   "The user under whose authority docker commands will be run.")
+  (group
+   (string "docker")
+   "The group under whose authority docker commands will be run.")
+  (command
+   (list-of-strings '())
+   "Overwrite the default command (@code{CMD}) of the image.")
+  (entrypoint
+   (maybe-string)
+   "Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+  (environment
+   (list '())
+   "Set environment variables.  This can be a list of pairs or strings, even
+mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+      \"JAVA_HOME=/opt/java\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.  Images are resolved by the Docker
+Engine, and follow the usual format
+@code{myregistry.local:5000/testing/test-image:tag}.")
+  (name
+   (maybe-string)
+   "Set a name for the spawned container.")
+  (network
+   (maybe-string)
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container.  This can
+be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"8080\" . \"80\")
+      \"10443:443\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container.  This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"/root/data/grafana\" . \"/var/lib/grafana\")
+      \"/gnu/store:/gnu/store\")
+@end lisp
+
+String are passed directly to the Docker CLI.  You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics."
+   (sanitizer oci-sanitize-volumes)))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(if (maybe-value-set? entrypoint)
+                            `("--entrypoint" ,entrypoint)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(if (maybe-value-set? network)
+                            `("--network" ,network)
+                            '())
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (maybe-value-set? name)
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (user (oci-container-configuration-user config))
+         (group (oci-container-configuration-group config))
+         (command (oci-container-configuration-command config))
+         (config-name (oci-container-configuration-name config))
+         (image (oci-container-configuration-image config))
+         (options (oci-container-configuration->options config))
+         (name (guess-name config-name image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd user-processes))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command "run" "--rm"
+                                "--name" #$name
+                                #$@options #$image #$@command)
+                          #:user #$user
+                          #:group #$group))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "rm" "-f" #$name)))
+                      (actions
+                       (list
+                        (shepherd-action
+                         (name 'pull)
+                         (documentation
+                          (format #f "Pull ~a's image (~a)."
+                                  name image))
+                         (procedure
+                          #~(lambda _
+                              (invoke #$docker-command "pull" #$image)))))))))
+
+(define %oci-container-accounts
+  (list (user-account
+         (name "oci-container")
+         (comment "OCI services account")
+         (group "docker")
+         (system? #t)
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension account-service-type
+                                                     (const %oci-container-accounts))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service allows the management of Docker and OCI
+containers as Shepherd services.")))

base-commit: 8aad7210ea06992ee3f36ca7f57678240949e063
-- 
2.41.0





^ permalink raw reply related	[relevance 36%]

* [bug#66160] [PATCH] gnu: Add oci-container-service-type.
    2023-09-22 20:34 45% ` Giacomo Leidi via Guix-patches via
  2023-10-06 19:09 41% ` Giacomo Leidi via Guix-patches via
@ 2023-10-13 22:57 40% ` Giacomo Leidi via Guix-patches via
  2023-10-14 21:36 36% ` Giacomo Leidi via Guix-patches via
                   ` (2 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-10-13 22:57 UTC (permalink / raw)
  To: 66160; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration): New variable;
(oci-container-shepherd-service): new variable;
(oci-container-service-type): new variable.
* doc/guix.texi: Document it.
---
 doc/guix.texi           | 108 +++++++++++++++++++++++
 gnu/services/docker.scm | 185 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 292 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 083504dcb8..97c3515652 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39534,6 +39534,114 @@ Miscellaneous Services
 @command{singularity run} and similar commands.
 @end defvar
 
+@cindex OCI-backed, Shepherd services
+@subsubheading OCI backed services
+
+Should you wish to manage your Docker containers with the same consistent
+interface you use for your other Shepherd services,
+@var{oci-container-service-type} is the tool to use: given an
+@acronym{Open Container Initiative, OCI} container image, it will run it in a
+Shepherd service.  One example where this is useful: it lets you run services
+that are available as Docker/OCI images but not yet packaged for Guix.
+
+@defvar oci-container-service-type
+
+This is a thin wrapper around Docker's CLI that executes OCI images backed
+processes as Shepherd Services.
+
+@lisp
+(simple-service 'oci-grafana-service
+                oci-container-service-type
+                (list
+                 (oci-container-configuration
+                  (image "prom/prometheus")
+                  (network "host")
+                  (ports
+                    '(("9000" . "9000")
+                      ("9090" . "9090"))))))
+                 (oci-container-configuration
+                  (image "grafana/grafana:10.0.1")
+                  (network "host")
+                  (ports
+                    '(("3000" . "3000")))
+                  (volumes
+                    '("/var/lib/grafana:/var/lib/grafana"))))))
+@end lisp
+
+In this example two different Shepherd services are going be added to the
+system.  Each @code{oci-container-configuration} record translates to a
+@code{docker run} invocation and its fields directly map to options.  You can
+refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run,upstream},
+documentation for the semantics of each value.  If the images are not found they
+will be
+@url{https://docs.docker.com/engine/reference/commandline/pull/,pulled}.  The
+spawned services are going to be attached to the host network and are supposed
+to behave like other processes.
+
+@end defvar
+
+@deftp {Data Type} oci-container-configuration
+Available @code{oci-container-configuration} fields are:
+
+@table @asis
+@item @code{command} (default: @code{()}) (type: list-of-strings)
+Overwrite the default command (@code{CMD}) of the image.
+
+@item @code{entrypoint} (default: @code{""}) (type: string)
+Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
+
+@item @code{environment} (default: @code{()}) (type: list)
+Set environment variables. This can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '("LANGUAGE" . "eo:ca:eu")
+      "JAVA_HOME=/opt/java")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics.
+
+@item @code{image} (type: string)
+The image used to build the container. Images are resolved by the Docker Engine,
+and follow the usual format @code{myregistry.local:5000/testing/test-image:tag}.
+
+@item @code{name} (default: @code{""}) (type: string)
+Set a name for the spawned container.
+
+@item @code{network} (default: @code{""}) (type: string)
+Set a Docker network for the spawned container.
+
+@item @code{ports} (default: @code{()}) (type: list)
+Set the port or port ranges to expose from the spawned container. This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("8080" . "80")
+      "10443:443")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics.
+
+@item @code{volumes} (default: @code{()}) (type: list)
+Set volume mappings for the spawned container. This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("/root/data/grafana" . "/var/lib/grafana")
+      "/gnu/store:/gnu/store")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics.
+
+@end table
+@end deftp
+
 @cindex Audit
 @subsubheading Auditd Service
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..be954f7a27 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,12 +33,30 @@ (define-module (gnu services docker)
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-name
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +235,167 @@ (define singularity-service-type
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+\f
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (define (valid? member)
+    (or (string? member)
+        (gexp? member)
+        (file-like? member)))
+  (match pair
+    (((? valid? key) . (? valid? value))
+     #~(string-append #$key #$delimiter #$value))
+    (_
+     (raise
+      (formatted-message
+       (G_ "pair members must contain only strings, gexps or file-like objects
+but ~a was found")
+       pair)))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (raise
+             (formatted-message
+              (G_ "~a members must be either a string or a pair but ~a was
+found!")
+              name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-configuration/no-serialization oci-container-configuration
+  (command
+   (list-of-strings '())
+   "Overwrite the default CMD of the image.")
+  (entrypoint
+   (string "")
+   "Overwrite the default ENTRYPOINT of the image.")
+  (environment
+   (list '())
+   "Set environment variables."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.")
+  (name
+   (string "")
+   "Set a name for the spawned container.")
+  (network
+   (string "")
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container."
+   (sanitizer oci-sanitize-volumes)))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(when (not (string-null? entrypoint))
+                          (list "--entrypoint" entrypoint))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(when (not (string-null? network))
+                          (list "--network" network))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (not (string-null? name))
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (command (oci-container-configuration-command config))
+         (config-name (oci-container-configuration-name config))
+         (image (oci-container-configuration-image config))
+         (options (oci-container-configuration->options config))
+         (name (guess-name config-name image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd user-processes))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command
+                                "run"
+                                "--rm"
+                                "--name" #$name
+                                #$@options
+                                #$image
+                                #$@command)
+                          #:user "root"
+                          #:group "root"))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "stop" #$name)))
+                      (actions
+                       (list
+                        (shepherd-action
+                         (name 'pull)
+                         (documentation
+                          (format #f "Pull ~a's image (~a)."
+                                  name image))
+                         (procedure
+                          #~(lambda _
+                              (invoke #$docker-command "pull" #$image)))))))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service allows the management of Docker and OCI
+containers as Shepherd services.")))

base-commit: 8aad7210ea06992ee3f36ca7f57678240949e063
-- 
2.41.0





^ permalink raw reply related	[relevance 40%]

* [bug#66160] [PATCH] gnu: Add oci-container-service-type.
    2023-09-22 20:34 45% ` Giacomo Leidi via Guix-patches via
@ 2023-10-06 19:09 41% ` Giacomo Leidi via Guix-patches via
  2023-10-13 22:57 40% ` Giacomo Leidi via Guix-patches via
                   ` (3 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-10-06 19:09 UTC (permalink / raw)
  To: 66160; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration): New variable;
(oci-container-shepherd-service): new variable;
(oci-container-service-type): new variable.
* doc/guix.texi: Document it.
---
 doc/guix.texi           | 108 ++++++++++++++++++++++++++
 gnu/services/docker.scm | 167 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 274 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 617b8463e3..5c3908f758 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39349,6 +39349,114 @@ Miscellaneous Services
 @command{singularity run} and similar commands.
 @end defvar
 
+@cindex OCI-backed, Shepherd services
+@subsubheading OCI backed services
+
+Should you wish to manage your Docker containers with the same consistent
+interface you use for your other Shepherd services,
+@var{oci-container-service-type} is the tool to use: given an
+@acronym{Open Container Initiative, OCI} container image, it will run it in a
+Shepherd service.  One example where this is useful: it lets you run services
+that are available as Docker/OCI images but not yet packaged for Guix.
+
+@defvar oci-container-service-type
+
+This is a thin wrapper around Docker's CLI that executes OCI images backed
+processes as Shepherd Services.
+
+@lisp
+(simple-service 'oci-grafana-service
+                oci-container-service-type
+                (list
+                 (oci-container-configuration
+                  (image "prom/prometheus")
+                  (network "host")
+                  (ports
+                    '(("9000" . "9000")
+                      ("9090" . "9090"))))))
+                 (oci-container-configuration
+                  (image "grafana/grafana:10.0.1")
+                  (network "host")
+                  (ports
+                    '(("3000" . "3000")))
+                  (volumes
+                    '("/var/lib/grafana:/var/lib/grafana"))))))
+@end lisp
+
+In this example two different Shepherd services are going be added to the
+system.  Each @code{oci-container-configuration} record translates to a
+@code{docker run} invocation and its fields directly map to options.  You can
+refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run,upstream},
+documentation for the semantics of each value.  If the images are not found they
+will be
+@url{https://docs.docker.com/engine/reference/commandline/pull/,pulled}.  The
+spawned services are going to be attached to the host network and are supposed
+to behave like other processes.
+
+@end defvar
+
+@deftp {Data Type} oci-container-configuration
+Available @code{oci-container-configuration} fields are:
+
+@table @asis
+@item @code{command} (default: @code{()}) (type: list-of-strings)
+Overwrite the default command (@code{CMD}) of the image.
+
+@item @code{entrypoint} (default: @code{""}) (type: string)
+Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.
+
+@item @code{environment} (default: @code{()}) (type: list)
+Set environment variables. This can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '("LANGUAGE" . "eo:ca:eu")
+      "JAVA_HOME=/opt/java")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
+documentation for semantics.
+
+@item @code{image} (type: string)
+The image used to build the container. Images are resolved by the Docker Engine,
+and follow the usual format @code{myregistry.local:5000/testing/test-image:tag}.
+
+@item @code{name} (default: @code{""}) (type: string)
+Set a name for the spawned container.
+
+@item @code{network} (default: @code{""}) (type: string)
+Set a Docker network for the spawned container.
+
+@item @code{ports} (default: @code{()}) (type: list)
+Set the port or port ranges to expose from the spawned container. This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("8080" . "80")
+      "10443:443")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
+documentation for semantics.
+
+@item @code{volumes} (default: @code{()}) (type: list)
+Set volume mappings for the spawned container. This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("/root/data/grafana" . "/var/lib/grafana")
+      "/gnu/store:/gnu/store")
+@end lisp
+
+String are passed directly to the Docker CLI. You can refer to the
+@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
+documentation for semantics.
+
+@end table
+@end deftp
+
 @cindex Audit
 @subsubheading Auditd Service
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..af87001143 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,12 +33,30 @@ (define-module (gnu services docker)
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-name
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +235,149 @@ (define singularity-service-type
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+\f
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (match pair
+    (((? string? key) . (? string? value))
+     (string-append key delimiter value))
+    (_
+     (raise
+      (formatted-message
+       (G_ "pair members must contain only strings but ~a was found")
+       pair)))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (raise
+             (formatted-message
+              (G_ "~a members must be either a string or a pair but ~a was found!")
+              name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-configuration/no-serialization oci-container-configuration
+  (command
+   (list-of-strings '())
+   "Overwrite the default CMD of the image.")
+  (entrypoint
+   (string "")
+   "Overwrite the default ENTRYPOINT of the image.")
+  (environment
+   (list '())
+   "Set environment variables."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.")
+  (name
+   (string "")
+   "Set a name for the spawned container.")
+  (network
+   (string "")
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container."
+   (sanitizer oci-sanitize-volumes)))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(when (not (string-null? entrypoint))
+                          (list "--entrypoint" entrypoint))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(when (not (string-null? network))
+                          (list "--network" network))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (not (string-null? name))
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (config-name (oci-container-configuration-name config))
+         (image (oci-container-configuration-image config))
+         (name (guess-name config-name image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd user-processes))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command
+                                "run"
+                                "--rm"
+                                "--name" #$name
+                                #$@(oci-container-configuration->options config)
+                                #$(oci-container-configuration-image config)
+                                #$@(oci-container-configuration-command config))
+                          #:user "root"
+                          #:group "root"))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "stop" #$name))))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service allows the management of Docker and OCI
+containers as Shepherd services.")))

base-commit: f45c0c82289d409b4fac00464ea8b323839ba53f
-- 
2.41.0





^ permalink raw reply related	[relevance 41%]

* [bug#66160] [PATCH] gnu: Add oci-container-service-type.
  @ 2023-09-22 20:34 45% ` Giacomo Leidi via Guix-patches via
  2023-10-06 19:09 41% ` Giacomo Leidi via Guix-patches via
                   ` (4 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Giacomo Leidi via Guix-patches via @ 2023-09-22 20:34 UTC (permalink / raw)
  To: 66160; +Cc: Giacomo Leidi

* gnu/services/docker.scm (oci-container-configuration): New variable;
(oci-container-shepherd-service): new variable;
(oci-container-service-type): new variable.
* doc/guix.texi: Document it.
---
 doc/guix.texi           |  78 +++++++++++++++++++
 gnu/services/docker.scm | 163 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 240 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 617b8463e3..988ab64773 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -39349,6 +39349,84 @@ Miscellaneous Services
 @command{singularity run} and similar commands.
 @end defvar
 
+@cindex OCI-backed, Shepherd services
+@subsubheading OCI backed services
+
+Should you wish to manage your Docker containers with the same consistent
+interface you use for your other Shepherd services,
+@var{oci-container-service-type} is the tool to use.
+
+@defvar oci-container-service-type
+
+This is a thin wrapper around Docker's CLI that wraps OCI images backed
+processes as Shepherd Services.
+
+@lisp
+(simple-service 'oci-grafana-service
+                (list
+                 (oci-container-configuration
+                  (image "prom/prometheus")
+                  (network "host")
+                  (ports
+                    '(("9000" . "9000")
+                      ("9090" . "9090"))))))
+                 (oci-container-configuration
+                  (image "grafana/grafana:10.0.1")
+                  (network "host")
+                  (volumes
+                    '("/var/lib/grafana:/var/lib/grafana"))))))
+@end lisp
+
+@end defvar
+
+@deftp {Data Type} oci-container-configuration
+Available @code{oci-container-configuration} fields are:
+
+@table @asis
+@item @code{command} (default: @code{()}) (type: list-of-strings)
+Overwrite the default CMD of the image.
+
+@item @code{entrypoint} (default: @code{""}) (type: string)
+Overwrite the default ENTRYPOINT of the image.
+
+@item @code{environment} (default: @code{()}) (type: list)
+Set environment variables. This can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '("LANGUAGE" . "eo:ca:eu")
+      "JAVA_HOME=/opt/java")
+@end lisp
+
+@item @code{image} (type: string)
+The image used to build the container.
+
+@item @code{name} (default: @code{""}) (type: string)
+Set a name for the spawned container.
+
+@item @code{network} (default: @code{""}) (type: string)
+Set a Docker network for the spawned container.
+
+@item @code{ports} (default: @code{()}) (type: list)
+Set the port or port ranges to expose from the spawned container. This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("8080" . "80")
+      "10443:443")
+@end lisp
+
+@item @code{volumes} (default: @code{()}) (type: list)
+Set volume mappings for the spawned container. This can be a
+list of pairs or strings, even mixed:
+
+@lisp
+(list '("/root/data/grafana" . "/var/lib/grafana")
+      "/gnu/store:/gnu/store")
+@end lisp
+
+@end table
+@end deftp
+
 @cindex Audit
 @subsubheading Auditd Service
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index c2023d618c..8a4fa2107e 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -34,10 +35,25 @@ (define-module (gnu services docker)
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
 
   #:export (docker-configuration
             docker-service-type
-            singularity-service-type))
+            singularity-service-type
+            oci-container-configuration
+            oci-container-configuration?
+            oci-container-configuration-fields
+            oci-container-configuration-command
+            oci-container-configuration-entrypoint
+            oci-container-configuration-environment
+            oci-container-configuration-image
+            oci-container-configuration-name
+            oci-container-configuration-network
+            oci-container-configuration-ports
+            oci-container-configuration-volumes
+            oci-container-service-type
+            oci-container-shepherd-service))
 
 (define-configuration docker-configuration
   (docker
@@ -216,3 +232,148 @@ (define singularity-service-type
                        (service-extension activation-service-type
                                           (const %singularity-activation))))
                 (default-value singularity)))
+
+\f
+;;;
+;;; OCI container.
+;;;
+
+(define (oci-sanitize-pair pair delimiter)
+  (cond ((file-like? (car pair))
+         (file-append (car pair) delimiter (cdr pair)))
+        ((gexp? (car pair))
+         (file-append (car pair) delimiter (cdr pair)))
+        ((string? (car pair))
+         (string-append (car pair) delimiter (cdr pair)))
+        (else
+         (error
+          (format #f "pair members must only contain gexps, file-like objects and strings but ~a was found" (car pair))))))
+
+(define (oci-sanitize-mixed-list name value delimiter)
+  (map
+   (lambda (el)
+     (cond ((string? el) el)
+           ((pair? el) (oci-sanitize-pair el delimiter))
+           (else
+            (error
+             (format #f "~a members must be either a string or a pair but ~a was found!" name el)))))
+   value))
+
+(define (oci-sanitize-environment value)
+  ;; Expected spec format:
+  ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+  (oci-sanitize-mixed-list "environment" value "="))
+
+(define (oci-sanitize-ports value)
+  ;; Expected spec format:
+  ;; '(("8088" . "80") "2022:22")
+  (oci-sanitize-mixed-list "ports" value ":"))
+
+(define (oci-sanitize-volumes value)
+  ;; Expected spec format:
+  ;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
+  (oci-sanitize-mixed-list "volumes" value ":"))
+
+(define-configuration/no-serialization oci-container-configuration
+  (command
+   (list-of-strings '())
+   "Overwrite the default CMD of the image.")
+  (entrypoint
+   (string "")
+   "Overwrite the default ENTRYPOINT of the image.")
+  (environment
+   (list '())
+   "Set environment variables."
+   (sanitizer oci-sanitize-environment))
+  (image
+   (string)
+   "The image used to build the container.")
+  (name
+   (string "")
+   "Set a name for the spawned container.")
+  (network
+   (string "")
+   "Set a Docker network for the spawned container.")
+  (ports
+   (list '())
+   "Set the port or port ranges to expose from the spawned container."
+   (sanitizer oci-sanitize-ports))
+  (volumes
+   (list '())
+   "Set volume mappings for the spawned container."
+   (sanitizer oci-sanitize-volumes)))
+
+(define oci-container-configuration->options
+  (lambda (config)
+    (let ((entrypoint
+           (oci-container-configuration-entrypoint config))
+          (network
+           (oci-container-configuration-network config)))
+      (apply append
+             (filter (compose not unspecified?)
+                     `(,(when (not (string-null? entrypoint))
+                          (list "--entrypoint" entrypoint))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "--env" spec))
+                         (oci-container-configuration-environment config))
+                       ,(when (not (string-null? network))
+                          (list "--network" network))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-p" spec))
+                         (oci-container-configuration-ports config))
+                       ,(append-map
+                         (lambda (spec)
+                           (list "-v" spec))
+                         (oci-container-configuration-volumes config))))))))
+
+(define (oci-container-shepherd-service config)
+  (define (guess-name name image)
+    (if (not (string-null? name))
+        name
+        (string-append "docker-"
+                       (basename (car (string-split image #\:))))))
+
+  (let* ((docker-command (file-append docker-cli "/bin/docker"))
+         (config-name (oci-container-configuration-name config))
+         (image (oci-container-configuration-image config))
+         (name (guess-name config-name image)))
+
+    (shepherd-service (provision `(,(string->symbol name)))
+                      (requirement '(dockerd))
+                      (respawn? #f)
+                      (documentation
+                       (string-append
+                        "Docker backed Shepherd service for image: " image))
+                      (start
+                       #~(make-forkexec-constructor
+                          ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+                          (list #$docker-command
+                                "run"
+                                "--rm"
+                                "--name" #$name
+                                #$@(oci-container-configuration->options config)
+                                #$(oci-container-configuration-image config)
+                                #$@(oci-container-configuration-command config))
+                          #:user "root"
+                          #:group "root"))
+                      (stop
+                       #~(lambda _
+                           (invoke #$docker-command "stop" #$name))))))
+
+(define (configs->shepherd-services configs)
+  (map oci-container-shepherd-service configs))
+
+(define oci-container-service-type
+  (service-type (name 'oci-container)
+                (extensions (list (service-extension profile-service-type
+                                                     (lambda _ (list docker-cli)))
+                                  (service-extension shepherd-root-service-type
+                                                     configs->shepherd-services)))
+                (default-value '())
+                (extend append)
+                (compose concatenate)
+                (description
+                 "This service provides allows the management of Docker
+containers as Shepherd services.")))

base-commit: f45c0c82289d409b4fac00464ea8b323839ba53f
-- 
2.41.0





^ permalink raw reply related	[relevance 45%]

* [bug#64910] [PATCH v2 2/3] gnu: containerd: Update to 1.6.22.
  @ 2023-08-11 10:46 72% ` Hilton Chain via Guix-patches via
  2023-08-11 10:46 67% ` [bug#64910] [PATCH v2 3/3] gnu: docker: Update to 20.10.25 Hilton Chain via Guix-patches via
  1 sibling, 0 replies; 149+ results
From: Hilton Chain via Guix-patches via @ 2023-08-11 10:46 UTC (permalink / raw)
  To: 64910; +Cc: Hilton Chain

* gnu/packages/docker.scm (containerd): Update to 1.6.22.
[#:phases]<patch-paths>: Patch Runtime name.
---
 gnu/packages/docker.scm | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 0b2a18d661..3815824202 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -177,7 +177,7 @@ (define-public python-docker-pycreds
 (define-public containerd
   (package
     (name "containerd")
-    (version "1.6.6")
+    (version "1.6.22")
     (source
      (origin
        (method git-fetch)
@@ -186,7 +186,7 @@ (define-public containerd
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1vsl747i3wyy68j4lp4nprwxadbyga8qxlrk892afcd2990zp5mr"))
+        (base32 "1m31y00sq2m76m1jiq4znws8gxbgkh5adklvqibxiz1b96vvwjk8"))
        (patches
         (search-patches "containerd-create-pid-file.patch"))))
     (build-system go-build-system)
@@ -215,7 +215,12 @@ (define-public containerd
                     (("DefaultRuntimeName: \"runc\"")
                      (string-append "DefaultRuntimeName: \""
                                     (search-input-file inputs "/sbin/runc")
-                                    "\"")))
+                                    "\""))
+                    ;; ContainerdConfig.Runtimes
+                    (("\"runc\":")
+                     (string-append "\""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\":")))
                   (substitute* "vendor/github.com/containerd/go-runc/runc.go"
                     (("DefaultCommand[ \t]*=.*")
                      (string-append "DefaultCommand = \""
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#64910] [PATCH v2 3/3] gnu: docker: Update to 20.10.25.
    2023-08-11 10:46 72% ` [bug#64910] [PATCH v2 2/3] gnu: containerd: Update to 1.6.22 Hilton Chain via Guix-patches via
@ 2023-08-11 10:46 67% ` Hilton Chain via Guix-patches via
  1 sibling, 0 replies; 149+ results
From: Hilton Chain via Guix-patches via @ 2023-08-11 10:46 UTC (permalink / raw)
  To: 64910; +Cc: Hilton Chain

* gnu/packages/docker.scm (%docker-version): Update to 20.10.25.
(docker-libnetwork): Update to 20.10-2.3f00484.
(docker)[native-inputs]: Replace go with go-1.19.
---
 gnu/packages/docker.scm | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3815824202..3b809feb67 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -54,7 +54,7 @@ (define-module (gnu packages docker)
 
 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "20.10.17")
+(define %docker-version "20.10.25")
 
 (define-public python-docker
   (package
@@ -264,9 +264,9 @@ (define docker-libnetwork
   ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
   ;; source file.  NOTE - It is important that this version is kept in sync
   ;; with the version of Docker being used.
-  (let ((commit "f6ccccb1c082a432c2a5814aaedaca56af33d9ea")
+  (let ((commit "3f0048413d95802b9c6c836eba06bfc54f9dbd03")
         (version (version-major+minor %docker-version))
-        (revision "1"))
+        (revision "2"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -279,7 +279,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "0nxpr0h0smv4n641g41vxibr5r85ixfcvs9cp3c4fc7zvrhjc49s"))
+                  "185i5ji7dwkv41zmb8s3d7i5gg72wivcj1l4bhr1lb3a1vy2hcxc"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(delete-file-recursively "vendor"))))
@@ -330,7 +330,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0hn7fg717rggwk6dbicrwa7aglqp7dp0jp5rvn6p9gfcnrp2w97d"))))
+        (base32 "1q5vc6f5fzzxsvv1kwdky56fr1jiy9199m3vxqh4mz85qr067cmn"))))
     (build-system gnu-build-system)
     (arguments
      (list
@@ -591,7 +591,7 @@ (define-public docker
            xz))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
-           go gotestsum pkg-config))
+           go-1.19 gotestsum pkg-config))
     (synopsis "Container component library and daemon")
     (description "This package provides a framework to assemble specialized
 container systems.  It includes components for orchestration, image
@@ -612,7 +612,7 @@ (define-public docker-cli
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0ksicj4iqvgp9jabd4xmhkf3vax6dwn4f5dsr73bdqj4mf3ahav0"))))
+        (base32 "0qy35vvnl4lf9w6dr9n7yfqvzhzm7m3sl2ai275apbhygwgcsbss"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
-- 
2.41.0





^ permalink raw reply related	[relevance 67%]

* [bug#64910] [PATCH 3/3] gnu: docker: Update to 20.10.25.
    2023-07-28  3:13 72% ` [bug#64910] [PATCH 2/3] gnu: containerd: Update to 1.6.22 Hilton Chain via Guix-patches via
@ 2023-07-28  3:13 67% ` Hilton Chain via Guix-patches via
  1 sibling, 0 replies; 149+ results
From: Hilton Chain via Guix-patches via @ 2023-07-28  3:13 UTC (permalink / raw)
  To: 64910; +Cc: Hilton Chain

* gnu/packages/docker.scm (%docker-version): Update to 20.10.25.
(docker-libnetwork): Update to 20.10-2.3f00484.
(docker)[native-inputs]: Replace go with go-1.19.
---
 gnu/packages/docker.scm | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3fe7c6ca2c..f6c417187c 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -54,7 +54,7 @@ (define-module (gnu packages docker)
 
 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "20.10.17")
+(define %docker-version "20.10.25")
 
 (define-public python-docker
   (package
@@ -259,9 +259,9 @@ (define docker-libnetwork
   ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
   ;; source file.  NOTE - It is important that this version is kept in sync
   ;; with the version of Docker being used.
-  (let ((commit "f6ccccb1c082a432c2a5814aaedaca56af33d9ea")
+  (let ((commit "3f0048413d95802b9c6c836eba06bfc54f9dbd03")
         (version (version-major+minor %docker-version))
-        (revision "1"))
+        (revision "2"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -274,7 +274,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "0nxpr0h0smv4n641g41vxibr5r85ixfcvs9cp3c4fc7zvrhjc49s"))
+                  "185i5ji7dwkv41zmb8s3d7i5gg72wivcj1l4bhr1lb3a1vy2hcxc"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(delete-file-recursively "vendor"))))
@@ -325,7 +325,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0hn7fg717rggwk6dbicrwa7aglqp7dp0jp5rvn6p9gfcnrp2w97d"))))
+        (base32 "1q5vc6f5fzzxsvv1kwdky56fr1jiy9199m3vxqh4mz85qr067cmn"))))
     (build-system gnu-build-system)
     (arguments
      (list
@@ -586,7 +586,7 @@ (define-public docker
            xz))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
-           go gotestsum pkg-config))
+           go-1.19 gotestsum pkg-config))
     (synopsis "Container component library and daemon")
     (description "This package provides a framework to assemble specialized
 container systems.  It includes components for orchestration, image
@@ -607,7 +607,7 @@ (define-public docker-cli
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0ksicj4iqvgp9jabd4xmhkf3vax6dwn4f5dsr73bdqj4mf3ahav0"))))
+        (base32 "0qy35vvnl4lf9w6dr9n7yfqvzhzm7m3sl2ai275apbhygwgcsbss"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
-- 
2.41.0





^ permalink raw reply related	[relevance 67%]

* [bug#64910] [PATCH 2/3] gnu: containerd: Update to 1.6.22.
  @ 2023-07-28  3:13 72% ` Hilton Chain via Guix-patches via
  2023-07-28  3:13 67% ` [bug#64910] [PATCH 3/3] gnu: docker: Update to 20.10.25 Hilton Chain via Guix-patches via
  1 sibling, 0 replies; 149+ results
From: Hilton Chain via Guix-patches via @ 2023-07-28  3:13 UTC (permalink / raw)
  To: 64910; +Cc: Hilton Chain

* gnu/packages/docker.scm (containerd): Update to 1.6.22.
---
 gnu/packages/docker.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 0b2a18d661..3fe7c6ca2c 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -177,7 +177,7 @@ (define-public python-docker-pycreds
 (define-public containerd
   (package
     (name "containerd")
-    (version "1.6.6")
+    (version "1.6.22")
     (source
      (origin
        (method git-fetch)
@@ -186,7 +186,7 @@ (define-public containerd
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1vsl747i3wyy68j4lp4nprwxadbyga8qxlrk892afcd2990zp5mr"))
+        (base32 "1m31y00sq2m76m1jiq4znws8gxbgkh5adklvqibxiz1b96vvwjk8"))
        (patches
         (search-patches "containerd-create-pid-file.patch"))))
     (build-system go-build-system)
-- 
2.41.0





^ permalink raw reply related	[relevance 72%]

* [bug#62726] [PATCH v2] services: Activate `setuid-program-service-type' in shepherd.
    2023-04-08 15:16 45% ` [bug#62726] [PATCH] " Brian Cully via Guix-patches via
@ 2023-06-07 12:59 40% ` Brian Cully via Guix-patches via
  1 sibling, 0 replies; 149+ results
From: Brian Cully via Guix-patches via @ 2023-06-07 12:59 UTC (permalink / raw)
  To: 62726; +Cc: Brian Cully

Activate using a one-shot Shepherd service on boot, rather than attaching to
ACTIVATION-SERVICE-TYPE to populate `/run/setuid-programs'.

In order to prevent a dependency cycle between (gnu services) and (gnu
services shepherd), introduce a new module (gnu services setuid) and deprecate
the import of `setuid-program-service-type' from (gnu services).

Add the new SETUID-PROGRAMS Shepherd service to the extant Shepherd services
which need it, as well as USER-PROCESSES as a catch for things started later.

* gnu/local.mk (GNU_SYSTEM_MODULES): add setuid.scm.
* gnu/services.scm (setuid-program-service-type): removed.
* gnu/services/setuid.scm: new module.
* gnu/services/dbus.scm (gnu): import (gnu services setuid).
(dbus-shepherd-service): require SETUID-PROGRAMS.
* gnu/services/desktop.scm (gnu): import (gnu services setuid).
* gnu/services/docker.scm (gnu): import (gnu services setuid).
* gnu/services/mail.scm (gnu): import (gnu services setuid).
(<opensmtpd-configuration>): require SETUID-PROGRAMS.
* gnu/services/xorg.scm (gnu): import (gnu services setuid).
* gnu/system.scm (gnu): import (gnu services setuid).
* gnu/system/pam.scm (gnu): import (gnu services setuid).
(pam-root-service): require SETUID-PROGRAMS by default.
---
 gnu/local.mk             |  1 +
 gnu/services.scm         | 38 ---------------------------
 gnu/services/dbus.scm    |  3 ++-
 gnu/services/desktop.scm |  1 +
 gnu/services/docker.scm  |  1 +
 gnu/services/mail.scm    |  3 ++-
 gnu/services/setuid.scm  | 57 ++++++++++++++++++++++++++++++++++++++++
 gnu/services/xorg.scm    |  1 +
 gnu/system.scm           |  1 +
 gnu/system/pam.scm       |  5 +++-
 10 files changed, 70 insertions(+), 41 deletions(-)
 create mode 100644 gnu/services/setuid.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 9adf593318..6f9013056c 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -708,6 +708,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/rsync.scm			\
   %D%/services/samba.scm			\
   %D%/services/sddm.scm				\
+  %D%/services/setuid.scm			\
   %D%/services/spice.scm				\
   %D%/services/ssh.scm				\
   %D%/services/syncthing.scm			\
diff --git a/gnu/services.scm b/gnu/services.scm
index a990d297c9..a17f7dcee1 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -44,7 +44,6 @@ (define-module (gnu services)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages hurd)
-  #:use-module (gnu system setuid)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -111,7 +110,6 @@ (define-module (gnu services)
             extra-special-file
             etc-service-type
             etc-directory
-            setuid-program-service-type
             profile-service-type
             firmware-service-type
             gc-root-service-type
@@ -828,42 +826,6 @@ (define-deprecated (etc-service files)
 FILES must be a list of name/file-like object pairs."
   (service etc-service-type files))
 
-(define (setuid-program->activation-gexp programs)
-  "Return an activation gexp for setuid-program from PROGRAMS."
-  (let ((programs (map (lambda (program)
-                         ;; FIXME This is really ugly, I didn't managed to use
-                         ;; "inherit"
-                         (let ((program-name (setuid-program-program program))
-                               (setuid?      (setuid-program-setuid? program))
-                               (setgid?      (setuid-program-setgid? program))
-                               (user         (setuid-program-user program))
-                               (group        (setuid-program-group program)) )
-                           #~(setuid-program
-                              (setuid? #$setuid?)
-                              (setgid? #$setgid?)
-                              (user    #$user)
-                              (group   #$group)
-                              (program #$program-name))))
-                       programs)))
-    (with-imported-modules (source-module-closure
-                            '((gnu system setuid)))
-      #~(begin
-          (use-modules (gnu system setuid))
-
-          (activate-setuid-programs (list #$@programs))))))
-
-(define setuid-program-service-type
-  (service-type (name 'setuid-program)
-                (extensions
-                 (list (service-extension activation-service-type
-                                          setuid-program->activation-gexp)))
-                (compose concatenate)
-                (extend (lambda (config extensions)
-                          (append config extensions)))
-                (description
-                 "Populate @file{/run/setuid-programs} with the specified
-executables, making them setuid and/or setgid.")))
-
 (define (packages->profile-entry packages)
   "Return a system entry for the profile containing PACKAGES."
   ;; XXX: 'mlet' is needed here for one reason: to get the proper
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 5a0c634393..7f0deaa037 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -21,6 +21,7 @@
 
 (define-module (gnu services dbus)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
@@ -200,7 +201,7 @@ (define dbus-shepherd-service
      (list (shepherd-service
             (documentation "Run the D-Bus system daemon.")
             (provision '(dbus-system))
-            (requirement '(user-processes syslogd))
+            (requirement '(user-processes syslogd setuid-programs))
             (start #~(make-forkexec-constructor
                       (list (string-append #$dbus "/bin/dbus-daemon")
                             "--nofork" "--system" "--syslog-only")
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index a63748b652..f7a601ed47 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -33,6 +33,7 @@
 
 (define-module (gnu services desktop)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 741bab5a8c..32ed9739bf 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -26,6 +26,7 @@ (define-module (gnu services docker)
   #:use-module (gnu services configuration)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index 12dcc8e71d..3b001e091a 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -27,6 +27,7 @@ (define-module (gnu services mail)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu services configuration)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system shadow)
@@ -1655,7 +1656,7 @@ (define-record-type* <opensmtpd-configuration>
   (package     opensmtpd-configuration-package
                (default opensmtpd))
   (shepherd-requirement opensmtpd-configuration-shepherd-requirement
-                        (default '())) ; list of symbols
+                        (default '(setuid-programs))) ; list of symbols
   (config-file opensmtpd-configuration-config-file
                (default %default-opensmtpd-config-file))
   (setgid-commands? opensmtpd-setgid-commands? (default #t)))
diff --git a/gnu/services/setuid.scm b/gnu/services/setuid.scm
new file mode 100644
index 0000000000..00319aabdc
--- /dev/null
+++ b/gnu/services/setuid.scm
@@ -0,0 +1,57 @@
+(define-module (gnu services setuid)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (srfi srfi-1)
+  #:export (setuid-program-service-type))
+
+(define (setuid-programs->shepherd-service programs)
+  (let ((programs (map (lambda (program)
+                         ;; FIXME This is really ugly, I didn't managed to use
+                         ;; "inherit"
+                         (let ((program-name (setuid-program-program program))
+                               (setuid?      (setuid-program-setuid? program))
+                               (setgid?      (setuid-program-setgid? program))
+                               (user         (setuid-program-user program))
+                               (group        (setuid-program-group program)) )
+                           #~(setuid-program
+                              (setuid? #$setuid?)
+                              (setgid? #$setgid?)
+                              (user    #$user)
+                              (group   #$group)
+                              (program #$program-name))))
+                       programs)))
+    (with-imported-modules (source-module-closure
+                            '((gnu system setuid)
+                              (gnu build activation)))
+      (list (shepherd-service
+             (documentation "Populate @file{/run/setuid-programs}.")
+             (provision '(setuid-programs))
+             ;; TODO: actually need to require account service. maybe user-homes
+             ;; as a proxy?
+             (requirement '(file-systems))
+             (one-shot? #t)
+             (modules '((gnu system setuid)
+                        (gnu build activation)))
+             (start #~(lambda ()
+                        (activate-setuid-programs (list #$@programs))
+                        #t)))))))
+
+(define setuid-program-service-type
+  (service-type (name 'setuid-program)
+                (extensions
+                 (list
+                  (service-extension shepherd-root-service-type
+                                     setuid-programs->shepherd-service)
+                  ;; Ensure that setuid programs are set up by the time they
+                  ;; might be needed by user-configured processes and daemons.
+                  (service-extension user-processes-service-type
+                                     (const '(setuid-programs)))))
+                (compose concatenate)
+                (extend append)
+                (default-value '())
+                (description
+                 "Populate @file{/run/setuid-programs} with the specified
+executables, making them setuid and/or setgid.")))
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index f8cf9f25b6..efcaa52754 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -35,6 +35,7 @@ (define-module (gnu services xorg)
   #:use-module (gnu artwork)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system setuid)
diff --git a/gnu/system.scm b/gnu/system.scm
index 354f58f55b..5f834dd8b6 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -67,6 +67,7 @@ (define-module (gnu system)
   #:use-module (gnu packages text-editors)
   #:use-module (gnu packages wget)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
   #:use-module (gnu bootloader)
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index a035a92e25..4c62e130de 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@@ -24,6 +24,7 @@ (define-module (gnu system pam)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (ice-9 match)
@@ -443,7 +444,9 @@ (define pam-root-service-type
 program may authenticate users or what it should do when opening a new
 session.")))
 
-(define* (pam-root-service base #:key (transformers '()) (shepherd-requirements '()))
+(define* (pam-root-service base
+                           #:key (transformers '())
+                           (shepherd-requirements '(setuid-programs)))
   "The \"root\" PAM service, which collects <pam-service> instance and turns
 them into a /etc/pam.d directory, including the <pam-service> listed in BASE.
 TRANSFORM is a procedure that takes a <pam-service> and returns a

base-commit: 940665301de4effd065d24c167f619286f2adf4c
-- 
2.40.1





^ permalink raw reply related	[relevance 40%]

* [bug#62153] [PATCH v4 1/2] guix: docker: Build layered image.
  @ 2023-06-03 19:14 35% ` Oleg Pykhalov
  0 siblings, 0 replies; 149+ results
From: Oleg Pykhalov @ 2023-06-03 19:14 UTC (permalink / raw)
  To: 62153; +Cc: Oleg Pykhalov, Greg Hogan

* doc/guix.texi (Invoking guix pack): Document docker-layered format.
(image Reference): Same.
(image-type Reference): Document docker-layered-image-type.
* gnu/image.scm
(validate-image-format)[docker-layered]: New image format.
* gnu/system/image.scm
(docker-layered-image, docker-layered-image-type): New variables.
(system-docker-image)[layered-image?]: New argument.
(system-docker-layered-image): New procedure.
(image->root-file-system)[docker-layered]: New image format.
* gnu/tests/docker.scm (%test-docker-layered-system): New test.
* guix/docker.scm (%docker-image-max-layers): New variable.
(build-docker-image)[stream-layered-image, root-system]: New arguments.
* guix/scripts/pack.scm (stream-layered-image.py): New variable.
(docker-image)[layered-image?]: New argument.
(docker-layered-image): New procedure.
(%formats)[docker-layered]: New format.
(show-formats): Document this.
* guix/scripts/system.scm
(system-derivation-for-action)[docker-layered-image]: New action.
(show-help): Document this.
(actions)[docker-layered-image]: New action.
(process-action): Add this.
* tests/pack.scm: Add "docker-layered-image + localstatedir" test.
---
 doc/guix.texi           |  18 +++-
 gnu/image.scm           |   3 +-
 gnu/system/image.scm    |  76 +++++++++++----
 gnu/tests/docker.scm    |  20 +++-
 guix/docker.scm         | 208 +++++++++++++++++++++++++++++++---------
 guix/scripts/pack.scm   |  62 ++++++++++--
 guix/scripts/system.scm |  11 ++-
 tests/pack.scm          |  48 ++++++++++
 8 files changed, 369 insertions(+), 77 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7f8d8d66e9..483be6ef16 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -56,7 +56,7 @@
 Copyright @copyright{} 2017, 2018, 2019, 2020 Arun Isaac@*
 Copyright @copyright{} 2017 nee@*
 Copyright @copyright{} 2018 Rutger Helling@*
-Copyright @copyright{} 2018, 2021 Oleg Pykhalov@*
+Copyright @copyright{} 2018, 2021, 2023 Oleg Pykhalov@*
 Copyright @copyright{} 2018 Mike Gerwitz@*
 Copyright @copyright{} 2018 Pierre-Antoine Rouby@*
 Copyright @copyright{} 2018, 2019 Gábor Boskovits@*
@@ -6984,9 +6984,15 @@ Invoking guix pack
 guix pack -f docker -S /bin=bin guile guile-readline
 @end example
 
+or
+
+@example
+guix pack -f docker-layered -S /bin=bin guile guile-readline
+@end example
+
 @noindent
-The result is a tarball that can be passed to the @command{docker load}
-command, followed by @code{docker run}:
+The result is a tarball with image or layered image that can be passed
+to the @command{docker load} command, followed by @code{docker run}:
 
 @example
 docker load < @var{file}
@@ -44347,6 +44353,8 @@ image Reference
 
 @item @code{docker}, a Docker image.
 
+@item @code{docker-layered}, a layered Docker image.
+
 @item @code{iso9660}, an ISO-9660 image.
 
 @item @code{tarball}, a tar.gz image archive.
@@ -44682,6 +44690,10 @@ image-type Reference
 Build an image based on the @code{docker-image} image.
 @end defvar
 
+@defvar docker-layered-image-type
+Build a layered image based on the @code{docker-layered-image} image.
+@end defvar
+
 @defvar raw-with-offset-image-type
 Build an MBR image with a single partition starting at a @code{1024KiB}
 offset.  This is useful to leave some room to install a bootloader in
diff --git a/gnu/image.scm b/gnu/image.scm
index 523653dd77..8a6a0d8479 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -152,7 +153,7 @@ (define-syntax-rule (define-set-sanitizer name field set)
 
 ;; The supported image formats.
 (define-set-sanitizer validate-image-format format
-  (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
+  (disk-image compressed-qcow2 docker docker-layered iso9660 tarball wsl2))
 
 ;; The supported partition table types.
 (define-set-sanitizer validate-partition-table-type partition-table-type
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index afef79185f..3a502f19ec 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -78,6 +79,7 @@ (define-module (gnu system image)
             efi-disk-image
             iso9660-image
             docker-image
+            docker-layered-image
             tarball-image
             wsl2-image
             raw-with-offset-disk-image
@@ -89,6 +91,7 @@ (define-module (gnu system image)
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            docker-layered-image-type
             tarball-image-type
             wsl2-image-type
             raw-with-offset-image-type
@@ -167,6 +170,10 @@ (define docker-image
   (image-without-os
    (format 'docker)))
 
+(define docker-layered-image
+  (image-without-os
+   (format 'docker-layered)))
+
 (define tarball-image
   (image-without-os
    (format 'tarball)))
@@ -237,6 +244,11 @@ (define docker-image-type
    (name 'docker)
    (constructor (cut image-with-os docker-image <>))))
 
+(define docker-layered-image-type
+  (image-type
+   (name 'docker-layered)
+   (constructor (cut image-with-os docker-layered-image <>))))
+
 (define tarball-image-type
   (image-type
    (name 'tarball)
@@ -633,9 +645,12 @@ (define (image-with-label base-image label)
 
 (define* (system-docker-image image
                               #:key
-                              (name "docker-image"))
+                              (name "docker-image")
+                              (archiver tar)
+                              layered-image?)
   "Build a docker image for IMAGE.  NAME is the base name to use for the
-output file."
+output file.  If LAYERED-IMAGE? is true, the image will with many of the store
+paths being on their own layer to improve sharing between images."
   (define boot-program
     ;; Program that runs the boot script of OS, which in turn starts shepherd.
     (program-file "boot-program"
@@ -678,9 +693,11 @@ (define* (system-docker-image image
               (use-modules (guix docker)
                            (guix build utils)
                            (gnu build image)
+                           (srfi srfi-1)
                            (srfi srfi-19)
                            (guix build store-copy)
-                           (guix store database))
+                           (guix store database)
+                           (ice-9 receive))
 
               ;; Set the SQL schema location.
               (sql-schema #$schema)
@@ -700,18 +717,31 @@ (define* (system-docker-image image
                                            #:register-closures? #$register-closures?
                                            #:deduplicate? #f
                                            #:system-directory #$os)
-                (build-docker-image
-                 #$output
-                 (cons* image-root
-                        (map store-info-item
-                             (call-with-input-file #$graph
-                               read-reference-graph)))
-                 #$os
-                 #:entry-point '(#$boot-program #$os)
-                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-                 #:creation-time (make-time time-utc 0 1)
-                 #:system #$image-target
-                 #:transformations `((,image-root -> ""))))))))
+                (when #$layered-image?
+                  (setenv "PATH"
+                          (string-join (list #+(file-append archiver "/bin")
+                                             #+(file-append coreutils "/bin")
+                                             #+(file-append gzip "/bin"))
+                                       ":")))
+                (apply build-docker-image
+                       (append (list #$output
+                                     (append (if #$layered-image?
+                                                 '()
+                                                 (list image-root))
+                                             (map store-info-item
+                                                  (call-with-input-file #$graph
+                                                    read-reference-graph)))
+                                     #$os
+                                     #:entry-point '(#$boot-program #$os)
+                                     #:compressor
+                                     '(#+(file-append gzip "/bin/gzip") "-9n")
+                                     #:creation-time (make-time time-utc 0 1)
+                                     #:system #$image-target
+                                     #:transformations `((,image-root -> "")))
+                               (if #$layered-image?
+                                   (list #:root-system image-root
+                                         #:layered-image? #$layered-image?)
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
@@ -720,6 +750,18 @@ (define* (system-docker-image image
                    #:options `(#:references-graphs ((,graph ,os))
                                #:substitutable? ,substitutable?))))
 
+(define* (system-docker-layered-image image
+                                      #:key
+                                      (name "docker-image")
+                                      (archiver tar)
+                                      (layered-image? #t))
+  "Build a docker image for IMAGE.  NAME is the base name to use for the
+output file."
+  (system-docker-image image
+                       #:name name
+                       #:archiver archiver
+                       #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Tarball image.
@@ -811,7 +853,7 @@ (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker tarball wsl2) "dummy")
+    ((docker docker-layered tarball wsl2) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -948,6 +990,8 @@ (define* (system-image image)
                                        ("bootcfg" ,bootcfg))))
        ((memq image-format '(docker))
         (system-docker-image image*))
+       ((memq image-format '(docker-layered))
+        (system-docker-layered-image image*))
        ((memq image-format '(tarball))
         (system-tarball-image image*))
        ((memq image-format '(wsl2))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index edc9804414..0cccc02ad2 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,7 +44,8 @@ (define-module (gnu tests docker)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (%test-docker
-            %test-docker-system))
+            %test-docker-system
+            %test-docker-layered-system))
 
 (define %docker-os
   (simple-operating-system
@@ -316,3 +318,19 @@ (define %test-docker-system
                                    (locale-libcs (list glibc)))
                                  #:type docker-image-type)))
                  run-docker-system-test)))))
+
+(define %test-docker-layered-system
+  (system-test
+   (name "docker-layered-system")
+   (description "Run a system image as produced by @command{guix system
+docker-layered-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (lower-object
+                  (system-image (os->image
+                                 (operating-system
+                                   (inherit (simple-operating-system))
+                                   ;; Use locales for a single libc to
+                                   ;; reduce space requirements.
+                                   (locale-libcs (list glibc)))
+                                 #:type docker-layered-image-type)))
+                 run-docker-system-test)))))
diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..b40cfb2374 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,8 @@ (define-module (guix docker)
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-1)
@@ -38,6 +41,9 @@ (define-module (guix docker)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
   #:export (build-docker-image))
 
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
@@ -92,12 +98,12 @@ (define (canonicalize-repository-name name)
                       (make-string (- min-length l) padding-character)))
       (_ normalized-name))))
 
-(define* (manifest path id #:optional (tag "guix"))
+(define* (manifest path layers #:optional (tag "guix"))
   "Generate a simple image manifest."
   (let ((tag (canonicalize-repository-name tag)))
     `#(((Config . "config.json")
         (RepoTags . #(,(string-append tag ":latest")))
-        (Layers . #(,(string-append id "/layer.tar")))))))
+        (Layers . ,(list->vector layers))))))
 
 ;; According to the specifications this is required for backwards
 ;; compatibility.  It duplicates information provided by the manifest.
@@ -106,8 +112,8 @@ (define* (repositories path id #:optional (tag "guix"))
   `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define* (config layer time arch #:key entry-point (environment '()))
-  "Generate a minimal image configuration for the given LAYER file."
+(define* (config layers-diff-ids time arch #:key entry-point (environment '()))
+  "Generate a minimal image configuration for the given LAYERS files."
   ;; "architecture" must be values matching "platform.arch" in the
   ;; runtime-spec at
   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
@@ -125,7 +131,7 @@ (define* (config layer time arch #:key entry-point (environment '()))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
-               (diff_ids . #(,(layer-diff-id layer)))))))
+               (diff_ids . ,(list->vector layers-diff-ids))))))
 
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
@@ -136,6 +142,37 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define %docker-image-max-layers
+  100)
+
+(define (paths-split-sort paths)
+  "Split list of PATHS at %DOCKER-IMAGE-MAX-LAYERS and sort by disk usage."
+  (let* ((paths-length (length paths))
+         (port (apply open-pipe* OPEN_READ
+                      (append '("du" "--summarize") paths)))
+         (output (read-string port)))
+    (close-port port)
+    (receive (head tail)
+        (split-at
+         (map (match-lambda ((size . path) path))
+              (sort (map (lambda (line)
+                           (match (string-split line #\tab)
+                             ((size path)
+                              (cons (string->number size) path))))
+                         (string-split
+                          (string-trim-right output #\newline)
+                          #\newline))
+                    (lambda (path1 path2)
+                      (< (match path2 ((size . _) size))
+                         (match path1 ((size . _) size))))))
+         (if (>= paths-length %docker-image-max-layers)
+             (- %docker-image-max-layers 2)
+             (1- paths-length)))
+      (list head tail))))
+
+(define (create-empty-tar file)
+  (invoke "tar" "-cf" file "--files-from" "/dev/null"))
+
 (define* (build-docker-image image paths prefix
                              #:key
                              (repository "guix")
@@ -146,11 +183,13 @@ (define* (build-docker-image image paths prefix
                              entry-point
                              (environment '())
                              compressor
-                             (creation-time (current-time time-utc)))
-  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
-must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
-is a descriptive name that will show up in \"REPOSITORY\" column of the output
-of \"docker images\".
+                             (creation-time (current-time time-utc))
+                             layered-image?
+                             root-system)
+  "Write to IMAGE a layerer Docker image archive containing the given PATHS.
+PREFIX must be a store path that is a prefix of any store paths in PATHS.
+REPOSITORY is a descriptive name that will show up in \"REPOSITORY\" column of
+the output of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -172,7 +211,14 @@ (define* (build-docker-image image paths prefix
 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 PATHS 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."
+SRFI-19 time-utc object, as the creation time in metadata.
+
+When LAYERED-IMAGE? is true build layered image, providing a Docker
+image with many of the store paths being on their own layer to improve sharing
+between images.
+
+ROOT-SYSTEM is a directory with a provisioned root file system, which will be
+added to image as a layer."
   (define (sanitize path-fragment)
     (escape-special-chars
      ;; GNU tar strips the leading slash off of absolute paths before applying
@@ -203,6 +249,53 @@ (define* (build-docker-image image paths prefix
     (if (eq? '() transformations)
         '()
         `("--transform" ,(transformations->expression transformations))))
+  (define layers-hashes
+    (match-lambda
+      (((head ...) (tail ...) id)
+       (create-empty-tar "image.tar")
+       (let* ((head-layers
+               (map
+                (lambda (file)
+                  (invoke "tar" "cf" "layer.tar" file)
+                  (let* ((file-hash (layer-diff-id "layer.tar"))
+                         (file-name (string-append file-hash "/layer.tar")))
+                    (mkdir file-hash)
+                    (rename-file "layer.tar" file-name)
+                    (invoke "tar" "-rf" "image.tar" file-name)
+                    (delete-file file-name)
+                    file-hash))
+                head))
+              (tail-layer
+               (begin
+                 (create-empty-tar "layer.tar")
+                 (for-each (lambda (file)
+                             (invoke "tar" "-rf" "layer.tar" file))
+                           tail)
+                 (let* ((file-hash (layer-diff-id "layer.tar"))
+                        (file-name (string-append file-hash "/layer.tar")))
+                   (mkdir file-hash)
+                   (rename-file "layer.tar" file-name)
+                   (invoke "tar" "-rf" "image.tar" file-name)
+                   (delete-file file-name)
+                   file-hash)))
+              (customization-layer
+               (let* ((file-id (string-append id "/layer.tar"))
+                      (file-hash (layer-diff-id file-id))
+                      (file-name (string-append file-hash "/layer.tar")))
+                 (mkdir file-hash)
+                 (rename-file file-id file-name)
+                 (invoke "tar" "-rf" "image.tar" file-name)
+                 file-hash))
+              (all-layers
+               (append head-layers (list tail-layer customization-layer))))
+         (with-output-to-file "manifest.json"
+           (lambda ()
+             (scm->json (manifest prefix
+                                  (map (cut string-append <> "/layer.tar")
+                                       all-layers)
+                                  repository))))
+         (invoke "tar" "-rf" "image.tar" "manifest.json")
+         all-layers))))
   (let* ((directory "/tmp/docker-image") ;temporary working directory
          (id (docker-id prefix))
          (time (date->string (time-utc->date creation-time) "~4"))
@@ -229,26 +322,39 @@ (define* (build-docker-image image paths prefix
         (with-output-to-file "json"
           (lambda () (scm->json (image-description id time))))
 
-        ;; Create a directory for the non-store files that need to go into the
-        ;; archive.
-        (mkdir "extra")
+        (if root-system
+            (let ((directory (getcwd)))
+              (with-directory-excursion root-system
+                (apply invoke "tar"
+                       "-cf" (string-append directory "/layer.tar")
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." "..")))))))))
+            (begin
+              ;; Create a directory for the non-store files that need to go
+              ;; into the archive.
+              (mkdir "extra")
 
-        (with-directory-excursion "extra"
-          ;; Create non-store files.
-          (for-each (cut evaluate-populate-directive <> "./")
-                    extra-files)
+              (with-directory-excursion "extra"
+                ;; Create non-store files.
+                (for-each (cut evaluate-populate-directive <> "./")
+                          extra-files)
 
-          (when database
-            ;; Initialize /var/guix, assuming PREFIX points to a profile.
-            (install-database-and-gc-roots "." database prefix))
+                (when database
+                  ;; Initialize /var/guix, assuming PREFIX points to a
+                  ;; profile.
+                  (install-database-and-gc-roots "." database prefix))
 
-          (apply invoke "tar" "-cf" "../layer.tar"
-                 `(,@transformation-options
-                   ,@(tar-base-options)
-                   ,@paths
-                   ,@(scandir "."
-                              (lambda (file)
-                                (not (member file '("." ".."))))))))
+                (apply invoke "tar" "-cf" "../layer.tar"
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(if layered-image? '() paths)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." ".."))))))))
+              (delete-file-recursively "extra")))
 
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -261,24 +367,36 @@ (define* (build-docker-image image paths prefix
         ;; error messages.
         (with-error-to-port (%make-void-port "w")
           (lambda ()
-            (system* "tar" "--delete" "/" "-f" "layer.tar")))
-
-        (delete-file-recursively "extra"))
+            (system* "tar" "--delete" "/" "-f" "layer.tar"))))
 
       (with-output-to-file "config.json"
         (lambda ()
-          (scm->json (config (string-append id "/layer.tar")
-                             time arch
-                             #:environment environment
-                             #:entry-point entry-point))))
-      (with-output-to-file "manifest.json"
-        (lambda ()
-          (scm->json (manifest prefix id repository))))
-      (with-output-to-file "repositories"
-        (lambda ()
-          (scm->json (repositories prefix id repository)))))
-
-    (apply invoke "tar" "-cf" image "-C" directory
-           `(,@(tar-base-options #:compressor compressor)
-             "."))
+          (scm->json
+           (config (if layered-image?
+                       (layers-hashes (append (paths-split-sort paths)
+                                              (list id)))
+                       (list (layer-diff-id (string-append id "/layer.tar"))))
+                   time arch
+                   #:environment environment
+                   #:entry-point entry-point))))
+      (if layered-image?
+          (begin
+            (invoke "tar" "-rf" "image.tar" "config.json")
+            (if compressor
+                (begin
+                  (apply invoke `(,@compressor "image.tar"))
+                  (copy-file "image.tar.gz" image))
+                (copy-file "image.tar" image)))
+          (begin
+            (with-output-to-file "manifest.json"
+              (lambda ()
+                (scm->json (manifest prefix
+                                     (list (string-append id "/layer.tar"))
+                                     repository))))
+            (with-output-to-file "repositories"
+              (lambda ()
+                (scm->json (repositories prefix id repository))))
+            (apply invoke "tar" "-cf" image
+                   `(,@(tar-base-options #:compressor compressor)
+                     ".")))))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0dc9979194..3fefd2eac3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@ (define-module (guix scripts pack)
   #:use-module (guix scripts)
   #:use-module (guix ui)
   #:use-module (guix gexp)
+  #:use-module ((guix build utils) #:select (%xz-parallel-args))
   #:use-module (guix utils)
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -53,6 +55,8 @@ (define-module (guix scripts pack)
   #:use-module ((gnu packages compression) #:hide (zip))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages shells)
+  #:autoload   (gnu packages package-management) (guix)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
   #:use-module (srfi srfi-1)
@@ -67,6 +71,7 @@ (define-module (guix scripts pack)
             debian-archive
             rpm-archive
             docker-image
+            docker-layered-image
             squashfs-image
 
             %formats
@@ -597,12 +602,14 @@ (define* (docker-image name profile
                        localstatedir?
                        (symlinks '())
                        (archiver tar)
-                       (extra-options '()))
+                       (extra-options '())
+                       layered-image?)
   "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."
+the image.  If LAYERED-IMAGE? is true, the image will with many of the
+store paths being on their own layer to improve sharing between images."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -653,7 +660,13 @@ (define* (docker-image name profile
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if layered-image?
+                                          (list (file-append coreutils "/bin")
+                                                (file-append gzip "/bin"))
+                                          '()))
+                                 ":"))
 
             (build-docker-image #$output
                                 (map store-info-item
@@ -671,7 +684,8 @@ (define* (docker-image name profile
                                                               #$entry-point)))
                                 #:extra-files directives
                                 #:compressor #+(compressor-command compressor)
-                                #:creation-time (make-time time-utc 0 1))))))
+                                #:creation-time (make-time time-utc 0 1)
+                                #:layered-image? #$layered-image?)))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -679,6 +693,33 @@ (define* (docker-image name profile
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (docker-layered-image name profile
+                               #:key target
+                               (profile-name "guix-profile")
+                               (compressor (first %compressors))
+                               entry-point
+                               localstatedir?
+                               (symlinks '())
+                               (archiver tar)
+                               (extra-options '())
+                               (layered-image? #t))
+  "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.  If LAYERED-IMAGE? is true, the image will with many of the store paths
+being on their own layer to improve sharing between images."
+  (docker-image name profile
+                #:target target
+                #:profile-name profile-name
+                #:compressor compressor
+                #:entry-point entry-point
+                #:localstatedir? localstatedir?
+                #:symlinks symlinks
+                #:archiver archiver
+                #:extra-options extra-options
+                #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Debian archive format.
@@ -1353,6 +1394,7 @@ (define %formats
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)
+    (docker-layered  . ,docker-layered-image)
     (deb . ,debian-archive)
     (rpm . ,rpm-archive)))
 
@@ -1361,15 +1403,17 @@ (define (show-formats)
   (display (G_ "The supported formats for 'guix pack' are:"))
   (newline)
   (display (G_ "
-  tarball       Self-contained tarball, ready to run on another machine"))
+  tarball        Self-contained tarball, ready to run on another machine"))
+  (display (G_ "
+  squashfs       Squashfs image suitable for Singularity"))
   (display (G_ "
-  squashfs      Squashfs image suitable for Singularity"))
+  docker         Tarball ready for 'docker load'"))
   (display (G_ "
-  docker        Tarball ready for 'docker load'"))
+  docker-layered Tarball with a layered image ready for 'docker load'"))
   (display (G_ "
-  deb           Debian archive installable via dpkg/apt"))
+  deb            Debian archive installable via dpkg/apt"))
   (display (G_ "
-  rpm           RPM archive installable via rpm/yum"))
+  rpm            RPM archive installable via rpm/yum"))
   (newline))
 
 (define (required-option symbol)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index d7163dd3eb..e4bf0347c7 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -11,6 +11,7 @@
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -727,13 +728,15 @@ (define* (system-derivation-for-action image action
                                               #:graphic? graphic?
                                               #:disk-image-size image-size
                                               #:mappings mappings))
-      ((image disk-image vm-image docker-image)
+      ((image disk-image vm-image docker-image docker-layered-image)
        (when (eq? action 'disk-image)
          (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'vm-image)
          (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'docker-image)
          (warning (G_ "'docker-image' is deprecated: use 'image' instead~%")))
+       (when (eq? action 'docker-layered-image)
+         (warning (G_ "'docker-layered-image' is deprecated: use 'image' instead~%")))
        (lower-object (system-image image))))))
 
 (define (maybe-suggest-running-guix-pull)
@@ -980,6 +983,8 @@ (define (show-help)
    image            build a Guix System image\n"))
   (display (G_ "\
    docker-image     build a Docker image\n"))
+  (display (G_ "\
+   docker-layered-image build a Docker layered image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1193,7 +1198,7 @@ (define actions '("build" "container" "vm" "vm-image" "image" "disk-image"
                   "list-generations" "describe"
                   "delete-generations" "roll-back"
                   "switch-generation" "search" "edit"
-                  "docker-image"))
+                  "docker-image" "docker-layered-image"))
 
 (define (process-action action args opts)
   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
@@ -1242,6 +1247,8 @@ (define (process-action action args opts)
          (image       (let* ((image-type (case action
                                            ((vm-image) qcow2-image-type)
                                            ((docker-image) docker-image-type)
+                                           ((docker-layered-image)
+                                            docker-layered-image-type)
                                            (else image-type)))
                             (image-size (assoc-ref opts 'image-size))
                             (volatile?
diff --git a/tests/pack.scm b/tests/pack.scm
index ce5a2f8a53..432ab1b2ea 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (test-pack)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (%store-directory))
   #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
   #:use-module (gnu packages bootstrap)
@@ -250,6 +252,52 @@ (define rpm-for-tests
                           (mkdir #$output)))))))
       (built-derivations (list check))))
 
+  (unless store (test-skip 1))
+  (test-assertm "docker-layered-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile)))
+                      (hooks '())
+                      (locales? #f)))
+         (tarball (docker-layered-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #:localstatedir? #t))
+         (check   (gexp->derivation "check-tarball"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils)
+                                       (ice-9 match))
+
+                          (define bin
+                            (string-append "." #$profile "/bin"))
+
+                          (define store
+                            (string-append "." #$(%store-directory)))
+
+                          (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+                          (mkdir "base")
+                          (with-directory-excursion "base"
+                            (invoke "tar" "xvf" #$tarball))
+
+                          (match (find-files "base" "layer.tar")
+                            ((layers ...)
+                             (for-each (lambda (layer)
+                                         (invoke "tar" "xvf" layer)
+                                         (invoke "chmod" "--recursive" "u+w" store))
+                                       layers)))
+
+                          (when
+                              (and (file-exists? (string-append bin "/guile"))
+                                   (file-exists? "var/guix/db/db.sqlite")
+                                   (file-is-directory? "tmp")
+                                   (string=? (string-append #$%bootstrap-guile "/bin")
+                                             (pk 'binlink (readlink bin)))
+                                   (string=? (string-append #$profile "/bin/guile")
+                                             (pk 'guilelink (readlink "bin/Guile"))))
+                            (mkdir #$output)))))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "squashfs-image + localstatedir" store
     (mlet* %store-monad

base-commit: 66c9b82fed3c59ee07187898592c688c82fed273
-- 
2.38.0





^ permalink raw reply related	[relevance 35%]

* [bug#62153] [PATCH] guix: docker: Build layered image.
  @ 2023-05-31  8:47 35% ` Oleg Pykhalov
  0 siblings, 0 replies; 149+ results
From: Oleg Pykhalov @ 2023-05-31  8:47 UTC (permalink / raw)
  To: 62153; +Cc: Oleg Pykhalov

* doc/guix.texi (Invoking guix pack): Document docker-layered format.
(image Reference): Same.
(image-type Reference): Document docker-layered-image-type.
* gnu/image.scm
(validate-image-format)[docker-layered]: New image format.
* gnu/system/image.scm
(docker-layered-image, docker-layered-image-type): New variables.
(system-docker-image)[layered-image?]: New argument.
(system-docker-layered-image): New procedure.
(image->root-file-system)[docker-layered]: New image format.
* gnu/tests/docker.scm (%test-docker-layered-system): New test.
* guix/docker.scm (%docker-image-max-layers): New variable.
(build-docker-image)[stream-layered-image, root-system]: New arguments.
* guix/scripts/pack.scm (stream-layered-image.py): New variable.
(docker-image)[layered-image?]: New argument.
(docker-layered-image): New procedure.
(%formats)[docker-layered]: New format.
(show-formats): Document this.
* guix/scripts/system.scm
(system-derivation-for-action)[docker-layered-image]: New action.
(show-help): Document this.
(actions)[docker-layered-image]: New action.
(process-action): Add this.
* tests/pack.scm: Add "docker-layered-image + localstatedir" test.
---
 doc/guix.texi           |  18 +++-
 gnu/image.scm           |   3 +-
 gnu/system/image.scm    |  76 +++++++++++----
 gnu/tests/docker.scm    |  20 +++-
 guix/docker.scm         | 205 +++++++++++++++++++++++++++++++---------
 guix/scripts/pack.scm   |  62 ++++++++++--
 guix/scripts/system.scm |  11 ++-
 tests/pack.scm          |  48 ++++++++++
 8 files changed, 366 insertions(+), 77 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 5fd2449ed5..1c95ec4320 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -56,7 +56,7 @@
 Copyright @copyright{} 2017, 2018, 2019, 2020 Arun Isaac@*
 Copyright @copyright{} 2017 nee@*
 Copyright @copyright{} 2018 Rutger Helling@*
-Copyright @copyright{} 2018, 2021 Oleg Pykhalov@*
+Copyright @copyright{} 2018, 2021, 2023 Oleg Pykhalov@*
 Copyright @copyright{} 2018 Mike Gerwitz@*
 Copyright @copyright{} 2018 Pierre-Antoine Rouby@*
 Copyright @copyright{} 2018, 2019 Gábor Boskovits@*
@@ -6984,9 +6984,15 @@ Invoking guix pack
 guix pack -f docker -S /bin=bin guile guile-readline
 @end example
 
+or
+
+@example
+guix pack -f docker-layered -S /bin=bin guile guile-readline
+@end example
+
 @noindent
-The result is a tarball that can be passed to the @command{docker load}
-command, followed by @code{docker run}:
+The result is a tarball with image or layered image that can be passed
+to the @command{docker load} command, followed by @code{docker run}:
 
 @example
 docker load < @var{file}
@@ -44309,6 +44315,8 @@ image Reference
 
 @item @code{docker}, a Docker image.
 
+@item @code{docker-layered}, a layered Docker image.
+
 @item @code{iso9660}, an ISO-9660 image.
 
 @item @code{tarball}, a tar.gz image archive.
@@ -44644,6 +44652,10 @@ image-type Reference
 Build an image based on the @code{docker-image} image.
 @end defvar
 
+@defvar docker-layered-image-type
+Build a layered image based on the @code{docker-layered-image} image.
+@end defvar
+
 @defvar raw-with-offset-image-type
 Build an MBR image with a single partition starting at a @code{1024KiB}
 offset.  This is useful to leave some room to install a bootloader in
diff --git a/gnu/image.scm b/gnu/image.scm
index 523653dd77..8a6a0d8479 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -152,7 +153,7 @@ (define-syntax-rule (define-set-sanitizer name field set)
 
 ;; The supported image formats.
 (define-set-sanitizer validate-image-format format
-  (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
+  (disk-image compressed-qcow2 docker docker-layered iso9660 tarball wsl2))
 
 ;; The supported partition table types.
 (define-set-sanitizer validate-partition-table-type partition-table-type
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index afef79185f..3a502f19ec 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -78,6 +79,7 @@ (define-module (gnu system image)
             efi-disk-image
             iso9660-image
             docker-image
+            docker-layered-image
             tarball-image
             wsl2-image
             raw-with-offset-disk-image
@@ -89,6 +91,7 @@ (define-module (gnu system image)
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            docker-layered-image-type
             tarball-image-type
             wsl2-image-type
             raw-with-offset-image-type
@@ -167,6 +170,10 @@ (define docker-image
   (image-without-os
    (format 'docker)))
 
+(define docker-layered-image
+  (image-without-os
+   (format 'docker-layered)))
+
 (define tarball-image
   (image-without-os
    (format 'tarball)))
@@ -237,6 +244,11 @@ (define docker-image-type
    (name 'docker)
    (constructor (cut image-with-os docker-image <>))))
 
+(define docker-layered-image-type
+  (image-type
+   (name 'docker-layered)
+   (constructor (cut image-with-os docker-layered-image <>))))
+
 (define tarball-image-type
   (image-type
    (name 'tarball)
@@ -633,9 +645,12 @@ (define (image-with-label base-image label)
 
 (define* (system-docker-image image
                               #:key
-                              (name "docker-image"))
+                              (name "docker-image")
+                              (archiver tar)
+                              layered-image?)
   "Build a docker image for IMAGE.  NAME is the base name to use for the
-output file."
+output file.  If LAYERED-IMAGE? is true, the image will with many of the store
+paths being on their own layer to improve sharing between images."
   (define boot-program
     ;; Program that runs the boot script of OS, which in turn starts shepherd.
     (program-file "boot-program"
@@ -678,9 +693,11 @@ (define* (system-docker-image image
               (use-modules (guix docker)
                            (guix build utils)
                            (gnu build image)
+                           (srfi srfi-1)
                            (srfi srfi-19)
                            (guix build store-copy)
-                           (guix store database))
+                           (guix store database)
+                           (ice-9 receive))
 
               ;; Set the SQL schema location.
               (sql-schema #$schema)
@@ -700,18 +717,31 @@ (define* (system-docker-image image
                                            #:register-closures? #$register-closures?
                                            #:deduplicate? #f
                                            #:system-directory #$os)
-                (build-docker-image
-                 #$output
-                 (cons* image-root
-                        (map store-info-item
-                             (call-with-input-file #$graph
-                               read-reference-graph)))
-                 #$os
-                 #:entry-point '(#$boot-program #$os)
-                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-                 #:creation-time (make-time time-utc 0 1)
-                 #:system #$image-target
-                 #:transformations `((,image-root -> ""))))))))
+                (when #$layered-image?
+                  (setenv "PATH"
+                          (string-join (list #+(file-append archiver "/bin")
+                                             #+(file-append coreutils "/bin")
+                                             #+(file-append gzip "/bin"))
+                                       ":")))
+                (apply build-docker-image
+                       (append (list #$output
+                                     (append (if #$layered-image?
+                                                 '()
+                                                 (list image-root))
+                                             (map store-info-item
+                                                  (call-with-input-file #$graph
+                                                    read-reference-graph)))
+                                     #$os
+                                     #:entry-point '(#$boot-program #$os)
+                                     #:compressor
+                                     '(#+(file-append gzip "/bin/gzip") "-9n")
+                                     #:creation-time (make-time time-utc 0 1)
+                                     #:system #$image-target
+                                     #:transformations `((,image-root -> "")))
+                               (if #$layered-image?
+                                   (list #:root-system image-root
+                                         #:layered-image? #$layered-image?)
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
@@ -720,6 +750,18 @@ (define* (system-docker-image image
                    #:options `(#:references-graphs ((,graph ,os))
                                #:substitutable? ,substitutable?))))
 
+(define* (system-docker-layered-image image
+                                      #:key
+                                      (name "docker-image")
+                                      (archiver tar)
+                                      (layered-image? #t))
+  "Build a docker image for IMAGE.  NAME is the base name to use for the
+output file."
+  (system-docker-image image
+                       #:name name
+                       #:archiver archiver
+                       #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Tarball image.
@@ -811,7 +853,7 @@ (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker tarball wsl2) "dummy")
+    ((docker docker-layered tarball wsl2) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -948,6 +990,8 @@ (define* (system-image image)
                                        ("bootcfg" ,bootcfg))))
        ((memq image-format '(docker))
         (system-docker-image image*))
+       ((memq image-format '(docker-layered))
+        (system-docker-layered-image image*))
        ((memq image-format '(tarball))
         (system-tarball-image image*))
        ((memq image-format '(wsl2))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index edc9804414..0cccc02ad2 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,7 +44,8 @@ (define-module (gnu tests docker)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (%test-docker
-            %test-docker-system))
+            %test-docker-system
+            %test-docker-layered-system))
 
 (define %docker-os
   (simple-operating-system
@@ -316,3 +318,19 @@ (define %test-docker-system
                                    (locale-libcs (list glibc)))
                                  #:type docker-image-type)))
                  run-docker-system-test)))))
+
+(define %test-docker-layered-system
+  (system-test
+   (name "docker-layered-system")
+   (description "Run a system image as produced by @command{guix system
+docker-layered-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (lower-object
+                  (system-image (os->image
+                                 (operating-system
+                                   (inherit (simple-operating-system))
+                                   ;; Use locales for a single libc to
+                                   ;; reduce space requirements.
+                                   (locale-libcs (list glibc)))
+                                 #:type docker-layered-image-type)))
+                 run-docker-system-test)))))
diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..e10b940aa4 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,8 @@ (define-module (guix docker)
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-1)
@@ -38,6 +41,9 @@ (define-module (guix docker)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
   #:export (build-docker-image))
 
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
@@ -92,12 +98,12 @@ (define (canonicalize-repository-name name)
                       (make-string (- min-length l) padding-character)))
       (_ normalized-name))))
 
-(define* (manifest path id #:optional (tag "guix"))
+(define* (manifest path layers #:optional (tag "guix"))
   "Generate a simple image manifest."
   (let ((tag (canonicalize-repository-name tag)))
     `#(((Config . "config.json")
         (RepoTags . #(,(string-append tag ":latest")))
-        (Layers . #(,(string-append id "/layer.tar")))))))
+        (Layers . ,(list->vector layers))))))
 
 ;; According to the specifications this is required for backwards
 ;; compatibility.  It duplicates information provided by the manifest.
@@ -106,8 +112,8 @@ (define* (repositories path id #:optional (tag "guix"))
   `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define* (config layer time arch #:key entry-point (environment '()))
-  "Generate a minimal image configuration for the given LAYER file."
+(define* (config layers-diff-ids time arch #:key entry-point (environment '()))
+  "Generate a minimal image configuration for the given LAYERS files."
   ;; "architecture" must be values matching "platform.arch" in the
   ;; runtime-spec at
   ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
@@ -125,7 +131,7 @@ (define* (config layer time arch #:key entry-point (environment '()))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
-               (diff_ids . #(,(layer-diff-id layer)))))))
+               (diff_ids . ,(list->vector layers-diff-ids))))))
 
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
@@ -136,6 +142,37 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define %docker-image-max-layers
+  100)
+
+(define (paths-split-sort paths)
+  "Split list of PATHS at %DOCKER-IMAGE-MAX-LAYERS and sort by disk usage."
+  (let* ((paths-length (length paths))
+         (port (apply open-pipe* OPEN_READ
+                      (append '("du" "--summarize") paths)))
+         (output (read-string port)))
+    (close-port port)
+    (receive (head tail)
+        (split-at
+         (map (match-lambda ((size . path) path))
+              (sort (map (lambda (line)
+                           (match (string-split line #\tab)
+                             ((size path)
+                              (cons (string->number size) path))))
+                         (string-split
+                          (string-trim-right output #\newline)
+                          #\newline))
+                    (lambda (path1 path2)
+                      (< (match path2 ((size . _) size))
+                         (match path1 ((size . _) size))))))
+         (if (>= paths-length %docker-image-max-layers)
+             (- %docker-image-max-layers 2)
+             (1- paths-length)))
+      (list head tail))))
+
+(define (create-empty-tar file)
+  (invoke "tar" "-cf" file "--files-from" "/dev/null"))
+
 (define* (build-docker-image image paths prefix
                              #:key
                              (repository "guix")
@@ -146,11 +183,13 @@ (define* (build-docker-image image paths prefix
                              entry-point
                              (environment '())
                              compressor
-                             (creation-time (current-time time-utc)))
-  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
-must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
-is a descriptive name that will show up in \"REPOSITORY\" column of the output
-of \"docker images\".
+                             (creation-time (current-time time-utc))
+                             layered-image?
+                             root-system)
+  "Write to IMAGE a layerer Docker image archive containing the given PATHS.
+PREFIX must be a store path that is a prefix of any store paths in PATHS.
+REPOSITORY is a descriptive name that will show up in \"REPOSITORY\" column of
+the output of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -172,7 +211,14 @@ (define* (build-docker-image image paths prefix
 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 PATHS 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."
+SRFI-19 time-utc object, as the creation time in metadata.
+
+When LAYERED-IMAGE? is true build layered image, providing a Docker
+image with many of the store paths being on their own layer to improve sharing
+between images.
+
+ROOT-SYSTEM is a directory with a provisioned root file system, which will be
+added to image as a layer."
   (define (sanitize path-fragment)
     (escape-special-chars
      ;; GNU tar strips the leading slash off of absolute paths before applying
@@ -203,6 +249,53 @@ (define* (build-docker-image image paths prefix
     (if (eq? '() transformations)
         '()
         `("--transform" ,(transformations->expression transformations))))
+  (define layers-hashes
+    (match-lambda
+      (((head ...) (tail ...) id)
+       (create-empty-tar "image.tar")
+       (let* ((head-layers
+               (map
+                (lambda (file)
+                  (invoke "tar" "cf" "layer.tar" file)
+                  (let* ((file-hash (layer-diff-id "layer.tar"))
+                         (file-name (string-append file-hash "/layer.tar")))
+                    (mkdir file-hash)
+                    (rename-file "layer.tar" file-name)
+                    (invoke "tar" "-rf" "image.tar" file-name)
+                    (delete-file file-name)
+                    file-hash))
+                head))
+              (tail-layer
+               (begin
+                 (create-empty-tar "layer.tar")
+                 (for-each (lambda (file)
+                             (invoke "tar" "-rf" "layer.tar" file))
+                           tail)
+                 (let* ((file-hash (layer-diff-id "layer.tar"))
+                        (file-name (string-append file-hash "/layer.tar")))
+                   (mkdir file-hash)
+                   (rename-file "layer.tar" file-name)
+                   (invoke "tar" "-rf" "image.tar" file-name)
+                   (delete-file file-name)
+                   file-hash)))
+              (customization-layer
+               (let* ((file-id (string-append id "/layer.tar"))
+                      (file-hash (layer-diff-id file-id))
+                      (file-name (string-append file-hash "/layer.tar")))
+                 (mkdir file-hash)
+                 (rename-file file-id file-name)
+                 (invoke "tar" "-rf" "image.tar" file-name)
+                 file-hash))
+              (all-layers
+               (append head-layers (list tail-layer customization-layer))))
+         (with-output-to-file "manifest.json"
+           (lambda ()
+             (scm->json (manifest prefix
+                                  (map (cut string-append <> "/layer.tar")
+                                       all-layers)
+                                  repository))))
+         (invoke "tar" "-rf" "image.tar" "manifest.json")
+         all-layers))))
   (let* ((directory "/tmp/docker-image") ;temporary working directory
          (id (docker-id prefix))
          (time (date->string (time-utc->date creation-time) "~4"))
@@ -229,26 +322,39 @@ (define* (build-docker-image image paths prefix
         (with-output-to-file "json"
           (lambda () (scm->json (image-description id time))))
 
-        ;; Create a directory for the non-store files that need to go into the
-        ;; archive.
-        (mkdir "extra")
+        (if root-system
+            (let ((directory (getcwd)))
+              (with-directory-excursion root-system
+                (apply invoke "tar"
+                       "-cf" (string-append directory "/layer.tar")
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." "..")))))))))
+            (begin
+              ;; Create a directory for the non-store files that need to go
+              ;; into the archive.
+              (mkdir "extra")
 
-        (with-directory-excursion "extra"
-          ;; Create non-store files.
-          (for-each (cut evaluate-populate-directive <> "./")
-                    extra-files)
+              (with-directory-excursion "extra"
+                ;; Create non-store files.
+                (for-each (cut evaluate-populate-directive <> "./")
+                          extra-files)
 
-          (when database
-            ;; Initialize /var/guix, assuming PREFIX points to a profile.
-            (install-database-and-gc-roots "." database prefix))
+                (when database
+                  ;; Initialize /var/guix, assuming PREFIX points to a
+                  ;; profile.
+                  (install-database-and-gc-roots "." database prefix))
 
-          (apply invoke "tar" "-cf" "../layer.tar"
-                 `(,@transformation-options
-                   ,@(tar-base-options)
-                   ,@paths
-                   ,@(scandir "."
-                              (lambda (file)
-                                (not (member file '("." ".."))))))))
+                (apply invoke "tar" "-cf" "../layer.tar"
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(if layered-image? '() paths)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." ".."))))))))
+              (delete-file-recursively "extra")))
 
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -261,24 +367,33 @@ (define* (build-docker-image image paths prefix
         ;; error messages.
         (with-error-to-port (%make-void-port "w")
           (lambda ()
-            (system* "tar" "--delete" "/" "-f" "layer.tar")))
-
-        (delete-file-recursively "extra"))
+            (system* "tar" "--delete" "/" "-f" "layer.tar"))))
 
       (with-output-to-file "config.json"
         (lambda ()
-          (scm->json (config (string-append id "/layer.tar")
-                             time arch
-                             #:environment environment
-                             #:entry-point entry-point))))
-      (with-output-to-file "manifest.json"
-        (lambda ()
-          (scm->json (manifest prefix id repository))))
-      (with-output-to-file "repositories"
-        (lambda ()
-          (scm->json (repositories prefix id repository)))))
-
-    (apply invoke "tar" "-cf" image "-C" directory
-           `(,@(tar-base-options #:compressor compressor)
-             "."))
+          (scm->json
+           (config (if layered-image?
+                       (layers-hashes (append (paths-split-sort paths)
+                                              (list id)))
+                       (list (layer-diff-id (string-append id "/layer.tar"))))
+                   time arch
+                   #:environment environment
+                   #:entry-point entry-point))))
+      (if layered-image?
+          (begin
+            (invoke "tar" "-rf" "image.tar" "config.json")
+            (apply invoke `(,@compressor "image.tar"))
+            (copy-file "image.tar.gz" image))
+          (begin
+            (with-output-to-file "manifest.json"
+              (lambda ()
+                (scm->json (manifest prefix
+                                     (list (string-append id "/layer.tar"))
+                                     repository))))
+            (with-output-to-file "repositories"
+              (lambda ()
+                (scm->json (repositories prefix id repository))))
+            (apply invoke "tar" "-cf" image
+                   `(,@(tar-base-options #:compressor compressor)
+                     ".")))))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0dc9979194..3fefd2eac3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@ (define-module (guix scripts pack)
   #:use-module (guix scripts)
   #:use-module (guix ui)
   #:use-module (guix gexp)
+  #:use-module ((guix build utils) #:select (%xz-parallel-args))
   #:use-module (guix utils)
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -53,6 +55,8 @@ (define-module (guix scripts pack)
   #:use-module ((gnu packages compression) #:hide (zip))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages shells)
+  #:autoload   (gnu packages package-management) (guix)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
   #:use-module (srfi srfi-1)
@@ -67,6 +71,7 @@ (define-module (guix scripts pack)
             debian-archive
             rpm-archive
             docker-image
+            docker-layered-image
             squashfs-image
 
             %formats
@@ -597,12 +602,14 @@ (define* (docker-image name profile
                        localstatedir?
                        (symlinks '())
                        (archiver tar)
-                       (extra-options '()))
+                       (extra-options '())
+                       layered-image?)
   "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."
+the image.  If LAYERED-IMAGE? is true, the image will with many of the
+store paths being on their own layer to improve sharing between images."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -653,7 +660,13 @@ (define* (docker-image name profile
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if layered-image?
+                                          (list (file-append coreutils "/bin")
+                                                (file-append gzip "/bin"))
+                                          '()))
+                                 ":"))
 
             (build-docker-image #$output
                                 (map store-info-item
@@ -671,7 +684,8 @@ (define* (docker-image name profile
                                                               #$entry-point)))
                                 #:extra-files directives
                                 #:compressor #+(compressor-command compressor)
-                                #:creation-time (make-time time-utc 0 1))))))
+                                #:creation-time (make-time time-utc 0 1)
+                                #:layered-image? #$layered-image?)))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -679,6 +693,33 @@ (define* (docker-image name profile
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (docker-layered-image name profile
+                               #:key target
+                               (profile-name "guix-profile")
+                               (compressor (first %compressors))
+                               entry-point
+                               localstatedir?
+                               (symlinks '())
+                               (archiver tar)
+                               (extra-options '())
+                               (layered-image? #t))
+  "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.  If LAYERED-IMAGE? is true, the image will with many of the store paths
+being on their own layer to improve sharing between images."
+  (docker-image name profile
+                #:target target
+                #:profile-name profile-name
+                #:compressor compressor
+                #:entry-point entry-point
+                #:localstatedir? localstatedir?
+                #:symlinks symlinks
+                #:archiver archiver
+                #:extra-options extra-options
+                #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Debian archive format.
@@ -1353,6 +1394,7 @@ (define %formats
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)
+    (docker-layered  . ,docker-layered-image)
     (deb . ,debian-archive)
     (rpm . ,rpm-archive)))
 
@@ -1361,15 +1403,17 @@ (define (show-formats)
   (display (G_ "The supported formats for 'guix pack' are:"))
   (newline)
   (display (G_ "
-  tarball       Self-contained tarball, ready to run on another machine"))
+  tarball        Self-contained tarball, ready to run on another machine"))
+  (display (G_ "
+  squashfs       Squashfs image suitable for Singularity"))
   (display (G_ "
-  squashfs      Squashfs image suitable for Singularity"))
+  docker         Tarball ready for 'docker load'"))
   (display (G_ "
-  docker        Tarball ready for 'docker load'"))
+  docker-layered Tarball with a layered image ready for 'docker load'"))
   (display (G_ "
-  deb           Debian archive installable via dpkg/apt"))
+  deb            Debian archive installable via dpkg/apt"))
   (display (G_ "
-  rpm           RPM archive installable via rpm/yum"))
+  rpm            RPM archive installable via rpm/yum"))
   (newline))
 
 (define (required-option symbol)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index d7163dd3eb..e4bf0347c7 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -11,6 +11,7 @@
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -727,13 +728,15 @@ (define* (system-derivation-for-action image action
                                               #:graphic? graphic?
                                               #:disk-image-size image-size
                                               #:mappings mappings))
-      ((image disk-image vm-image docker-image)
+      ((image disk-image vm-image docker-image docker-layered-image)
        (when (eq? action 'disk-image)
          (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'vm-image)
          (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'docker-image)
          (warning (G_ "'docker-image' is deprecated: use 'image' instead~%")))
+       (when (eq? action 'docker-layered-image)
+         (warning (G_ "'docker-layered-image' is deprecated: use 'image' instead~%")))
        (lower-object (system-image image))))))
 
 (define (maybe-suggest-running-guix-pull)
@@ -980,6 +983,8 @@ (define (show-help)
    image            build a Guix System image\n"))
   (display (G_ "\
    docker-image     build a Docker image\n"))
+  (display (G_ "\
+   docker-layered-image build a Docker layered image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1193,7 +1198,7 @@ (define actions '("build" "container" "vm" "vm-image" "image" "disk-image"
                   "list-generations" "describe"
                   "delete-generations" "roll-back"
                   "switch-generation" "search" "edit"
-                  "docker-image"))
+                  "docker-image" "docker-layered-image"))
 
 (define (process-action action args opts)
   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
@@ -1242,6 +1247,8 @@ (define (process-action action args opts)
          (image       (let* ((image-type (case action
                                            ((vm-image) qcow2-image-type)
                                            ((docker-image) docker-image-type)
+                                           ((docker-layered-image)
+                                            docker-layered-image-type)
                                            (else image-type)))
                             (image-size (assoc-ref opts 'image-size))
                             (volatile?
diff --git a/tests/pack.scm b/tests/pack.scm
index ce5a2f8a53..432ab1b2ea 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (test-pack)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (%store-directory))
   #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
   #:use-module (gnu packages bootstrap)
@@ -250,6 +252,52 @@ (define rpm-for-tests
                           (mkdir #$output)))))))
       (built-derivations (list check))))
 
+  (unless store (test-skip 1))
+  (test-assertm "docker-layered-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile)))
+                      (hooks '())
+                      (locales? #f)))
+         (tarball (docker-layered-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #:localstatedir? #t))
+         (check   (gexp->derivation "check-tarball"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils)
+                                       (ice-9 match))
+
+                          (define bin
+                            (string-append "." #$profile "/bin"))
+
+                          (define store
+                            (string-append "." #$(%store-directory)))
+
+                          (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+                          (mkdir "base")
+                          (with-directory-excursion "base"
+                            (invoke "tar" "xvf" #$tarball))
+
+                          (match (find-files "base" "layer.tar")
+                            ((layers ...)
+                             (for-each (lambda (layer)
+                                         (invoke "tar" "xvf" layer)
+                                         (invoke "chmod" "--recursive" "u+w" store))
+                                       layers)))
+
+                          (when
+                              (and (file-exists? (string-append bin "/guile"))
+                                   (file-exists? "var/guix/db/db.sqlite")
+                                   (file-is-directory? "tmp")
+                                   (string=? (string-append #$%bootstrap-guile "/bin")
+                                             (pk 'binlink (readlink bin)))
+                                   (string=? (string-append #$profile "/bin/guile")
+                                             (pk 'guilelink (readlink "bin/Guile"))))
+                            (mkdir #$output)))))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "squashfs-image + localstatedir" store
     (mlet* %store-monad
-- 
2.38.0





^ permalink raw reply related	[relevance 35%]

* [bug#62726] [PATCH] services: Activate `setuid-program-service-type' in shepherd.
  @ 2023-04-08 15:16 45% ` Brian Cully via Guix-patches via
  2023-06-07 12:59 40% ` [bug#62726] [PATCH v2] " Brian Cully via Guix-patches via
  1 sibling, 0 replies; 149+ results
From: Brian Cully via Guix-patches via @ 2023-04-08 15:16 UTC (permalink / raw)
  To: 62726; +Cc: Brian Cully

Activate using a one-shot Shepherd service on boot, rather than attaching to
`activation-service-type' to populate `/run/setuid-programs'.

In order to prevent a dependency cycle between (gnu services) and (gnu
services shepherd), introduce a new module (gnu services setuid) and deprecate
the import of `setuid-program-service-type' from (gnu services).

* gnu/local.mk (GNU_SYSTEM_MODULES): add setuid.scm.
* gnu/services.scm (setuid-program-service-type): deprecate.
* gnu/services/setuid.scm: new module.
* gnu/services/dbus.scm (gnu): import (gnu services setuid).
* gnu/services/desktop.scm (gnu): import (gnu services setuid).
* gnu/services/docker.scm (gnu): import (gnu services setuid).
* gnu/services/mail.scm (gnu): import (gnu services setuid).
* gnu/services/xorg.scm (gnu): import (gnu services setuid).
* gnu/system.scm (gnu): import (gnu services setuid).
---
 gnu/local.mk             |  1 +
 gnu/services.scm         | 40 +++---------------------------
 gnu/services/dbus.scm    |  1 +
 gnu/services/desktop.scm |  1 +
 gnu/services/docker.scm  |  1 +
 gnu/services/mail.scm    |  1 +
 gnu/services/setuid.scm  | 53 ++++++++++++++++++++++++++++++++++++++++
 gnu/services/xorg.scm    |  1 +
 gnu/system.scm           |  1 +
 9 files changed, 63 insertions(+), 37 deletions(-)
 create mode 100644 gnu/services/setuid.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index b7e19b6bc2..55dae3426a 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -704,6 +704,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/rsync.scm			\
   %D%/services/samba.scm			\
   %D%/services/sddm.scm				\
+  %D%/services/setuid.scm			\
   %D%/services/spice.scm				\
   %D%/services/ssh.scm				\
   %D%/services/syncthing.scm			\
diff --git a/gnu/services.scm b/gnu/services.scm
index d6c7ad0553..f42d4bc15f 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -43,7 +43,6 @@ (define-module (gnu services)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages hurd)
-  #:use-module (gnu system setuid)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -110,7 +109,7 @@ (define-module (gnu services)
             extra-special-file
             etc-service-type
             etc-directory
-            setuid-program-service-type
+            setuid-program-service-type ; deprecated
             profile-service-type
             firmware-service-type
             gc-root-service-type
@@ -811,41 +810,8 @@ (define-deprecated (etc-service files)
 FILES must be a list of name/file-like object pairs."
   (service etc-service-type files))
 
-(define (setuid-program->activation-gexp programs)
-  "Return an activation gexp for setuid-program from PROGRAMS."
-  (let ((programs (map (lambda (program)
-                         ;; FIXME This is really ugly, I didn't managed to use
-                         ;; "inherit"
-                         (let ((program-name (setuid-program-program program))
-                               (setuid?      (setuid-program-setuid? program))
-                               (setgid?      (setuid-program-setgid? program))
-                               (user         (setuid-program-user program))
-                               (group        (setuid-program-group program)) )
-                           #~(setuid-program
-                              (setuid? #$setuid?)
-                              (setgid? #$setgid?)
-                              (user    #$user)
-                              (group   #$group)
-                              (program #$program-name))))
-                       programs)))
-    (with-imported-modules (source-module-closure
-                            '((gnu system setuid)))
-      #~(begin
-          (use-modules (gnu system setuid))
-
-          (activate-setuid-programs (list #$@programs))))))
-
-(define setuid-program-service-type
-  (service-type (name 'setuid-program)
-                (extensions
-                 (list (service-extension activation-service-type
-                                          setuid-program->activation-gexp)))
-                (compose concatenate)
-                (extend (lambda (config extensions)
-                          (append config extensions)))
-                (description
-                 "Populate @file{/run/setuid-programs} with the specified
-executables, making them setuid and/or setgid.")))
+(define-deprecated/public-alias setuid-program-service-type
+  (@ (gnu services setuid) setuid-program-service-type))
 
 (define (packages->profile-entry packages)
   "Return a system entry for the profile containing PACKAGES."
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index e9c9346f56..dd9f0122b1 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -21,6 +21,7 @@
 
 (define-module (gnu services dbus)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index adea5b38dd..1ff7abd61e 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -33,6 +33,7 @@
 
 (define-module (gnu services desktop)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 741bab5a8c..32ed9739bf 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -26,6 +26,7 @@ (define-module (gnu services docker)
   #:use-module (gnu services configuration)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index bf4948dcfb..d6e35a07f8 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -27,6 +27,7 @@ (define-module (gnu services mail)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu services configuration)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system shadow)
diff --git a/gnu/services/setuid.scm b/gnu/services/setuid.scm
new file mode 100644
index 0000000000..4e46510733
--- /dev/null
+++ b/gnu/services/setuid.scm
@@ -0,0 +1,53 @@
+(define-module (gnu services setuid)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (srfi srfi-1)
+  #:export (setuid-program-service-type))
+
+(define (setuid-programs->shepherd-service programs)
+  (let ((programs (map (lambda (program)
+                         ;; FIXME This is really ugly, I didn't managed to use
+                         ;; "inherit"
+                         (let ((program-name (setuid-program-program program))
+                               (setuid?      (setuid-program-setuid? program))
+                               (setgid?      (setuid-program-setgid? program))
+                               (user         (setuid-program-user program))
+                               (group        (setuid-program-group program)) )
+                           #~(setuid-program
+                              (setuid? #$setuid?)
+                              (setgid? #$setgid?)
+                              (user    #$user)
+                              (group   #$group)
+                              (program #$program-name))))
+                       programs)))
+    (with-imported-modules (source-module-closure
+                            '((gnu system setuid)
+                              (gnu build activation)))
+      (list (shepherd-service
+             (documentation "Populate @file{/run/setuid-programs}.")
+             (provision '(setuid-programs))
+             ;; TODO: actually need to require account service. maybe user-homes
+             ;; as a proxy?
+             (requirement '(file-systems))
+             (one-shot? #t)
+             (modules '((gnu system setuid)
+                        (gnu build activation)))
+             (start #~(lambda ()
+                        (activate-setuid-programs (list #$@programs))
+                        #t)))))))
+
+(define setuid-program-service-type
+  (service-type (name 'setuid-program)
+                (extensions
+                 (list
+                  (service-extension shepherd-root-service-type
+                                     setuid-programs->shepherd-service)))
+                (compose concatenate)
+                (extend append)
+                (default-value '())
+                (description
+                 "Populate @file{/run/setuid-programs} with the specified
+executables, making them setuid and/or setgid.")))
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 7295a45b59..9ed1977f66 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -34,6 +34,7 @@ (define-module (gnu services xorg)
   #:use-module (gnu artwork)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system setuid)
diff --git a/gnu/system.scm b/gnu/system.scm
index c17c6e4e98..8faa3b4672 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -67,6 +67,7 @@ (define-module (gnu system)
   #:use-module (gnu packages text-editors)
   #:use-module (gnu packages wget)
   #:use-module (gnu services)
+  #:use-module (gnu services setuid)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
   #:use-module (gnu bootloader)
-- 
2.39.2





^ permalink raw reply related	[relevance 45%]

* [bug#62153] [PATCH 1/2] guix: docker: Build layered image.
  @ 2023-03-14  0:24 27%   ` Oleg Pykhalov
  0 siblings, 0 replies; 149+ results
From: Oleg Pykhalov @ 2023-03-14  0:24 UTC (permalink / raw)
  To: pelzflorian; +Cc: Oleg Pykhalov, 62153

* gnu/packages/aux-files/python/stream-layered-image.py: New file.
* Makefile.am (AUX_FILES): Add this.
* guix/docker.scm (%docker-image-max-layers): New variable.
(build-docker-image)[stream-layered-image, root-system]: New arguments.
* guix/scripts/pack.scm (stream-layered-image.py): New variable.
(docker-image)[layered-image?]: New argument.
(docker-layered-image): New procedure.
(%formats)[docker-layered]: New format.
(show-formats): Document this.
* tests/pack.scm: Add docker-layered-image + localstatedir test.
* guix/scripts/system.scm
(system-derivation-for-action)[docker-layered-image]: New action.
(show-help): Document this.
(actions)[docker-layered-image]: New action.
(process-action): Add this.
* gnu/system/image.scm (docker-layered-image, docker-layered-image-type): New
variables.
(system-docker-image)[layered-image?]: New argument.
(stream-layered-image.py): New variable.
(system-docker-layered-image): New procedure.
(image->root-file-system)[docker-layered]: New image format.
* gnu/tests/docker.scm (%test-docker-layered-system): New test.
* gnu/image.scm (validate-image-format)[docker-layered]: New image format.
* doc/guix.texi (Invoking guix pack): Document docker-layered format.
(image Reference): Same.
(image-type Reference): Document docker-layered-image-type.
---
 Makefile.am                                   |   3 +-
 doc/guix.texi                                 |  18 +-
 gnu/image.scm                                 |   3 +-
 .../aux-files/python/stream-layered-image.py  | 391 ++++++++++++++++++
 gnu/system/image.scm                          |  84 +++-
 gnu/tests/docker.scm                          |  20 +-
 guix/docker.scm                               | 182 ++++++--
 guix/scripts/pack.scm                         | 105 +++--
 guix/scripts/system.scm                       |  11 +-
 tests/pack.scm                                |  48 +++
 10 files changed, 779 insertions(+), 86 deletions(-)
 create mode 100644 gnu/packages/aux-files/python/stream-layered-image.py

diff --git a/Makefile.am b/Makefile.am
index 23b939b674..9aca84f8f8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -11,7 +11,7 @@
 # Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
 # Copyright © 2018 Nikita <nikita@n0.is>
 # Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
-# Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+# Copyright © 2018, 2023 Oleg Pykhalov <go.wigust@gmail.com>
 # Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 # Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
@@ -435,6 +435,7 @@ AUX_FILES =						\
   gnu/packages/aux-files/python/sanity-check.py		\
   gnu/packages/aux-files/python/sanity-check-next.py	\
   gnu/packages/aux-files/python/sitecustomize.py	\
+  gnu/packages/aux-files/python/stream-layered-image.py	\
   gnu/packages/aux-files/renpy/renpy.in	\
   gnu/packages/aux-files/run-in-namespace.c
 
diff --git a/doc/guix.texi b/doc/guix.texi
index 39932d5aad..fa4b7586c9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -56,7 +56,7 @@ Copyright @copyright{} 2017 Andy Wingo@*
 Copyright @copyright{} 2017, 2018, 2019, 2020 Arun Isaac@*
 Copyright @copyright{} 2017 nee@*
 Copyright @copyright{} 2018 Rutger Helling@*
-Copyright @copyright{} 2018, 2021 Oleg Pykhalov@*
+Copyright @copyright{} 2018, 2021, 2023 Oleg Pykhalov@*
 Copyright @copyright{} 2018 Mike Gerwitz@*
 Copyright @copyright{} 2018 Pierre-Antoine Rouby@*
 Copyright @copyright{} 2018, 2019 Gábor Boskovits@*
@@ -6837,9 +6837,15 @@ the following command:
 guix pack -f docker -S /bin=bin guile guile-readline
 @end example
 
+or
+
+@example
+guix pack -f docker-layered -S /bin=bin guile guile-readline
+@end example
+
 @noindent
-The result is a tarball that can be passed to the @command{docker load}
-command, followed by @code{docker run}:
+The result is a tarball with image or layered image that can be passed
+to the @command{docker load} command, followed by @code{docker run}:
 
 @example
 docker load < @var{file}
@@ -43274,6 +43280,8 @@ one or multiple partitions.
 
 @item @code{docker}, a Docker image.
 
+@item @code{docker-layered}, a layered Docker image.
+
 @item @code{iso9660}, an ISO-9660 image.
 
 @item @code{tarball}, a tar.gz image archive.
@@ -43605,6 +43613,10 @@ Build an image based on the @code{iso9660-image} image but with the
 Build an image based on the @code{docker-image} image.
 @end defvar
 
+@defvar docker-layered-image-type
+Build a layered image based on the @code{docker-layered-image} image.
+@end defvar
+
 @defvar raw-with-offset-image-type
 Build an MBR image with a single partition starting at a @code{1024KiB}
 offset.  This is useful to leave some room to install a bootloader in
diff --git a/gnu/image.scm b/gnu/image.scm
index 523653dd77..8a6a0d8479 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -152,7 +153,7 @@ (define-with-syntax-properties (name (value properties))
 
 ;; The supported image formats.
 (define-set-sanitizer validate-image-format format
-  (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
+  (disk-image compressed-qcow2 docker docker-layered iso9660 tarball wsl2))
 
 ;; The supported partition table types.
 (define-set-sanitizer validate-partition-table-type partition-table-type
diff --git a/gnu/packages/aux-files/python/stream-layered-image.py b/gnu/packages/aux-files/python/stream-layered-image.py
new file mode 100644
index 0000000000..9ad2168c2d
--- /dev/null
+++ b/gnu/packages/aux-files/python/stream-layered-image.py
@@ -0,0 +1,391 @@
+"""
+This script generates a Docker image from a set of store paths. Uses
+Docker Image Specification v1.2 as reference [1].
+
+It expects a JSON file with the following properties and writes the
+image as an uncompressed tarball to stdout:
+
+* "architecture", "config", "os", "created", "repo_tag" correspond to
+  the fields with the same name on the image spec [2].
+* "created" can be "now".
+* "created" is also used as mtime for files added to the image.
+* "store_layers" is a list of layers in ascending order, where each
+  layer is the list of store paths to include in that layer.
+
+The main challenge for this script to create the final image in a
+streaming fashion, without dumping any intermediate data to disk
+for performance.
+
+A docker image has each layer contents archived as separate tarballs,
+and they later all get enveloped into a single big tarball in a
+content addressed fashion. However, because how "tar" format works,
+we have to know about the name (which includes the checksum in our
+case) and the size of the tarball before we can start adding it to the
+outer tarball.  We achieve that by creating the layer tarballs twice;
+on the first iteration we calculate the file size and the checksum,
+and on the second one we actually stream the contents. 'add_layer_dir'
+function does all this.
+
+[1]: https://github.com/moby/moby/blob/master/image/spec/v1.2.md
+[2]: https://github.com/moby/moby/blob/4fb59c20a4fb54f944fe170d0ff1d00eb4a24d6f/image/spec/v1.2.md#image-json-field-descriptions
+"""  # noqa: E501
+
+
+import io
+import os
+import re
+import sys
+import json
+import hashlib
+import pathlib
+import tarfile
+import itertools
+import threading
+from datetime import datetime, timezone
+from collections import namedtuple
+
+
+def archive_paths_to(obj, paths, mtime):
+    """
+    Writes the given store paths as a tar file to the given stream.
+
+    obj: Stream to write to. Should have a 'write' method.
+    paths: List of store paths.
+    """
+
+    # gettarinfo makes the paths relative, this makes them
+    # absolute again
+    def append_root(ti):
+        ti.name = "/" + ti.name
+        return ti
+
+    def apply_filters(ti):
+        ti.mtime = mtime
+        ti.uid = 0
+        ti.gid = 0
+        ti.uname = "root"
+        ti.gname = "root"
+        return ti
+
+    def nix_root(ti):
+        ti.mode = 0o0555  # r-xr-xr-x
+        return ti
+
+    def dir(path):
+        ti = tarfile.TarInfo(path)
+        ti.type = tarfile.DIRTYPE
+        return ti
+
+    with tarfile.open(fileobj=obj, mode="w|") as tar:
+        # To be consistent with the docker utilities, we need to have
+        # these directories first when building layer tarballs.
+        tar.addfile(apply_filters(nix_root(dir("/gnu"))))
+        tar.addfile(apply_filters(nix_root(dir("/gnu/store"))))
+
+        for path in paths:
+            path = pathlib.Path(path)
+            if path.is_symlink():
+                files = [path]
+            else:
+                files = itertools.chain([path], path.rglob("*"))
+
+            for filename in sorted(files):
+                ti = append_root(tar.gettarinfo(filename))
+
+                # copy hardlinks as regular files
+                if ti.islnk():
+                    ti.type = tarfile.REGTYPE
+                    ti.linkname = ""
+                    ti.size = filename.stat().st_size
+
+                ti = apply_filters(ti)
+                if ti.isfile():
+                    with open(filename, "rb") as f:
+                        tar.addfile(ti, f)
+                else:
+                    tar.addfile(ti)
+
+
+class ExtractChecksum:
+    """
+    A writable stream which only calculates the final file size and
+    sha256sum, while discarding the actual contents.
+    """
+
+    def __init__(self):
+        self._digest = hashlib.sha256()
+        self._size = 0
+
+    def write(self, data):
+        self._digest.update(data)
+        self._size += len(data)
+
+    def extract(self):
+        """
+        Returns: Hex-encoded sha256sum and size as a tuple.
+        """
+        return (self._digest.hexdigest(), self._size)
+
+
+FromImage = namedtuple("FromImage", ["tar", "manifest_json", "image_json"])
+# Some metadata for a layer
+LayerInfo = namedtuple("LayerInfo", ["size", "checksum", "path", "paths"])
+
+
+def load_from_image(from_image_str):
+    """
+    Loads the given base image, if any.
+
+    from_image_str: Path to the base image archive.
+
+    Returns: A 'FromImage' object with references to the loaded base image,
+             or 'None' if no base image was provided.
+    """
+    if from_image_str is None:
+        return None
+
+    base_tar = tarfile.open(from_image_str)
+
+    manifest_json_tarinfo = base_tar.getmember("manifest.json")
+    with base_tar.extractfile(manifest_json_tarinfo) as f:
+        manifest_json = json.load(f)
+
+    image_json_tarinfo = base_tar.getmember(manifest_json[0]["Config"])
+    with base_tar.extractfile(image_json_tarinfo) as f:
+        image_json = json.load(f)
+
+    return FromImage(base_tar, manifest_json, image_json)
+
+
+def add_base_layers(tar, from_image):
+    """
+    Adds the layers from the given base image to the final image.
+
+    tar: 'tarfile.TarFile' object for new layers to be added to.
+    from_image: 'FromImage' object with references to the loaded base image.
+    """
+    if from_image is None:
+        print("No 'fromImage' provided", file=sys.stderr)
+        return []
+
+    layers = from_image.manifest_json[0]["Layers"]
+    checksums = from_image.image_json["rootfs"]["diff_ids"]
+    layers_checksums = zip(layers, checksums)
+
+    for num, (layer, checksum) in enumerate(layers_checksums, start=1):
+        layer_tarinfo = from_image.tar.getmember(layer)
+        checksum = re.sub(r"^sha256:", "", checksum)
+
+        tar.addfile(layer_tarinfo, from_image.tar.extractfile(layer_tarinfo))
+        path = layer_tarinfo.path
+        size = layer_tarinfo.size
+
+        print("Adding base layer", num, "from", path, file=sys.stderr)
+        yield LayerInfo(size=size, checksum=checksum, path=path, paths=[path])
+
+    from_image.tar.close()
+
+
+def overlay_base_config(from_image, final_config):
+    """
+    Overlays the final image 'config' JSON on top of selected defaults from the
+    base image 'config' JSON.
+
+    from_image: 'FromImage' object with references to the loaded base image.
+    final_config: 'dict' object of the final image 'config' JSON.
+    """
+    if from_image is None:
+        return final_config
+
+    base_config = from_image.image_json["config"]
+
+    # Preserve environment from base image
+    final_env = base_config.get("Env", []) + final_config.get("Env", [])
+    if final_env:
+        # Resolve duplicates (last one wins) and format back as list
+        resolved_env = {entry.split("=", 1)[0]: entry for entry in final_env}
+        final_config["Env"] = list(resolved_env.values())
+    return final_config
+
+
+def add_layer_dir(tar, paths, store_dir, mtime):
+    """
+    Appends given store paths to a TarFile object as a new layer.
+
+    tar: 'tarfile.TarFile' object for the new layer to be added to.
+    paths: List of store paths.
+    store_dir: the root directory of the nix store
+    mtime: 'mtime' of the added files and the layer tarball.
+           Should be an integer representing a POSIX time.
+
+    Returns: A 'LayerInfo' object containing some metadata of
+             the layer added.
+    """
+
+    invalid_paths = [i for i in paths if not i.startswith(store_dir)]
+    assert len(invalid_paths) == 0, \
+        f"Expecting absolute paths from {store_dir}, but got: {invalid_paths}"
+
+    # First, calculate the tarball checksum and the size.
+    extract_checksum = ExtractChecksum()
+    archive_paths_to(
+        extract_checksum,
+        paths,
+        mtime=mtime,
+    )
+    (checksum, size) = extract_checksum.extract()
+
+    path = f"{checksum}/layer.tar"
+    layer_tarinfo = tarfile.TarInfo(path)
+    layer_tarinfo.size = size
+    layer_tarinfo.mtime = mtime
+
+    # Then actually stream the contents to the outer tarball.
+    read_fd, write_fd = os.pipe()
+    with open(read_fd, "rb") as read, open(write_fd, "wb") as write:
+        def producer():
+            archive_paths_to(
+                write,
+                paths,
+                mtime=mtime,
+            )
+            write.close()
+
+        # Closing the write end of the fifo also closes the read end,
+        # so we don't need to wait until this thread is finished.
+        #
+        # Any exception from the thread will get printed by the default
+        # exception handler, and the 'addfile' call will fail since it
+        # won't be able to read required amount of bytes.
+        threading.Thread(target=producer).start()
+        tar.addfile(layer_tarinfo, read)
+
+    return LayerInfo(size=size, checksum=checksum, path=path, paths=paths)
+
+
+def add_customisation_layer(target_tar, customisation_layer, mtime):
+    """
+    Adds the customisation layer as a new layer. This is layer is structured
+    differently; given store path has the 'layer.tar' and corresponding
+    sha256sum ready.
+
+    tar: 'tarfile.TarFile' object for the new layer to be added to.
+    customisation_layer: Path containing the layer archive.
+    mtime: 'mtime' of the added layer tarball.
+    """
+
+    checksum_path = os.path.join(customisation_layer, "checksum")
+    with open(checksum_path) as f:
+        checksum = f.read().strip()
+    assert len(checksum) == 64, f"Invalid sha256 at ${checksum_path}."
+
+    layer_path = os.path.join(customisation_layer, "layer.tar")
+
+    path = f"{checksum}/layer.tar"
+    tarinfo = target_tar.gettarinfo(layer_path)
+    tarinfo.name = path
+    tarinfo.mtime = mtime
+
+    with open(layer_path, "rb") as f:
+        target_tar.addfile(tarinfo, f)
+
+    return LayerInfo(
+      size=None,
+      checksum=checksum,
+      path=path,
+      paths=[customisation_layer]
+    )
+
+
+def add_bytes(tar, path, content, mtime):
+    """
+    Adds a file to the tarball with given path and contents.
+
+    tar: 'tarfile.TarFile' object.
+    path: Path of the file as a string.
+    content: Contents of the file.
+    mtime: 'mtime' of the file. Should be an integer representing a POSIX time.
+    """
+    assert type(content) is bytes
+
+    ti = tarfile.TarInfo(path)
+    ti.size = len(content)
+    ti.mtime = mtime
+    tar.addfile(ti, io.BytesIO(content))
+
+
+def main():
+    with open(sys.argv[1], "r") as f:
+        conf = json.load(f)
+
+    created = (
+      datetime.now(tz=timezone.utc)
+      if conf["created"] == "now"
+      else datetime.fromisoformat(conf["created"])
+    )
+    mtime = int(created.timestamp())
+    store_dir = conf["store_dir"]
+
+    from_image = load_from_image(conf["from_image"])
+
+    with tarfile.open(mode="w|", fileobj=sys.stdout.buffer) as tar:
+        layers = []
+        layers.extend(add_base_layers(tar, from_image))
+
+        start = len(layers) + 1
+        for num, store_layer in enumerate(conf["store_layers"], start=start):
+            print("Creating layer", num, "from paths:", store_layer,
+                  file=sys.stderr)
+            info = add_layer_dir(tar, store_layer, store_dir, mtime=mtime)
+            layers.append(info)
+
+        print("Creating layer", len(layers) + 1, "with customisation...",
+              file=sys.stderr)
+        layers.append(
+          add_customisation_layer(
+            tar,
+            conf["customisation_layer"],
+            mtime=mtime
+          )
+        )
+
+        print("Adding manifests...", file=sys.stderr)
+
+        image_json = {
+            "created": datetime.isoformat(created),
+            "architecture": conf["architecture"],
+            "os": "linux",
+            "config": overlay_base_config(from_image, conf["config"]),
+            "rootfs": {
+                "diff_ids": [f"sha256:{layer.checksum}" for layer in layers],
+                "type": "layers",
+            },
+            "history": [
+                {
+                  "created": datetime.isoformat(created),
+                  "comment": f"store paths: {layer.paths}"
+                }
+                for layer in layers
+            ],
+        }
+
+        image_json = json.dumps(image_json, indent=4).encode("utf-8")
+        image_json_checksum = hashlib.sha256(image_json).hexdigest()
+        image_json_path = f"{image_json_checksum}.json"
+        add_bytes(tar, image_json_path, image_json, mtime=mtime)
+
+        manifest_json = [
+            {
+                "Config": image_json_path,
+                "RepoTags": [conf["repo_tag"]],
+                "Layers": [layer.path for layer in layers],
+            }
+        ]
+        manifest_json = json.dumps(manifest_json, indent=4).encode("utf-8")
+        add_bytes(tar, "manifest.json", manifest_json, mtime=mtime)
+
+        print("Done.", file=sys.stderr)
+
+
+if __name__ == "__main__":
+    main()
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index afef79185f..0bfd011ad4 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -45,6 +46,7 @@ (define-module (gnu system image)
   #:use-module (gnu system uuid)
   #:use-module (gnu system vm)
   #:use-module (guix packages)
+  #:use-module ((gnu packages) #:select (search-auxiliary-file))
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages bootloaders)
@@ -58,6 +60,7 @@ (define-module (gnu system image)
   #:use-module (gnu packages hurd)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages mtools)
+  #:use-module (gnu packages python)
   #:use-module (gnu packages virtualization)
   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
   #:use-module (srfi srfi-11)
@@ -78,6 +81,7 @@ (define-module (gnu system image)
             efi-disk-image
             iso9660-image
             docker-image
+            docker-layered-image
             tarball-image
             wsl2-image
             raw-with-offset-disk-image
@@ -89,6 +93,7 @@ (define-module (gnu system image)
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            docker-layered-image-type
             tarball-image-type
             wsl2-image-type
             raw-with-offset-image-type
@@ -167,6 +172,10 @@ (define docker-image
   (image-without-os
    (format 'docker)))
 
+(define docker-layered-image
+  (image-without-os
+   (format 'docker-layered)))
+
 (define tarball-image
   (image-without-os
    (format 'tarball)))
@@ -237,6 +246,11 @@ (define docker-image-type
    (name 'docker)
    (constructor (cut image-with-os docker-image <>))))
 
+(define docker-layered-image-type
+  (image-type
+   (name 'docker-layered)
+   (constructor (cut image-with-os docker-layered-image <>))))
+
 (define tarball-image-type
   (image-type
    (name 'tarball)
@@ -633,9 +647,12 @@ (define (image-with-label base-image label)
 
 (define* (system-docker-image image
                               #:key
-                              (name "docker-image"))
+                              (name "docker-image")
+                              (archiver tar)
+                              layered-image?)
   "Build a docker image for IMAGE.  NAME is the base name to use for the
-output file."
+output file.  If LAYERED-IMAGE? is true, the image will with many of the store
+paths being on their own layer to improve sharing between images."
   (define boot-program
     ;; Program that runs the boot script of OS, which in turn starts shepherd.
     (program-file "boot-program"
@@ -678,9 +695,11 @@ (define builder
               (use-modules (guix docker)
                            (guix build utils)
                            (gnu build image)
+                           (srfi srfi-1)
                            (srfi srfi-19)
                            (guix build store-copy)
-                           (guix store database))
+                           (guix store database)
+                           (ice-9 receive))
 
               ;; Set the SQL schema location.
               (sql-schema #$schema)
@@ -700,18 +719,34 @@ (define builder
                                            #:register-closures? #$register-closures?
                                            #:deduplicate? #f
                                            #:system-directory #$os)
-                (build-docker-image
-                 #$output
-                 (cons* image-root
-                        (map store-info-item
-                             (call-with-input-file #$graph
-                               read-reference-graph)))
-                 #$os
-                 #:entry-point '(#$boot-program #$os)
-                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-                 #:creation-time (make-time time-utc 0 1)
-                 #:system #$image-target
-                 #:transformations `((,image-root -> ""))))))))
+                (when #$layered-image?
+                  (setenv "PATH"
+                          (string-join (list #+(file-append archiver "/bin")
+                                             #+(file-append coreutils "/bin")
+                                             #+(file-append gzip "/bin")
+                                             #+(file-append python "/bin"))
+                                       ":")))
+                (apply build-docker-image
+                       (append (list #$output
+                                     (append (if #$layered-image?
+                                                 '()
+                                                 (list image-root))
+                                             (map store-info-item
+                                                  (call-with-input-file #$graph
+                                                    read-reference-graph)))
+                                     #$os
+                                     #:entry-point '(#$boot-program #$os)
+                                     #:compressor
+                                     '(#+(file-append gzip "/bin/gzip") "-9n")
+                                     #:creation-time (make-time time-utc 0 1)
+                                     #:system #$image-target
+                                     #:transformations `((,image-root -> "")))
+                               (if #$layered-image?
+                                   (list #:root-system
+                                         image-root
+                                         #:stream-layered-image
+                                         #$stream-layered-image.py)
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
@@ -720,6 +755,21 @@ (define builder
                    #:options `(#:references-graphs ((,graph ,os))
                                #:substitutable? ,substitutable?))))
 
+(define stream-layered-image.py
+  (local-file (search-auxiliary-file "python/stream-layered-image.py")))
+
+(define* (system-docker-layered-image image
+                                      #:key
+                                      (name "docker-image")
+                                      (archiver tar)
+                                      (layered-image? #t))
+  "Build a docker image for IMAGE.  NAME is the base name to use for the
+output file."
+  (system-docker-image image
+                       #:name name
+                       #:archiver archiver
+                       #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Tarball image.
@@ -811,7 +861,7 @@ (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker tarball wsl2) "dummy")
+    ((docker docker-layered tarball wsl2) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -948,6 +998,8 @@ (define target (cond
                                        ("bootcfg" ,bootcfg))))
        ((memq image-format '(docker))
         (system-docker-image image*))
+       ((memq image-format '(docker-layered))
+        (system-docker-layered-image image*))
        ((memq image-format '(tarball))
         (system-tarball-image image*))
        ((memq image-format '(wsl2))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 0276e398a7..85c5f178b5 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,7 +44,8 @@ (define-module (gnu tests docker)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (%test-docker
-            %test-docker-system))
+            %test-docker-system
+            %test-docker-layered-system))
 
 (define %docker-os
   (simple-operating-system
@@ -309,3 +311,19 @@ (define %test-docker-system
                                    (locale-libcs (list glibc)))
                                  #:type docker-image-type)))
                  run-docker-system-test)))))
+
+(define %test-docker-layered-system
+  (system-test
+   (name "docker-layered-system")
+   (description "Run a system image as produced by @command{guix system
+docker-layered-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (lower-object
+                  (system-image (os->image
+                                 (operating-system
+                                   (inherit (simple-operating-system))
+                                   ;; Use locales for a single libc to
+                                   ;; reduce space requirements.
+                                   (locale-libcs (list glibc)))
+                                 #:type docker-layered-image-type)))
+                 run-docker-system-test)))))
diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..f1adad26dc 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,10 +25,14 @@ (define-module (guix docker)
   #:use-module (guix base16)
   #:use-module (guix build pack)
   #:use-module ((guix build utils)
-                #:select (mkdir-p
+                #:select (%store-directory
+                          mkdir-p
                           delete-file-recursively
+                          dump-port
                           with-directory-excursion
                           invoke))
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-1)
@@ -38,6 +43,9 @@ (define-module (guix docker)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
   #:export (build-docker-image))
 
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
@@ -136,6 +144,9 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define %docker-image-max-layers
+  100)
+
 (define* (build-docker-image image paths prefix
                              #:key
                              (repository "guix")
@@ -146,11 +157,13 @@ (define* (build-docker-image image paths prefix
                              entry-point
                              (environment '())
                              compressor
-                             (creation-time (current-time time-utc)))
-  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
-must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
-is a descriptive name that will show up in \"REPOSITORY\" column of the output
-of \"docker images\".
+                             (creation-time (current-time time-utc))
+                             stream-layered-image
+                             root-system)
+  "Write to IMAGE a layerer Docker image archive containing the given PATHS.
+PREFIX must be a store path that is a prefix of any store paths in PATHS.
+REPOSITORY is a descriptive name that will show up in \"REPOSITORY\" column of
+the output of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -172,7 +185,13 @@ (define* (build-docker-image image paths prefix
 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 PATHS 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."
+SRFI-19 time-utc object, as the creation time in metadata.
+
+STREAM-LAYERED-IMAGE is a Python script which accepts a JSON configuration
+file and prints archive to STDOUT.
+
+ROOT-SYSTEM is a directory with a provisioned root file system, which will be
+added to image as a layer."
   (define (sanitize path-fragment)
     (escape-special-chars
      ;; GNU tar strips the leading slash off of absolute paths before applying
@@ -183,6 +202,39 @@ (define (sanitize path-fragment)
      ;; We also need to escape "/" because we use it as a delimiter.
      "/*.^$[]\\"
      #\\))
+  (define (file-sha256 file-name)
+    "Calculate the hexdigest of the sha256 checksum of FILE-NAME and return it."
+    (let ((port (open-pipe* OPEN_READ
+                            "sha256sum"
+                            "--"
+                            file-name)))
+      (let ((result (read-delimited " " port)))
+        (close-pipe port)
+        result)))
+  (define (paths-split-sort paths)
+    "Split list of PATHS at %DOCKER-IMAGE-MAX-LAYERS and sort by disk usage."
+    (let* ((paths-length (length paths))
+           (port (apply open-pipe* OPEN_READ
+                        (append '("du" "--summarize") paths)))
+           (output (read-string port)))
+      (close-port port)
+      (receive (head tail)
+          (split-at
+           (map (match-lambda ((size . path) path))
+                (sort (map (lambda (line)
+                             (match (string-split line #\tab)
+                               ((size path)
+                                (cons (string->number size) path))))
+                           (string-split
+                            (string-trim-right output #\newline)
+                            #\newline))
+                      (lambda (path1 path2)
+                        (< (match path2 ((size . _) size))
+                           (match path1 ((size . _) size))))))
+           (if (>= paths-length %docker-image-max-layers)
+               (- %docker-image-max-layers 2)
+               (1- paths-length)))
+        (list head tail))))
   (define transformation->replacement
     (match-lambda
       ((old '-> new)
@@ -205,7 +257,9 @@ (define transformation-options
         `("--transform" ,(transformations->expression transformations))))
   (let* ((directory "/tmp/docker-image") ;temporary working directory
          (id (docker-id prefix))
-         (time (date->string (time-utc->date creation-time) "~4"))
+         (time ;Workaround for Python datetime.fromisoformat does not parse Z.
+          (string-append (date->string (time-utc->date creation-time) "~5")
+                         "+00:00"))
          (arch (let-syntax ((cond* (syntax-rules ()
                                      ((_ (pattern clause) ...)
                                       (cond ((string-prefix? pattern system)
@@ -218,7 +272,8 @@ (define transformation-options
                         ("i686"    "386")
                         ("arm"     "arm")
                         ("aarch64" "arm64")
-                        ("mips64"  "mips64le")))))
+                        ("mips64"  "mips64le"))))
+         (paths (if stream-layered-image (paths-split-sort paths) paths)))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
     (with-directory-excursion directory
@@ -229,26 +284,38 @@ (define transformation-options
         (with-output-to-file "json"
           (lambda () (scm->json (image-description id time))))
 
-        ;; Create a directory for the non-store files that need to go into the
-        ;; archive.
-        (mkdir "extra")
+        (if root-system
+            (let ((directory (getcwd)))
+              (with-directory-excursion root-system
+                (apply invoke "tar"
+                       "-cf" (string-append directory "/layer.tar")
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." "..")))))))))
+            (begin
+              ;; Create a directory for the non-store files that need to go
+              ;; into the archive.
+              (mkdir "extra")
 
-        (with-directory-excursion "extra"
-          ;; Create non-store files.
-          (for-each (cut evaluate-populate-directive <> "./")
-                    extra-files)
+              (with-directory-excursion "extra"
+                ;; Create non-store files.
+                (for-each (cut evaluate-populate-directive <> "./")
+                          extra-files)
 
-          (when database
-            ;; Initialize /var/guix, assuming PREFIX points to a profile.
-            (install-database-and-gc-roots "." database prefix))
+                (when database
+                  ;; Initialize /var/guix, assuming PREFIX points to a profile.
+                  (install-database-and-gc-roots "." database prefix))
 
-          (apply invoke "tar" "-cf" "../layer.tar"
-                 `(,@transformation-options
-                   ,@(tar-base-options)
-                   ,@paths
-                   ,@(scandir "."
-                              (lambda (file)
-                                (not (member file '("." ".."))))))))
+                (apply invoke "tar" "-cf" "../layer.tar"
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(if stream-layered-image '() paths)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." ".."))))))))
+              (delete-file-recursively "extra")))
 
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -263,22 +330,65 @@ (define transformation-options
           (lambda ()
             (system* "tar" "--delete" "/" "-f" "layer.tar")))
 
-        (delete-file-recursively "extra"))
+        (when stream-layered-image
+          (call-with-output-file "checksum"
+            (lambda (port)
+              (display (file-sha256 "layer.tar") port)))))
 
       (with-output-to-file "config.json"
         (lambda ()
-          (scm->json (config (string-append id "/layer.tar")
-                             time arch
-                             #:environment environment
-                             #:entry-point entry-point))))
+          (scm->json
+           (if stream-layered-image
+               `(("created" . ,time)
+                 ("repo_tag" . "guix:latest")
+                 ("customisation_layer" . ,id)
+                 ("store_layers" . ,(match paths
+                                      (((head ...) (tail ...))
+                                       (list->vector
+                                        (reverse
+                                         (cons (list->vector tail)
+                                               (fold (lambda (path paths)
+                                                       (cons (vector path) paths))
+                                                     '()
+                                                     head)))))))
+                 ("store_dir" . ,(%store-directory))
+                 ("from_image" . #nil)
+                 ("os" . "linux")
+                 ("config"
+                  (env . ,(list->vector (map (match-lambda
+                                               ((name . value)
+                                                (string-append name "=" value)))
+                                             environment)))
+                  ,@(if entry-point
+                        `((entrypoint . ,(list->vector entry-point)))
+                        '()))
+                 ("architecture" . ,arch))
+               (config (string-append id "/layer.tar")
+                       time arch
+                       #:environment environment
+                       #:entry-point entry-point)))))
       (with-output-to-file "manifest.json"
         (lambda ()
           (scm->json (manifest prefix id repository))))
       (with-output-to-file "repositories"
         (lambda ()
-          (scm->json (repositories prefix id repository)))))
-
-    (apply invoke "tar" "-cf" image "-C" directory
-           `(,@(tar-base-options #:compressor compressor)
-             "."))
+          (scm->json (repositories prefix id repository))))
+      (if stream-layered-image
+          (let ((input (open-pipe* OPEN_READ "python3"
+                                   stream-layered-image
+                                   "config.json")))
+            (call-with-output-file "image.tar"
+              (lambda (output)
+                (dump-port input output)))
+            (if (eqv? 0 (status:exit-val (close-pipe input)))
+                (begin
+                  (invoke "gzip" "image.tar")
+                  (copy-file "image.tar.gz" image))
+                (error
+                 (formatted-message
+                  (G_ "failed to create ~a image tarball")
+                  image))))
+          (apply invoke "tar" "-cf" image
+                 `(,@(tar-base-options #:compressor compressor)
+                   "."))))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 25ac9d29d0..3a8f87e850 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@ (define-module (guix scripts pack)
   #:use-module (guix scripts)
   #:use-module (guix ui)
   #:use-module (guix gexp)
+  #:use-module ((guix build utils) #:select (%xz-parallel-args))
   #:use-module (guix utils)
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -53,6 +55,8 @@ (define-module (guix scripts pack)
   #:use-module ((gnu packages compression) #:hide (zip))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages python)
+  #:autoload   (gnu packages package-management) (guix)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
   #:use-module (srfi srfi-1)
@@ -67,6 +71,7 @@ (define-module (guix scripts pack)
             debian-archive
             rpm-archive
             docker-image
+            docker-layered-image
             squashfs-image
 
             %formats
@@ -589,6 +594,10 @@ (define (mksquashfs args)
 ;;;
 ;;; Docker image format.
 ;;;
+
+(define stream-layered-image.py
+  (local-file (search-auxiliary-file "python/stream-layered-image.py")))
+
 (define* (docker-image name profile
                        #:key target
                        (profile-name "guix-profile")
@@ -597,12 +606,14 @@ (define* (docker-image name profile
                        localstatedir?
                        (symlinks '())
                        (archiver tar)
-                       (extra-options '()))
+                       (extra-options '())
+                       layered-image?)
   "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."
+the image.  If LAYERED-IMAGE? is true, the image will with many of the
+store paths being on their own layer to improve sharing between images."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -653,25 +664,37 @@ (define directives
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
-
-            (build-docker-image #$output
-                                (map store-info-item
-                                     (call-with-input-file "profile"
-                                       read-reference-graph))
-                                #$profile
-                                #:repository (manifest->friendly-name
-                                              (profile-manifest #$profile))
-                                #:database #+database
-                                #:system (or #$target %host-type)
-                                #:environment environment
-                                #:entry-point
-                                #$(and entry-point
-                                       #~(list (string-append #$profile "/"
-                                                              #$entry-point)))
-                                #:extra-files directives
-                                #:compressor #+(compressor-command compressor)
-                                #:creation-time (make-time time-utc 0 1))))))
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if layered-image?
+                                          (list (file-append coreutils "/bin")
+                                                (file-append gzip "/bin")
+                                                (file-append python "/bin"))
+                                          '()))
+                                 ":"))
+
+            (apply build-docker-image
+                   (append (list #$output
+                                 (map store-info-item
+                                      (call-with-input-file "profile"
+                                        read-reference-graph))
+                                 #$profile
+                                 #:repository (manifest->friendly-name
+                                               (profile-manifest #$profile))
+                                 #:database #+database
+                                 #:system (or #$target %host-type)
+                                 #:environment environment
+                                 #:entry-point
+                                 #$(and entry-point
+                                        #~(list (string-append #$profile "/"
+                                                               #$entry-point)))
+                                 #:extra-files directives
+                                 #:compressor #+(compressor-command compressor)
+                                 #:creation-time (make-time time-utc 0 1))
+                           (if #$layered-image?
+                               (list #:stream-layered-image
+                                     #$stream-layered-image.py)
+                               '())))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -679,6 +702,33 @@ (define directives
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (docker-layered-image name profile
+                               #:key target
+                               (profile-name "guix-profile")
+                               (compressor (first %compressors))
+                               entry-point
+                               localstatedir?
+                               (symlinks '())
+                               (archiver tar)
+                               (extra-options '())
+                               (layered-image? #t))
+  "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.  If LAYERED-IMAGE? is true, the image will with many of the store paths
+being on their own layer to improve sharing between images."
+  (docker-image name profile
+                #:target target
+                #:profile-name profile-name
+                #:compressor compressor
+                #:entry-point entry-point
+                #:localstatedir? localstatedir?
+                #:symlinks symlinks
+                #:archiver archiver
+                #:extra-options extra-options
+                #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Debian archive format.
@@ -1355,6 +1405,7 @@ (define %formats
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)
+    (docker-layered  . ,docker-layered-image)
     (deb . ,debian-archive)
     (rpm . ,rpm-archive)))
 
@@ -1363,15 +1414,17 @@ (define (show-formats)
   (display (G_ "The supported formats for 'guix pack' are:"))
   (newline)
   (display (G_ "
-  tarball       Self-contained tarball, ready to run on another machine"))
+  tarball        Self-contained tarball, ready to run on another machine"))
+  (display (G_ "
+  squashfs       Squashfs image suitable for Singularity"))
   (display (G_ "
-  squashfs      Squashfs image suitable for Singularity"))
+  docker         Tarball ready for 'docker load'"))
   (display (G_ "
-  docker        Tarball ready for 'docker load'"))
+  docker-layered Tarball with a layered image ready for 'docker load'"))
   (display (G_ "
-  deb           Debian archive installable via dpkg/apt"))
+  deb            Debian archive installable via dpkg/apt"))
   (display (G_ "
-  rpm           RPM archive installable via rpm/yum"))
+  rpm            RPM archive installable via rpm/yum"))
   (newline))
 
 (define (required-option symbol)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index d7163dd3eb..e4bf0347c7 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -11,6 +11,7 @@
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -727,13 +728,15 @@ (define* (system-derivation-for-action image action
                                               #:graphic? graphic?
                                               #:disk-image-size image-size
                                               #:mappings mappings))
-      ((image disk-image vm-image docker-image)
+      ((image disk-image vm-image docker-image docker-layered-image)
        (when (eq? action 'disk-image)
          (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'vm-image)
          (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'docker-image)
          (warning (G_ "'docker-image' is deprecated: use 'image' instead~%")))
+       (when (eq? action 'docker-layered-image)
+         (warning (G_ "'docker-layered-image' is deprecated: use 'image' instead~%")))
        (lower-object (system-image image))))))
 
 (define (maybe-suggest-running-guix-pull)
@@ -980,6 +983,8 @@ (define (show-help)
    image            build a Guix System image\n"))
   (display (G_ "\
    docker-image     build a Docker image\n"))
+  (display (G_ "\
+   docker-layered-image build a Docker layered image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1193,7 +1198,7 @@ (define actions '("build" "container" "vm" "vm-image" "image" "disk-image"
                   "list-generations" "describe"
                   "delete-generations" "roll-back"
                   "switch-generation" "search" "edit"
-                  "docker-image"))
+                  "docker-image" "docker-layered-image"))
 
 (define (process-action action args opts)
   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
@@ -1242,6 +1247,8 @@ (define save-provenance?
          (image       (let* ((image-type (case action
                                            ((vm-image) qcow2-image-type)
                                            ((docker-image) docker-image-type)
+                                           ((docker-layered-image)
+                                            docker-layered-image-type)
                                            (else image-type)))
                             (image-size (assoc-ref opts 'image-size))
                             (volatile?
diff --git a/tests/pack.scm b/tests/pack.scm
index 87187bb62c..db2208d91c 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (test-pack)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (%store-directory))
   #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
   #:use-module (gnu packages bootstrap)
@@ -246,6 +248,52 @@ (define bin
                             (mkdir #$output)))))))
       (built-derivations (list check))))
 
+  (unless store (test-skip 1))
+  (test-assertm "docker-layered-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile)))
+                      (hooks '())
+                      (locales? #f)))
+         (tarball (docker-layered-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #:localstatedir? #t))
+         (check   (gexp->derivation "check-tarball"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils)
+                                       (ice-9 match))
+
+                          (define bin
+                            (string-append "." #$profile "/bin"))
+
+                          (define store
+                            (string-append "." #$(%store-directory)))
+
+                          (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+                          (mkdir "base")
+                          (with-directory-excursion "base"
+                            (invoke "tar" "xvf" #$tarball))
+
+                          (match (find-files "base" "layer.tar")
+                            ((layers ...)
+                             (for-each (lambda (layer)
+                                         (invoke "tar" "xvf" layer)
+                                         (invoke "chmod" "--recursive" "u+w" store))
+                                       layers)))
+
+                          (when
+                              (and (file-exists? (string-append bin "/guile"))
+                                   (file-exists? "var/guix/db/db.sqlite")
+                                   (file-is-directory? "tmp")
+                                   (string=? (string-append #$%bootstrap-guile "/bin")
+                                             (pk 'binlink (readlink bin)))
+                                   (string=? (string-append #$profile "/bin/guile")
+                                             (pk 'guilelink (readlink "bin/Guile"))))
+                            (mkdir #$output)))))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "squashfs-image + localstatedir" store
     (mlet* %store-monad
-- 
2.38.0





^ permalink raw reply related	[relevance 27%]

* [bug#62153] [PATCH 1/2] guix: docker: Build layered image.
  @ 2023-03-13  0:33 28% ` Oleg Pykhalov
  0 siblings, 0 replies; 149+ results
From: Oleg Pykhalov @ 2023-03-13  0:33 UTC (permalink / raw)
  To: 62153; +Cc: Oleg Pykhalov

* gnu/packages/aux-files/python/stream-layered-image.py: New file.
* Makefile.am (AUX_FILES): Add this.
* guix/docker.scm (%docker-image-max-layers): New variable.
(build-docker-image)[stream-layered-image, root-system]: New arguments.
* guix/scripts/pack.scm (stream-layered-image.py): New variable.
(docker-image)[layered-image?]: New argument.
(docker-layered-image): New procedure.
(%formats)[docker-layered]: New format.
(show-formats): Document this.
* tests/pack.scm: Add docker-layered-image + localstatedir test.
* guix/scripts/system.scm
(system-derivation-for-action)[docker-layered-image]: New action.
(show-help): Document this.
(actions)[docker-layered-image]: New action.
(process-action): Add this.
* gnu/system/image.scm (docker-layered-image, docker-layered-image-type): New
variables.
(system-docker-image)[layered-image?]: New argument.
(stream-layered-image.py): New variable.
(system-docker-layered-image): New procedure.
(image->root-file-system)[docker-layered]: New image format.
* gnu/tests/docker.scm (%test-docker-layered-system): New test.
* gnu/image.scm (validate-image-format)[docker-layered]: New image format.
* doc/guix.texi (Invoking guix pack): Document docker-layered format.
(image-type Reference): Document docker-layered-image-type.
---
 Makefile.am                                   |   3 +-
 doc/guix.texi                                 |  16 +-
 gnu/image.scm                                 |   3 +-
 .../aux-files/python/stream-layered-image.py  | 391 ++++++++++++++++++
 gnu/system/image.scm                          |  84 +++-
 gnu/tests/docker.scm                          |  20 +-
 guix/docker.scm                               | 182 ++++++--
 guix/scripts/pack.scm                         | 103 +++--
 guix/scripts/system.scm                       |  11 +-
 tests/pack.scm                                |  48 +++
 10 files changed, 775 insertions(+), 86 deletions(-)
 create mode 100644 gnu/packages/aux-files/python/stream-layered-image.py

diff --git a/Makefile.am b/Makefile.am
index 23b939b674..9aca84f8f8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -11,7 +11,7 @@
 # Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
 # Copyright © 2018 Nikita <nikita@n0.is>
 # Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
-# Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+# Copyright © 2018, 2023 Oleg Pykhalov <go.wigust@gmail.com>
 # Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 # Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
@@ -435,6 +435,7 @@ AUX_FILES =						\
   gnu/packages/aux-files/python/sanity-check.py		\
   gnu/packages/aux-files/python/sanity-check-next.py	\
   gnu/packages/aux-files/python/sitecustomize.py	\
+  gnu/packages/aux-files/python/stream-layered-image.py	\
   gnu/packages/aux-files/renpy/renpy.in	\
   gnu/packages/aux-files/run-in-namespace.c
 
diff --git a/doc/guix.texi b/doc/guix.texi
index b545751e1b..bd0ee126ee 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -56,7 +56,7 @@ Copyright @copyright{} 2017 Andy Wingo@*
 Copyright @copyright{} 2017, 2018, 2019, 2020 Arun Isaac@*
 Copyright @copyright{} 2017 nee@*
 Copyright @copyright{} 2018 Rutger Helling@*
-Copyright @copyright{} 2018, 2021 Oleg Pykhalov@*
+Copyright @copyright{} 2018, 2021, 2023 Oleg Pykhalov@*
 Copyright @copyright{} 2018 Mike Gerwitz@*
 Copyright @copyright{} 2018 Pierre-Antoine Rouby@*
 Copyright @copyright{} 2018, 2019 Gábor Boskovits@*
@@ -6840,9 +6840,15 @@ the following command:
 guix pack -f docker -S /bin=bin guile guile-readline
 @end example
 
+or
+
+@example
+guix pack -f docker-layered -S /bin=bin guile guile-readline
+@end example
+
 @noindent
-The result is a tarball that can be passed to the @command{docker load}
-command, followed by @code{docker run}:
+The result is a tarball with image or layered image that can be passed
+to the @command{docker load} command, followed by @code{docker run}:
 
 @example
 docker load < @var{file}
@@ -43631,6 +43637,10 @@ Build an image based on the @code{iso9660-image} image but with the
 Build an image based on the @code{docker-image} image.
 @end defvar
 
+@defvar docker-layered-image-type
+Build a layered image based on the @code{docker-layered-image} image.
+@end defvar
+
 @defvar raw-with-offset-image-type
 Build an MBR image with a single partition starting at a @code{1024KiB}
 offset.  This is useful to leave some room to install a bootloader in
diff --git a/gnu/image.scm b/gnu/image.scm
index 523653dd77..8a6a0d8479 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -152,7 +153,7 @@ (define-with-syntax-properties (name (value properties))
 
 ;; The supported image formats.
 (define-set-sanitizer validate-image-format format
-  (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
+  (disk-image compressed-qcow2 docker docker-layered iso9660 tarball wsl2))
 
 ;; The supported partition table types.
 (define-set-sanitizer validate-partition-table-type partition-table-type
diff --git a/gnu/packages/aux-files/python/stream-layered-image.py b/gnu/packages/aux-files/python/stream-layered-image.py
new file mode 100644
index 0000000000..9ad2168c2d
--- /dev/null
+++ b/gnu/packages/aux-files/python/stream-layered-image.py
@@ -0,0 +1,391 @@
+"""
+This script generates a Docker image from a set of store paths. Uses
+Docker Image Specification v1.2 as reference [1].
+
+It expects a JSON file with the following properties and writes the
+image as an uncompressed tarball to stdout:
+
+* "architecture", "config", "os", "created", "repo_tag" correspond to
+  the fields with the same name on the image spec [2].
+* "created" can be "now".
+* "created" is also used as mtime for files added to the image.
+* "store_layers" is a list of layers in ascending order, where each
+  layer is the list of store paths to include in that layer.
+
+The main challenge for this script to create the final image in a
+streaming fashion, without dumping any intermediate data to disk
+for performance.
+
+A docker image has each layer contents archived as separate tarballs,
+and they later all get enveloped into a single big tarball in a
+content addressed fashion. However, because how "tar" format works,
+we have to know about the name (which includes the checksum in our
+case) and the size of the tarball before we can start adding it to the
+outer tarball.  We achieve that by creating the layer tarballs twice;
+on the first iteration we calculate the file size and the checksum,
+and on the second one we actually stream the contents. 'add_layer_dir'
+function does all this.
+
+[1]: https://github.com/moby/moby/blob/master/image/spec/v1.2.md
+[2]: https://github.com/moby/moby/blob/4fb59c20a4fb54f944fe170d0ff1d00eb4a24d6f/image/spec/v1.2.md#image-json-field-descriptions
+"""  # noqa: E501
+
+
+import io
+import os
+import re
+import sys
+import json
+import hashlib
+import pathlib
+import tarfile
+import itertools
+import threading
+from datetime import datetime, timezone
+from collections import namedtuple
+
+
+def archive_paths_to(obj, paths, mtime):
+    """
+    Writes the given store paths as a tar file to the given stream.
+
+    obj: Stream to write to. Should have a 'write' method.
+    paths: List of store paths.
+    """
+
+    # gettarinfo makes the paths relative, this makes them
+    # absolute again
+    def append_root(ti):
+        ti.name = "/" + ti.name
+        return ti
+
+    def apply_filters(ti):
+        ti.mtime = mtime
+        ti.uid = 0
+        ti.gid = 0
+        ti.uname = "root"
+        ti.gname = "root"
+        return ti
+
+    def nix_root(ti):
+        ti.mode = 0o0555  # r-xr-xr-x
+        return ti
+
+    def dir(path):
+        ti = tarfile.TarInfo(path)
+        ti.type = tarfile.DIRTYPE
+        return ti
+
+    with tarfile.open(fileobj=obj, mode="w|") as tar:
+        # To be consistent with the docker utilities, we need to have
+        # these directories first when building layer tarballs.
+        tar.addfile(apply_filters(nix_root(dir("/gnu"))))
+        tar.addfile(apply_filters(nix_root(dir("/gnu/store"))))
+
+        for path in paths:
+            path = pathlib.Path(path)
+            if path.is_symlink():
+                files = [path]
+            else:
+                files = itertools.chain([path], path.rglob("*"))
+
+            for filename in sorted(files):
+                ti = append_root(tar.gettarinfo(filename))
+
+                # copy hardlinks as regular files
+                if ti.islnk():
+                    ti.type = tarfile.REGTYPE
+                    ti.linkname = ""
+                    ti.size = filename.stat().st_size
+
+                ti = apply_filters(ti)
+                if ti.isfile():
+                    with open(filename, "rb") as f:
+                        tar.addfile(ti, f)
+                else:
+                    tar.addfile(ti)
+
+
+class ExtractChecksum:
+    """
+    A writable stream which only calculates the final file size and
+    sha256sum, while discarding the actual contents.
+    """
+
+    def __init__(self):
+        self._digest = hashlib.sha256()
+        self._size = 0
+
+    def write(self, data):
+        self._digest.update(data)
+        self._size += len(data)
+
+    def extract(self):
+        """
+        Returns: Hex-encoded sha256sum and size as a tuple.
+        """
+        return (self._digest.hexdigest(), self._size)
+
+
+FromImage = namedtuple("FromImage", ["tar", "manifest_json", "image_json"])
+# Some metadata for a layer
+LayerInfo = namedtuple("LayerInfo", ["size", "checksum", "path", "paths"])
+
+
+def load_from_image(from_image_str):
+    """
+    Loads the given base image, if any.
+
+    from_image_str: Path to the base image archive.
+
+    Returns: A 'FromImage' object with references to the loaded base image,
+             or 'None' if no base image was provided.
+    """
+    if from_image_str is None:
+        return None
+
+    base_tar = tarfile.open(from_image_str)
+
+    manifest_json_tarinfo = base_tar.getmember("manifest.json")
+    with base_tar.extractfile(manifest_json_tarinfo) as f:
+        manifest_json = json.load(f)
+
+    image_json_tarinfo = base_tar.getmember(manifest_json[0]["Config"])
+    with base_tar.extractfile(image_json_tarinfo) as f:
+        image_json = json.load(f)
+
+    return FromImage(base_tar, manifest_json, image_json)
+
+
+def add_base_layers(tar, from_image):
+    """
+    Adds the layers from the given base image to the final image.
+
+    tar: 'tarfile.TarFile' object for new layers to be added to.
+    from_image: 'FromImage' object with references to the loaded base image.
+    """
+    if from_image is None:
+        print("No 'fromImage' provided", file=sys.stderr)
+        return []
+
+    layers = from_image.manifest_json[0]["Layers"]
+    checksums = from_image.image_json["rootfs"]["diff_ids"]
+    layers_checksums = zip(layers, checksums)
+
+    for num, (layer, checksum) in enumerate(layers_checksums, start=1):
+        layer_tarinfo = from_image.tar.getmember(layer)
+        checksum = re.sub(r"^sha256:", "", checksum)
+
+        tar.addfile(layer_tarinfo, from_image.tar.extractfile(layer_tarinfo))
+        path = layer_tarinfo.path
+        size = layer_tarinfo.size
+
+        print("Adding base layer", num, "from", path, file=sys.stderr)
+        yield LayerInfo(size=size, checksum=checksum, path=path, paths=[path])
+
+    from_image.tar.close()
+
+
+def overlay_base_config(from_image, final_config):
+    """
+    Overlays the final image 'config' JSON on top of selected defaults from the
+    base image 'config' JSON.
+
+    from_image: 'FromImage' object with references to the loaded base image.
+    final_config: 'dict' object of the final image 'config' JSON.
+    """
+    if from_image is None:
+        return final_config
+
+    base_config = from_image.image_json["config"]
+
+    # Preserve environment from base image
+    final_env = base_config.get("Env", []) + final_config.get("Env", [])
+    if final_env:
+        # Resolve duplicates (last one wins) and format back as list
+        resolved_env = {entry.split("=", 1)[0]: entry for entry in final_env}
+        final_config["Env"] = list(resolved_env.values())
+    return final_config
+
+
+def add_layer_dir(tar, paths, store_dir, mtime):
+    """
+    Appends given store paths to a TarFile object as a new layer.
+
+    tar: 'tarfile.TarFile' object for the new layer to be added to.
+    paths: List of store paths.
+    store_dir: the root directory of the nix store
+    mtime: 'mtime' of the added files and the layer tarball.
+           Should be an integer representing a POSIX time.
+
+    Returns: A 'LayerInfo' object containing some metadata of
+             the layer added.
+    """
+
+    invalid_paths = [i for i in paths if not i.startswith(store_dir)]
+    assert len(invalid_paths) == 0, \
+        f"Expecting absolute paths from {store_dir}, but got: {invalid_paths}"
+
+    # First, calculate the tarball checksum and the size.
+    extract_checksum = ExtractChecksum()
+    archive_paths_to(
+        extract_checksum,
+        paths,
+        mtime=mtime,
+    )
+    (checksum, size) = extract_checksum.extract()
+
+    path = f"{checksum}/layer.tar"
+    layer_tarinfo = tarfile.TarInfo(path)
+    layer_tarinfo.size = size
+    layer_tarinfo.mtime = mtime
+
+    # Then actually stream the contents to the outer tarball.
+    read_fd, write_fd = os.pipe()
+    with open(read_fd, "rb") as read, open(write_fd, "wb") as write:
+        def producer():
+            archive_paths_to(
+                write,
+                paths,
+                mtime=mtime,
+            )
+            write.close()
+
+        # Closing the write end of the fifo also closes the read end,
+        # so we don't need to wait until this thread is finished.
+        #
+        # Any exception from the thread will get printed by the default
+        # exception handler, and the 'addfile' call will fail since it
+        # won't be able to read required amount of bytes.
+        threading.Thread(target=producer).start()
+        tar.addfile(layer_tarinfo, read)
+
+    return LayerInfo(size=size, checksum=checksum, path=path, paths=paths)
+
+
+def add_customisation_layer(target_tar, customisation_layer, mtime):
+    """
+    Adds the customisation layer as a new layer. This is layer is structured
+    differently; given store path has the 'layer.tar' and corresponding
+    sha256sum ready.
+
+    tar: 'tarfile.TarFile' object for the new layer to be added to.
+    customisation_layer: Path containing the layer archive.
+    mtime: 'mtime' of the added layer tarball.
+    """
+
+    checksum_path = os.path.join(customisation_layer, "checksum")
+    with open(checksum_path) as f:
+        checksum = f.read().strip()
+    assert len(checksum) == 64, f"Invalid sha256 at ${checksum_path}."
+
+    layer_path = os.path.join(customisation_layer, "layer.tar")
+
+    path = f"{checksum}/layer.tar"
+    tarinfo = target_tar.gettarinfo(layer_path)
+    tarinfo.name = path
+    tarinfo.mtime = mtime
+
+    with open(layer_path, "rb") as f:
+        target_tar.addfile(tarinfo, f)
+
+    return LayerInfo(
+      size=None,
+      checksum=checksum,
+      path=path,
+      paths=[customisation_layer]
+    )
+
+
+def add_bytes(tar, path, content, mtime):
+    """
+    Adds a file to the tarball with given path and contents.
+
+    tar: 'tarfile.TarFile' object.
+    path: Path of the file as a string.
+    content: Contents of the file.
+    mtime: 'mtime' of the file. Should be an integer representing a POSIX time.
+    """
+    assert type(content) is bytes
+
+    ti = tarfile.TarInfo(path)
+    ti.size = len(content)
+    ti.mtime = mtime
+    tar.addfile(ti, io.BytesIO(content))
+
+
+def main():
+    with open(sys.argv[1], "r") as f:
+        conf = json.load(f)
+
+    created = (
+      datetime.now(tz=timezone.utc)
+      if conf["created"] == "now"
+      else datetime.fromisoformat(conf["created"])
+    )
+    mtime = int(created.timestamp())
+    store_dir = conf["store_dir"]
+
+    from_image = load_from_image(conf["from_image"])
+
+    with tarfile.open(mode="w|", fileobj=sys.stdout.buffer) as tar:
+        layers = []
+        layers.extend(add_base_layers(tar, from_image))
+
+        start = len(layers) + 1
+        for num, store_layer in enumerate(conf["store_layers"], start=start):
+            print("Creating layer", num, "from paths:", store_layer,
+                  file=sys.stderr)
+            info = add_layer_dir(tar, store_layer, store_dir, mtime=mtime)
+            layers.append(info)
+
+        print("Creating layer", len(layers) + 1, "with customisation...",
+              file=sys.stderr)
+        layers.append(
+          add_customisation_layer(
+            tar,
+            conf["customisation_layer"],
+            mtime=mtime
+          )
+        )
+
+        print("Adding manifests...", file=sys.stderr)
+
+        image_json = {
+            "created": datetime.isoformat(created),
+            "architecture": conf["architecture"],
+            "os": "linux",
+            "config": overlay_base_config(from_image, conf["config"]),
+            "rootfs": {
+                "diff_ids": [f"sha256:{layer.checksum}" for layer in layers],
+                "type": "layers",
+            },
+            "history": [
+                {
+                  "created": datetime.isoformat(created),
+                  "comment": f"store paths: {layer.paths}"
+                }
+                for layer in layers
+            ],
+        }
+
+        image_json = json.dumps(image_json, indent=4).encode("utf-8")
+        image_json_checksum = hashlib.sha256(image_json).hexdigest()
+        image_json_path = f"{image_json_checksum}.json"
+        add_bytes(tar, image_json_path, image_json, mtime=mtime)
+
+        manifest_json = [
+            {
+                "Config": image_json_path,
+                "RepoTags": [conf["repo_tag"]],
+                "Layers": [layer.path for layer in layers],
+            }
+        ]
+        manifest_json = json.dumps(manifest_json, indent=4).encode("utf-8")
+        add_bytes(tar, "manifest.json", manifest_json, mtime=mtime)
+
+        print("Done.", file=sys.stderr)
+
+
+if __name__ == "__main__":
+    main()
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index afef79185f..0bfd011ad4 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -45,6 +46,7 @@ (define-module (gnu system image)
   #:use-module (gnu system uuid)
   #:use-module (gnu system vm)
   #:use-module (guix packages)
+  #:use-module ((gnu packages) #:select (search-auxiliary-file))
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages bootloaders)
@@ -58,6 +60,7 @@ (define-module (gnu system image)
   #:use-module (gnu packages hurd)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages mtools)
+  #:use-module (gnu packages python)
   #:use-module (gnu packages virtualization)
   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
   #:use-module (srfi srfi-11)
@@ -78,6 +81,7 @@ (define-module (gnu system image)
             efi-disk-image
             iso9660-image
             docker-image
+            docker-layered-image
             tarball-image
             wsl2-image
             raw-with-offset-disk-image
@@ -89,6 +93,7 @@ (define-module (gnu system image)
             iso-image-type
             uncompressed-iso-image-type
             docker-image-type
+            docker-layered-image-type
             tarball-image-type
             wsl2-image-type
             raw-with-offset-image-type
@@ -167,6 +172,10 @@ (define docker-image
   (image-without-os
    (format 'docker)))
 
+(define docker-layered-image
+  (image-without-os
+   (format 'docker-layered)))
+
 (define tarball-image
   (image-without-os
    (format 'tarball)))
@@ -237,6 +246,11 @@ (define docker-image-type
    (name 'docker)
    (constructor (cut image-with-os docker-image <>))))
 
+(define docker-layered-image-type
+  (image-type
+   (name 'docker-layered)
+   (constructor (cut image-with-os docker-layered-image <>))))
+
 (define tarball-image-type
   (image-type
    (name 'tarball)
@@ -633,9 +647,12 @@ (define (image-with-label base-image label)
 
 (define* (system-docker-image image
                               #:key
-                              (name "docker-image"))
+                              (name "docker-image")
+                              (archiver tar)
+                              layered-image?)
   "Build a docker image for IMAGE.  NAME is the base name to use for the
-output file."
+output file.  If LAYERED-IMAGE? is true, the image will with many of the store
+paths being on their own layer to improve sharing between images."
   (define boot-program
     ;; Program that runs the boot script of OS, which in turn starts shepherd.
     (program-file "boot-program"
@@ -678,9 +695,11 @@ (define builder
               (use-modules (guix docker)
                            (guix build utils)
                            (gnu build image)
+                           (srfi srfi-1)
                            (srfi srfi-19)
                            (guix build store-copy)
-                           (guix store database))
+                           (guix store database)
+                           (ice-9 receive))
 
               ;; Set the SQL schema location.
               (sql-schema #$schema)
@@ -700,18 +719,34 @@ (define builder
                                            #:register-closures? #$register-closures?
                                            #:deduplicate? #f
                                            #:system-directory #$os)
-                (build-docker-image
-                 #$output
-                 (cons* image-root
-                        (map store-info-item
-                             (call-with-input-file #$graph
-                               read-reference-graph)))
-                 #$os
-                 #:entry-point '(#$boot-program #$os)
-                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-                 #:creation-time (make-time time-utc 0 1)
-                 #:system #$image-target
-                 #:transformations `((,image-root -> ""))))))))
+                (when #$layered-image?
+                  (setenv "PATH"
+                          (string-join (list #+(file-append archiver "/bin")
+                                             #+(file-append coreutils "/bin")
+                                             #+(file-append gzip "/bin")
+                                             #+(file-append python "/bin"))
+                                       ":")))
+                (apply build-docker-image
+                       (append (list #$output
+                                     (append (if #$layered-image?
+                                                 '()
+                                                 (list image-root))
+                                             (map store-info-item
+                                                  (call-with-input-file #$graph
+                                                    read-reference-graph)))
+                                     #$os
+                                     #:entry-point '(#$boot-program #$os)
+                                     #:compressor
+                                     '(#+(file-append gzip "/bin/gzip") "-9n")
+                                     #:creation-time (make-time time-utc 0 1)
+                                     #:system #$image-target
+                                     #:transformations `((,image-root -> "")))
+                               (if #$layered-image?
+                                   (list #:root-system
+                                         image-root
+                                         #:stream-layered-image
+                                         #$stream-layered-image.py)
+                                   '()))))))))
 
     (computed-file name builder
                    ;; Allow offloading so that this I/O-intensive process
@@ -720,6 +755,21 @@ (define builder
                    #:options `(#:references-graphs ((,graph ,os))
                                #:substitutable? ,substitutable?))))
 
+(define stream-layered-image.py
+  (local-file (search-auxiliary-file "python/stream-layered-image.py")))
+
+(define* (system-docker-layered-image image
+                                      #:key
+                                      (name "docker-image")
+                                      (archiver tar)
+                                      (layered-image? #t))
+  "Build a docker image for IMAGE.  NAME is the base name to use for the
+output file."
+  (system-docker-image image
+                       #:name name
+                       #:archiver archiver
+                       #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Tarball image.
@@ -811,7 +861,7 @@ (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
   (case (image-format image)
     ((iso9660) "iso9660")
-    ((docker tarball wsl2) "dummy")
+    ((docker docker-layered tarball wsl2) "dummy")
     (else
      (partition-file-system (find-root-partition image)))))
 
@@ -948,6 +998,8 @@ (define target (cond
                                        ("bootcfg" ,bootcfg))))
        ((memq image-format '(docker))
         (system-docker-image image*))
+       ((memq image-format '(docker-layered))
+        (system-docker-layered-image image*))
        ((memq image-format '(tarball))
         (system-tarball-image image*))
        ((memq image-format '(wsl2))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 0276e398a7..85c5f178b5 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,7 +44,8 @@ (define-module (gnu tests docker)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (%test-docker
-            %test-docker-system))
+            %test-docker-system
+            %test-docker-layered-system))
 
 (define %docker-os
   (simple-operating-system
@@ -309,3 +311,19 @@ (define %test-docker-system
                                    (locale-libcs (list glibc)))
                                  #:type docker-image-type)))
                  run-docker-system-test)))))
+
+(define %test-docker-layered-system
+  (system-test
+   (name "docker-layered-system")
+   (description "Run a system image as produced by @command{guix system
+docker-layered-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (lower-object
+                  (system-image (os->image
+                                 (operating-system
+                                   (inherit (simple-operating-system))
+                                   ;; Use locales for a single libc to
+                                   ;; reduce space requirements.
+                                   (locale-libcs (list glibc)))
+                                 #:type docker-layered-image-type)))
+                 run-docker-system-test)))))
diff --git a/guix/docker.scm b/guix/docker.scm
index 5e6460f43f..f1adad26dc 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,10 +25,14 @@ (define-module (guix docker)
   #:use-module (guix base16)
   #:use-module (guix build pack)
   #:use-module ((guix build utils)
-                #:select (mkdir-p
+                #:select (%store-directory
+                          mkdir-p
                           delete-file-recursively
+                          dump-port
                           with-directory-excursion
                           invoke))
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-1)
@@ -38,6 +43,9 @@ (define-module (guix docker)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
   #:export (build-docker-image))
 
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
@@ -136,6 +144,9 @@ (define directive-file
     (('directory name _ ...)
      (string-trim name #\/))))
 
+(define %docker-image-max-layers
+  100)
+
 (define* (build-docker-image image paths prefix
                              #:key
                              (repository "guix")
@@ -146,11 +157,13 @@ (define* (build-docker-image image paths prefix
                              entry-point
                              (environment '())
                              compressor
-                             (creation-time (current-time time-utc)))
-  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
-must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
-is a descriptive name that will show up in \"REPOSITORY\" column of the output
-of \"docker images\".
+                             (creation-time (current-time time-utc))
+                             stream-layered-image
+                             root-system)
+  "Write to IMAGE a layerer Docker image archive containing the given PATHS.
+PREFIX must be a store path that is a prefix of any store paths in PATHS.
+REPOSITORY is a descriptive name that will show up in \"REPOSITORY\" column of
+the output of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -172,7 +185,13 @@ (define* (build-docker-image image paths prefix
 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
 PATHS 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."
+SRFI-19 time-utc object, as the creation time in metadata.
+
+STREAM-LAYERED-IMAGE is a Python script which accepts a JSON configuration
+file and prints archive to STDOUT.
+
+ROOT-SYSTEM is a directory with a provisioned root file system, which will be
+added to image as a layer."
   (define (sanitize path-fragment)
     (escape-special-chars
      ;; GNU tar strips the leading slash off of absolute paths before applying
@@ -183,6 +202,39 @@ (define (sanitize path-fragment)
      ;; We also need to escape "/" because we use it as a delimiter.
      "/*.^$[]\\"
      #\\))
+  (define (file-sha256 file-name)
+    "Calculate the hexdigest of the sha256 checksum of FILE-NAME and return it."
+    (let ((port (open-pipe* OPEN_READ
+                            "sha256sum"
+                            "--"
+                            file-name)))
+      (let ((result (read-delimited " " port)))
+        (close-pipe port)
+        result)))
+  (define (paths-split-sort paths)
+    "Split list of PATHS at %DOCKER-IMAGE-MAX-LAYERS and sort by disk usage."
+    (let* ((paths-length (length paths))
+           (port (apply open-pipe* OPEN_READ
+                        (append '("du" "--summarize") paths)))
+           (output (read-string port)))
+      (close-port port)
+      (receive (head tail)
+          (split-at
+           (map (match-lambda ((size . path) path))
+                (sort (map (lambda (line)
+                             (match (string-split line #\tab)
+                               ((size path)
+                                (cons (string->number size) path))))
+                           (string-split
+                            (string-trim-right output #\newline)
+                            #\newline))
+                      (lambda (path1 path2)
+                        (< (match path2 ((size . _) size))
+                           (match path1 ((size . _) size))))))
+           (if (>= paths-length %docker-image-max-layers)
+               (- %docker-image-max-layers 2)
+               (1- paths-length)))
+        (list head tail))))
   (define transformation->replacement
     (match-lambda
       ((old '-> new)
@@ -205,7 +257,9 @@ (define transformation-options
         `("--transform" ,(transformations->expression transformations))))
   (let* ((directory "/tmp/docker-image") ;temporary working directory
          (id (docker-id prefix))
-         (time (date->string (time-utc->date creation-time) "~4"))
+         (time ;Workaround for Python datetime.fromisoformat does not parse Z.
+          (string-append (date->string (time-utc->date creation-time) "~5")
+                         "+00:00"))
          (arch (let-syntax ((cond* (syntax-rules ()
                                      ((_ (pattern clause) ...)
                                       (cond ((string-prefix? pattern system)
@@ -218,7 +272,8 @@ (define transformation-options
                         ("i686"    "386")
                         ("arm"     "arm")
                         ("aarch64" "arm64")
-                        ("mips64"  "mips64le")))))
+                        ("mips64"  "mips64le"))))
+         (paths (if stream-layered-image (paths-split-sort paths) paths)))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
     (with-directory-excursion directory
@@ -229,26 +284,38 @@ (define transformation-options
         (with-output-to-file "json"
           (lambda () (scm->json (image-description id time))))
 
-        ;; Create a directory for the non-store files that need to go into the
-        ;; archive.
-        (mkdir "extra")
+        (if root-system
+            (let ((directory (getcwd)))
+              (with-directory-excursion root-system
+                (apply invoke "tar"
+                       "-cf" (string-append directory "/layer.tar")
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." "..")))))))))
+            (begin
+              ;; Create a directory for the non-store files that need to go
+              ;; into the archive.
+              (mkdir "extra")
 
-        (with-directory-excursion "extra"
-          ;; Create non-store files.
-          (for-each (cut evaluate-populate-directive <> "./")
-                    extra-files)
+              (with-directory-excursion "extra"
+                ;; Create non-store files.
+                (for-each (cut evaluate-populate-directive <> "./")
+                          extra-files)
 
-          (when database
-            ;; Initialize /var/guix, assuming PREFIX points to a profile.
-            (install-database-and-gc-roots "." database prefix))
+                (when database
+                  ;; Initialize /var/guix, assuming PREFIX points to a profile.
+                  (install-database-and-gc-roots "." database prefix))
 
-          (apply invoke "tar" "-cf" "../layer.tar"
-                 `(,@transformation-options
-                   ,@(tar-base-options)
-                   ,@paths
-                   ,@(scandir "."
-                              (lambda (file)
-                                (not (member file '("." ".."))))))))
+                (apply invoke "tar" "-cf" "../layer.tar"
+                       `(,@transformation-options
+                         ,@(tar-base-options)
+                         ,@(if stream-layered-image '() paths)
+                         ,@(scandir "."
+                                    (lambda (file)
+                                      (not (member file '("." ".."))))))))
+              (delete-file-recursively "extra")))
 
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -263,22 +330,65 @@ (define transformation-options
           (lambda ()
             (system* "tar" "--delete" "/" "-f" "layer.tar")))
 
-        (delete-file-recursively "extra"))
+        (when stream-layered-image
+          (call-with-output-file "checksum"
+            (lambda (port)
+              (display (file-sha256 "layer.tar") port)))))
 
       (with-output-to-file "config.json"
         (lambda ()
-          (scm->json (config (string-append id "/layer.tar")
-                             time arch
-                             #:environment environment
-                             #:entry-point entry-point))))
+          (scm->json
+           (if stream-layered-image
+               `(("created" . ,time)
+                 ("repo_tag" . "guix:latest")
+                 ("customisation_layer" . ,id)
+                 ("store_layers" . ,(match paths
+                                      (((head ...) (tail ...))
+                                       (list->vector
+                                        (reverse
+                                         (cons (list->vector tail)
+                                               (fold (lambda (path paths)
+                                                       (cons (vector path) paths))
+                                                     '()
+                                                     head)))))))
+                 ("store_dir" . ,(%store-directory))
+                 ("from_image" . #nil)
+                 ("os" . "linux")
+                 ("config"
+                  (env . ,(list->vector (map (match-lambda
+                                               ((name . value)
+                                                (string-append name "=" value)))
+                                             environment)))
+                  ,@(if entry-point
+                        `((entrypoint . ,(list->vector entry-point)))
+                        '()))
+                 ("architecture" . ,arch))
+               (config (string-append id "/layer.tar")
+                       time arch
+                       #:environment environment
+                       #:entry-point entry-point)))))
       (with-output-to-file "manifest.json"
         (lambda ()
           (scm->json (manifest prefix id repository))))
       (with-output-to-file "repositories"
         (lambda ()
-          (scm->json (repositories prefix id repository)))))
-
-    (apply invoke "tar" "-cf" image "-C" directory
-           `(,@(tar-base-options #:compressor compressor)
-             "."))
+          (scm->json (repositories prefix id repository))))
+      (if stream-layered-image
+          (let ((input (open-pipe* OPEN_READ "python3"
+                                   stream-layered-image
+                                   "config.json")))
+            (call-with-output-file "image.tar"
+              (lambda (output)
+                (dump-port input output)))
+            (if (eqv? 0 (status:exit-val (close-pipe input)))
+                (begin
+                  (invoke "gzip" "image.tar")
+                  (copy-file "image.tar.gz" image))
+                (error
+                 (formatted-message
+                  (G_ "failed to create ~a image tarball")
+                  image))))
+          (apply invoke "tar" "-cf" image
+                 `(,@(tar-base-options #:compressor compressor)
+                   "."))))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index eb41eb5563..3a8f87e850 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,6 +55,7 @@ (define-module (guix scripts pack)
   #:use-module ((gnu packages compression) #:hide (zip))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages python)
   #:autoload   (gnu packages package-management) (guix)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
@@ -69,6 +71,7 @@ (define-module (guix scripts pack)
             debian-archive
             rpm-archive
             docker-image
+            docker-layered-image
             squashfs-image
 
             %formats
@@ -591,6 +594,10 @@ (define (mksquashfs args)
 ;;;
 ;;; Docker image format.
 ;;;
+
+(define stream-layered-image.py
+  (local-file (search-auxiliary-file "python/stream-layered-image.py")))
+
 (define* (docker-image name profile
                        #:key target
                        (profile-name "guix-profile")
@@ -599,12 +606,14 @@ (define* (docker-image name profile
                        localstatedir?
                        (symlinks '())
                        (archiver tar)
-                       (extra-options '()))
+                       (extra-options '())
+                       layered-image?)
   "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."
+the image.  If LAYERED-IMAGE? is true, the image will with many of the
+store paths being on their own layer to improve sharing between images."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -655,25 +664,37 @@ (define directives
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (setenv "PATH" #+(file-append archiver "/bin"))
-
-            (build-docker-image #$output
-                                (map store-info-item
-                                     (call-with-input-file "profile"
-                                       read-reference-graph))
-                                #$profile
-                                #:repository (manifest->friendly-name
-                                              (profile-manifest #$profile))
-                                #:database #+database
-                                #:system (or #$target %host-type)
-                                #:environment environment
-                                #:entry-point
-                                #$(and entry-point
-                                       #~(list (string-append #$profile "/"
-                                                              #$entry-point)))
-                                #:extra-files directives
-                                #:compressor #+(compressor-command compressor)
-                                #:creation-time (make-time time-utc 0 1))))))
+            (setenv "PATH"
+                    (string-join `(#+(file-append archiver "/bin")
+                                   #+@(if layered-image?
+                                          (list (file-append coreutils "/bin")
+                                                (file-append gzip "/bin")
+                                                (file-append python "/bin"))
+                                          '()))
+                                 ":"))
+
+            (apply build-docker-image
+                   (append (list #$output
+                                 (map store-info-item
+                                      (call-with-input-file "profile"
+                                        read-reference-graph))
+                                 #$profile
+                                 #:repository (manifest->friendly-name
+                                               (profile-manifest #$profile))
+                                 #:database #+database
+                                 #:system (or #$target %host-type)
+                                 #:environment environment
+                                 #:entry-point
+                                 #$(and entry-point
+                                        #~(list (string-append #$profile "/"
+                                                               #$entry-point)))
+                                 #:extra-files directives
+                                 #:compressor #+(compressor-command compressor)
+                                 #:creation-time (make-time time-utc 0 1))
+                           (if #$layered-image?
+                               (list #:stream-layered-image
+                                     #$stream-layered-image.py)
+                               '())))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -681,6 +702,33 @@ (define directives
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (docker-layered-image name profile
+                               #:key target
+                               (profile-name "guix-profile")
+                               (compressor (first %compressors))
+                               entry-point
+                               localstatedir?
+                               (symlinks '())
+                               (archiver tar)
+                               (extra-options '())
+                               (layered-image? #t))
+  "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.  If LAYERED-IMAGE? is true, the image will with many of the store paths
+being on their own layer to improve sharing between images."
+  (docker-image name profile
+                #:target target
+                #:profile-name profile-name
+                #:compressor compressor
+                #:entry-point entry-point
+                #:localstatedir? localstatedir?
+                #:symlinks symlinks
+                #:archiver archiver
+                #:extra-options extra-options
+                #:layered-image? layered-image?))
+
 \f
 ;;;
 ;;; Debian archive format.
@@ -1357,6 +1405,7 @@ (define %formats
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)
+    (docker-layered  . ,docker-layered-image)
     (deb . ,debian-archive)
     (rpm . ,rpm-archive)))
 
@@ -1365,15 +1414,17 @@ (define (show-formats)
   (display (G_ "The supported formats for 'guix pack' are:"))
   (newline)
   (display (G_ "
-  tarball       Self-contained tarball, ready to run on another machine"))
+  tarball        Self-contained tarball, ready to run on another machine"))
+  (display (G_ "
+  squashfs       Squashfs image suitable for Singularity"))
   (display (G_ "
-  squashfs      Squashfs image suitable for Singularity"))
+  docker         Tarball ready for 'docker load'"))
   (display (G_ "
-  docker        Tarball ready for 'docker load'"))
+  docker-layered Tarball with a layered image ready for 'docker load'"))
   (display (G_ "
-  deb           Debian archive installable via dpkg/apt"))
+  deb            Debian archive installable via dpkg/apt"))
   (display (G_ "
-  rpm           RPM archive installable via rpm/yum"))
+  rpm            RPM archive installable via rpm/yum"))
   (newline))
 
 (define (required-option symbol)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index c0bc295c00..e9123e679a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -11,6 +11,7 @@
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -734,13 +735,15 @@ (define* (system-derivation-for-action image action
                                               #:graphic? graphic?
                                               #:disk-image-size image-size
                                               #:mappings mappings))
-      ((image disk-image vm-image docker-image)
+      ((image disk-image vm-image docker-image docker-layered-image)
        (when (eq? action 'disk-image)
          (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'vm-image)
          (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
        (when (eq? action 'docker-image)
          (warning (G_ "'docker-image' is deprecated: use 'image' instead~%")))
+       (when (eq? action 'docker-layered-image)
+         (warning (G_ "'docker-layered-image' is deprecated: use 'image' instead~%")))
        (lower-object (system-image image))))))
 
 (define (maybe-suggest-running-guix-pull)
@@ -987,6 +990,8 @@ (define (show-help)
    image            build a Guix System image\n"))
   (display (G_ "\
    docker-image     build a Docker image\n"))
+  (display (G_ "\
+   docker-layered-image build a Docker layered image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1200,7 +1205,7 @@ (define actions '("build" "container" "vm" "vm-image" "image" "disk-image"
                   "list-generations" "describe"
                   "delete-generations" "roll-back"
                   "switch-generation" "search" "edit"
-                  "docker-image"))
+                  "docker-image" "docker-layered-image"))
 
 (define (process-action action args opts)
   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
@@ -1249,6 +1254,8 @@ (define save-provenance?
          (image       (let* ((image-type (case action
                                            ((vm-image) qcow2-image-type)
                                            ((docker-image) docker-image-type)
+                                           ((docker-layered-image)
+                                            docker-layered-image-type)
                                            (else image-type)))
                             (image-size (assoc-ref opts 'image-size))
                             (volatile?
diff --git a/tests/pack.scm b/tests/pack.scm
index 87187bb62c..db2208d91c 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@ (define-module (test-pack)
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (%store-directory))
   #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
   #:use-module (gnu packages bootstrap)
@@ -246,6 +248,52 @@ (define bin
                             (mkdir #$output)))))))
       (built-derivations (list check))))
 
+  (unless store (test-skip 1))
+  (test-assertm "docker-layered-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile)))
+                      (hooks '())
+                      (locales? #f)))
+         (tarball (docker-layered-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #:localstatedir? #t))
+         (check   (gexp->derivation "check-tarball"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils)
+                                       (ice-9 match))
+
+                          (define bin
+                            (string-append "." #$profile "/bin"))
+
+                          (define store
+                            (string-append "." #$(%store-directory)))
+
+                          (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+                          (mkdir "base")
+                          (with-directory-excursion "base"
+                            (invoke "tar" "xvf" #$tarball))
+
+                          (match (find-files "base" "layer.tar")
+                            ((layers ...)
+                             (for-each (lambda (layer)
+                                         (invoke "tar" "xvf" layer)
+                                         (invoke "chmod" "--recursive" "u+w" store))
+                                       layers)))
+
+                          (when
+                              (and (file-exists? (string-append bin "/guile"))
+                                   (file-exists? "var/guix/db/db.sqlite")
+                                   (file-is-directory? "tmp")
+                                   (string=? (string-append #$%bootstrap-guile "/bin")
+                                             (pk 'binlink (readlink bin)))
+                                   (string=? (string-append #$profile "/bin/guile")
+                                             (pk 'guilelink (readlink "bin/Guile"))))
+                            (mkdir #$output)))))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "squashfs-image + localstatedir" store
     (mlet* %store-monad
-- 
2.38.0





^ permalink raw reply related	[relevance 28%]

* [bug#61789] [PATCH 27/27] services: dbus: Deprecate 'dbus-service' procedure.
    2023-02-25 18:58 60% ` [bug#61789] [PATCH 18/27] services: dbus: Deprecate 'polkit-service' procedure Bruno Victal
@ 2023-02-25 18:58 47% ` Bruno Victal
  1 sibling, 0 replies; 149+ results
From: Bruno Victal @ 2023-02-25 18:58 UTC (permalink / raw)
  To: 61789; +Cc: Bruno Victal

* doc/guix.texi (Desktop Services): Replace with 'dbus-root-service-type'.
Document dbus-configuration.
* gnu/services/dbus.scm (dbus-service): Define with 'define-deprecated'.
* gnu/services/desktop.scm (desktop-services-for-system): Replace with
dbus-root-service-type.
* gnu/system/install.scm (%installation-services): Ditto.
* gnu/tests/base.scm (%avahi-os): Ditto.
* gnu/tests/docker.scm (%docker-os): Ditto.
* gnu/tests/lightdm.scm (minimal-desktop-services): Ditto.
* gnu/tests/virtualization.scm (%libvirt-os): Ditto.
---
 doc/guix.texi                | 49 +++++++++++++++++++++++-------------
 gnu/services/dbus.scm        |  5 ++--
 gnu/services/desktop.scm     |  2 +-
 gnu/system/install.scm       |  2 +-
 gnu/tests/base.scm           |  2 +-
 gnu/tests/docker.scm         |  2 +-
 gnu/tests/lightdm.scm        |  2 +-
 gnu/tests/virtualization.scm |  2 +-
 8 files changed, 40 insertions(+), 26 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index a40d88455b..2dc3ca7d1f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -23293,24 +23293,37 @@ Desktop Services
 provided by @code{(gnu services dbus)} and @code{(gnu services desktop)}
 are described below.
 
-@deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()] @
-                                       [#:verbose?]
-Return a service that runs the ``system bus'', using @var{dbus}, with
-support for @var{services}.  When @var{verbose?} is true, it causes the
-@samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
-verbose-enabled D-Bus package such as @code{dbus-verbose} should be
-provided as @var{dbus} in this scenario.  The verbose output is logged
-to @file{/var/log/dbus-daemon.log}.
-
-@uref{https://dbus.freedesktop.org/, D-Bus} is an inter-process communication
-facility.  Its system bus is used to allow system services to communicate
-and to be notified of system-wide events.
-
-@var{services} must be a list of packages that provide an
-@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
-and policy files.  For example, to allow avahi-daemon to use the system bus,
-@var{services} must be equal to @code{(list avahi)}.
-@end deffn
+@defvar dbus-root-service-type
+Type for a service that runs the D-Bus ``system bus''.
+@footnote{@uref{https://dbus.freedesktop.org/, D-Bus} is an inter-process
+communication facility.  Its system bus is used to allow system services
+to communicate and to be notified of system-wide events.}
+
+The value for this service type is a @code{<dbus-configuration>} record.
+@end defvar
+
+@deftp {Data Type} dbus-configuration
+Data type representing the configuration for @code{dbus-root-service-type}.
+
+@table @asis
+@item @code{dbus} (default: @code{dbus}) (type: file-like)
+Package object for dbus.
+
+@item @code{services} (default: @code{()}) (type: list)
+List of packages that provide an @file{etc/dbus-1/system.d} directory
+containing additional D-Bus configuration and policy files.
+For example, to allow avahi-daemon to use the system bus, @var{services}
+must be equal to @code{(list avahi)}.
+
+@item @code{verbose?} (default: @code{#f}) (type: boolean)
+When @code{#t}, D-Bus is launched with environment variable
+@samp{DBUS_VERBOSE} set to @samp{1}.  A verbose-enabled D-Bus package
+such as @code{dbus-verbose} should be provided to @var{dbus} in this
+scenario. The verbose output is logged to
+@file{/var/log/dbus-daemon.log}.
+
+@end table
+@end deftp
 
 @subsubheading Elogind
 
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index ea2593501f..e9c9346f56 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -38,7 +38,7 @@ (define-module (gnu services dbus)
   #:export (dbus-configuration
             dbus-configuration?
             dbus-root-service-type
-            dbus-service
+            dbus-service  ; deprecated
             wrapped-dbus-service
 
             polkit-configuration
@@ -245,7 +245,8 @@ (define dbus-root-service-type
 bus.  It allows programs and daemons to communicate and is also responsible
 for spawning (@dfn{activating}) D-Bus services on demand.")))
 
-(define* (dbus-service #:key (dbus dbus) (services '()) verbose?)
+(define-deprecated (dbus-service #:key (dbus dbus) (services '()) verbose?)
+  dbus-root-service-type
   "Return a service that runs the \"system bus\", using @var{dbus}, with
 support for @var{services}.  When @var{verbose?} is true, it causes the
 @samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 202bf1de80..2d39b4f9d1 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -1821,7 +1821,7 @@ (define* (desktop-services-for-system #:optional
          (service geoclue-service-type)
          (service polkit-service-type)
          (service elogind-service-type)
-         (dbus-service)
+         (service dbus-root-service-type)
 
          (service ntp-service-type)
 
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index dd965f312b..7a68c19606 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -442,7 +442,7 @@ (define* (%installation-services #:key (system (or (and=>
                     (list %loopback-static-networking))
 
            (service wpa-supplicant-service-type)
-           (dbus-service)
+           (service dbus-root-service-type)
            (service connman-service-type
                     (connman-configuration
                      (disable-vpn? #t)))
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 3e72e193d7..97edbbc6ad 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -962,7 +962,7 @@ (define %avahi-os
     (name-service-switch %mdns-host-lookup-nss)
     (services (cons* (service avahi-service-type
                               (avahi-configuration (debug? #t)))
-                     (dbus-service)
+                     (service dbus-root-service-type)
                      (service dhcp-client-service-type) ;needed for multicast
 
                      ;; Enable heavyweight debugging output.
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index e464ec587e..0276e398a7 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -48,7 +48,7 @@ (define-module (gnu tests docker)
 (define %docker-os
   (simple-operating-system
    (service dhcp-client-service-type)
-   (dbus-service)
+   (service dbus-root-service-type)
    (service polkit-service-type)
    (service elogind-service-type)
    (service docker-service-type)))
diff --git a/gnu/tests/lightdm.scm b/gnu/tests/lightdm.scm
index aa97a96939..dda472bd74 100644
--- a/gnu/tests/lightdm.scm
+++ b/gnu/tests/lightdm.scm
@@ -49,7 +49,7 @@ (define minimal-desktop-services
         (service accountsservice-service-type)
         (service polkit-service-type)
         (service elogind-service-type)
-        (dbus-service)
+        (service dbus-root-service-type)
         x11-socket-directory-service))
 
 (define %lightdm-os
diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index 6749ade4bd..effdeb4cfa 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -49,7 +49,7 @@ (define-module (gnu tests virtualization)
 (define %libvirt-os
   (simple-operating-system
    (service dhcp-client-service-type)
-   (dbus-service)
+   (service dbus-root-service-type)
    (service polkit-service-type)
    (service libvirt-service-type)))
 
-- 
2.39.1





^ permalink raw reply related	[relevance 47%]

* [bug#61789] [PATCH 18/27] services: dbus: Deprecate 'polkit-service' procedure.
  @ 2023-02-25 18:58 60% ` Bruno Victal
  2023-02-25 18:58 47% ` [bug#61789] [PATCH 27/27] services: dbus: Deprecate 'dbus-service' procedure Bruno Victal
  1 sibling, 0 replies; 149+ results
From: Bruno Victal @ 2023-02-25 18:58 UTC (permalink / raw)
  To: 61789; +Cc: Bruno Victal

* doc/guix.texi (Desktop Services): Replace 'polkit-service' with 'polkit-service-type'.
* gnu/services/dbus.scm (polkit-service): Deprecate procedure.
* gnu/tests/docker.scm (%docker-os): Use polkit-service-type.
* gnu/tests/virtualization.scm (%libvirt-os): Ditto.
---
 doc/guix.texi                | 14 +++++++++-----
 gnu/services/dbus.scm        |  6 ++++--
 gnu/tests/docker.scm         |  2 +-
 gnu/tests/virtualization.scm |  2 +-
 4 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 1831528ef3..4ed77d6715 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -23432,16 +23432,20 @@ Desktop Services
 set to @code{accountsservice} (the package object for AccountsService).
 @end defvar
 
-@deffn {Scheme Procedure} polkit-service @
-                         [#:polkit @var{polkit}]
-Return a service that runs the
-@uref{https://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
+@defvar polkit-service-type
+Type for the service that runs the
+@url{https://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
 management service}, which allows system administrators to grant access to
 privileged operations in a structured way.  By querying the Polkit service, a
 privileged system component can know when it should grant additional
 capabilities to ordinary users.  For example, an ordinary user can be granted
 the capability to suspend the system if the user is logged in locally.
-@end deffn
+
+The value for this service is a @code{<polkit-configuration>} object.
+@end defvar
+
+@c TODO: Document <polkit-configuration>, preferably by refactoring this to use
+@c       define-configuration and generating documentation from it.
 
 @defvar polkit-wheel-service
 Service that adds the @code{wheel} group as admins to the Polkit
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 5efd6bdadf..ea2593501f 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -28,6 +28,7 @@ (define-module (gnu services dbus)
   #:use-module ((gnu packages glib) #:select (dbus))
   #:use-module (gnu packages polkit)
   #:use-module (gnu packages admin)
+  #:use-module (guix deprecation)
   #:use-module (guix gexp)
   #:use-module ((guix packages) #:select (package-name))
   #:use-module (guix records)
@@ -43,7 +44,7 @@ (define-module (gnu services dbus)
             polkit-configuration
             polkit-configuration?
             polkit-service-type
-            polkit-service))
+            polkit-service))  ; deprecated
 
 ;;;
 ;;; D-Bus.
@@ -404,7 +405,8 @@ (define polkit-service-type
 privileged operations in a structured way.  Polkit is a requirement for most
 desktop environments, such as GNOME.")))
 
-(define* (polkit-service #:key (polkit polkit))
+(define-deprecated (polkit-service #:key (polkit polkit))
+  polkit-service-type
   "Return a service that runs the
 @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
 management service}, which allows system administrators to grant access to
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 4267ff89a8..e464ec587e 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -49,7 +49,7 @@ (define %docker-os
   (simple-operating-system
    (service dhcp-client-service-type)
    (dbus-service)
-   (polkit-service)
+   (service polkit-service-type)
    (service elogind-service-type)
    (service docker-service-type)))
 
diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index 60789fbb5b..6749ade4bd 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -50,7 +50,7 @@ (define %libvirt-os
   (simple-operating-system
    (service dhcp-client-service-type)
    (dbus-service)
-   (polkit-service)
+   (service polkit-service-type)
    (service libvirt-service-type)))
 
 (define (run-libvirt-test)
-- 
2.39.1





^ permalink raw reply related	[relevance 60%]

* [bug#61692] [PATCH] services: dbus-service: Deprecate 'dbus-service' procedure.
@ 2023-02-21 23:31 46% Bruno Victal
  0 siblings, 0 replies; 149+ results
From: Bruno Victal @ 2023-02-21 23:31 UTC (permalink / raw)
  To: 61692; +Cc: Bruno Victal

* doc/guix.texi (Desktop Services): Replace with 'dbus-root-service-type'.
Document dbus-configuration.
* gnu/services/dbus.scm (dbus-service): Define with 'define-deprecated'.
* gnu/services/desktop.scm (desktop-services-for-system): Replace with
dbus-root-service-type.
* gnu/system/install.scm (%installation-services): Ditto.
* gnu/tests/base.scm (%avahi-os): Ditto.
* gnu/tests/docker.scm (%docker-os): Ditto.
* gnu/tests/lightdm.scm (minimal-desktop-services): Ditto.
* gnu/tests/virtualization.scm (%libvirt-os): Ditto.
---
 doc/guix.texi                | 49 +++++++++++++++++++++++-------------
 gnu/services/dbus.scm        |  6 +++--
 gnu/services/desktop.scm     |  2 +-
 gnu/system/install.scm       |  2 +-
 gnu/tests/base.scm           |  2 +-
 gnu/tests/docker.scm         |  2 +-
 gnu/tests/lightdm.scm        |  2 +-
 gnu/tests/virtualization.scm |  2 +-
 8 files changed, 41 insertions(+), 26 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 05615b9549..b85bef40c1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -23141,24 +23141,37 @@ Desktop Services
 provided by @code{(gnu services dbus)} and @code{(gnu services desktop)}
 are described below.
 
-@deffn {Scheme Procedure} dbus-service [#:dbus @var{dbus}] [#:services '()] @
-                                       [#:verbose?]
-Return a service that runs the ``system bus'', using @var{dbus}, with
-support for @var{services}.  When @var{verbose?} is true, it causes the
-@samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
-verbose-enabled D-Bus package such as @code{dbus-verbose} should be
-provided as @var{dbus} in this scenario.  The verbose output is logged
-to @file{/var/log/dbus-daemon.log}.
-
-@uref{https://dbus.freedesktop.org/, D-Bus} is an inter-process communication
-facility.  Its system bus is used to allow system services to communicate
-and to be notified of system-wide events.
-
-@var{services} must be a list of packages that provide an
-@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration
-and policy files.  For example, to allow avahi-daemon to use the system bus,
-@var{services} must be equal to @code{(list avahi)}.
-@end deffn
+@defvar dbus-root-service-type
+Type for a service that runs the D-Bus ``system bus''.
+@footnote{@uref{https://dbus.freedesktop.org/, D-Bus} is an inter-process
+communication facility.  Its system bus is used to allow system services
+to communicate and to be notified of system-wide events.}
+
+The value for this service type is a @code{<dbus-configuration>} record.
+@end defvar
+
+@deftp {Data Type} dbus-configuration
+Data type representing the configuration for @code{dbus-root-service-type}.
+
+@table @asis
+@item @code{dbus} (default: @code{dbus}) (type: file-like)
+Package object for dbus.
+
+@item @code{services} (default: @code{()}) (type: list)
+List of packages that provide an @file{etc/dbus-1/system.d} directory
+containing additional D-Bus configuration and policy files.
+For example, to allow avahi-daemon to use the system bus, @var{services}
+must be equal to @code{(list avahi)}.
+
+@item @code{verbose?} (default: @code{#f}) (type: boolean)
+When @code{#t}, D-Bus is launched with environment variable
+@samp{DBUS_VERBOSE} set to @samp{1}.  A verbose-enabled D-Bus package
+such as @code{dbus-verbose} should be provided to @var{dbus} in this
+scenario. The verbose output is logged to
+@file{/var/log/dbus-daemon.log}.
+
+@end table
+@end deftp
 
 @deffn {Scheme Procedure} elogind-service [#:config @var{config}]
 Return a service that runs the @code{elogind} login and
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 5efd6bdadf..c08a91221f 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -28,6 +28,7 @@ (define-module (gnu services dbus)
   #:use-module ((gnu packages glib) #:select (dbus))
   #:use-module (gnu packages polkit)
   #:use-module (gnu packages admin)
+  #:use-module (guix deprecation)
   #:use-module (guix gexp)
   #:use-module ((guix packages) #:select (package-name))
   #:use-module (guix records)
@@ -37,7 +38,7 @@ (define-module (gnu services dbus)
   #:export (dbus-configuration
             dbus-configuration?
             dbus-root-service-type
-            dbus-service
+            dbus-service  ; deprecated
             wrapped-dbus-service
 
             polkit-configuration
@@ -244,7 +245,8 @@ (define dbus-root-service-type
 bus.  It allows programs and daemons to communicate and is also responsible
 for spawning (@dfn{activating}) D-Bus services on demand.")))
 
-(define* (dbus-service #:key (dbus dbus) (services '()) verbose?)
+(define-deprecated (dbus-service #:key (dbus dbus) (services '()) verbose?)
+  dbus-root-service-type
   "Return a service that runs the \"system bus\", using @var{dbus}, with
 support for @var{services}.  When @var{verbose?} is true, it causes the
 @samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index fe1f0fd20a..0d3de32be6 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -1804,7 +1804,7 @@ (define* (desktop-services-for-system #:optional
          (geoclue-service)
          (service polkit-service-type)
          (elogind-service)
-         (dbus-service)
+         (service dbus-root-service-type)
 
          (service ntp-service-type)
 
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index b3cf7a1bd8..77ef577fd2 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -437,7 +437,7 @@ (define* (%installation-services #:key (system (or (and=>
                     (list %loopback-static-networking))
 
            (service wpa-supplicant-service-type)
-           (dbus-service)
+           (service dbus-root-service-type)
            (service connman-service-type
                     (connman-configuration
                      (disable-vpn? #t)))
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 3e72e193d7..97edbbc6ad 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -962,7 +962,7 @@ (define %avahi-os
     (name-service-switch %mdns-host-lookup-nss)
     (services (cons* (service avahi-service-type
                               (avahi-configuration (debug? #t)))
-                     (dbus-service)
+                     (service dbus-root-service-type)
                      (service dhcp-client-service-type) ;needed for multicast
 
                      ;; Enable heavyweight debugging output.
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 4267ff89a8..37946b2fbc 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -48,7 +48,7 @@ (define-module (gnu tests docker)
 (define %docker-os
   (simple-operating-system
    (service dhcp-client-service-type)
-   (dbus-service)
+   (service dbus-root-service-type)
    (polkit-service)
    (service elogind-service-type)
    (service docker-service-type)))
diff --git a/gnu/tests/lightdm.scm b/gnu/tests/lightdm.scm
index 57d029a75a..74c7b118a5 100644
--- a/gnu/tests/lightdm.scm
+++ b/gnu/tests/lightdm.scm
@@ -49,7 +49,7 @@ (define minimal-desktop-services
         (accountsservice-service)
         (service polkit-service-type)
         (elogind-service)
-        (dbus-service)
+        (service dbus-root-service-type)
         x11-socket-directory-service))
 
 (define %lightdm-os
diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm
index 60789fbb5b..9fe23aeeac 100644
--- a/gnu/tests/virtualization.scm
+++ b/gnu/tests/virtualization.scm
@@ -49,7 +49,7 @@ (define-module (gnu tests virtualization)
 (define %libvirt-os
   (simple-operating-system
    (service dhcp-client-service-type)
-   (dbus-service)
+   (service dbus-root-service-type)
    (polkit-service)
    (service libvirt-service-type)))
 

base-commit: fbbbc2088ce933d83f5b0be75308fdcb6b40fa57
-- 
2.39.1





^ permalink raw reply related	[relevance 46%]

* [bug#60770] [PATCH v2] gnu: Add docker-registry
  2023-01-13  4:59 63% [bug#60770] [PATCH v1] gnu: Add docker-registry Denis 'GNUtoo' Carikli
@ 2023-01-14 18:26 63% ` Denis 'GNUtoo' Carikli
  0 siblings, 0 replies; 149+ results
From: Denis 'GNUtoo' Carikli @ 2023-01-14 18:26 UTC (permalink / raw)
  To: 60770; +Cc: Denis 'GNUtoo' Carikli

* gnu/packages/docker.scm (docker-registry): New variable.

Signed-off-by: Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
---
 gnu/packages/docker.scm | 81 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 81 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 7d109dc94c..58c61ba02e 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -724,3 +724,84 @@ (define-public tini
 processes produced from it are reaped and that signals are properly forwarded.
 Tini is integrated with Docker.")
     (license license:expat)))
+
+(define-public docker-registry
+  (package
+    (name "docker-registry")
+    (version "2.8.1")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/docker/distribution")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1w8zr97p2c62gm1lrdwqa704ivjsy25ylznrddbbpv63idwdbi9k"))))
+    (build-system go-build-system)
+    (arguments
+     (list
+      #:import-path "github.com/docker/distribution"
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'chdir-to-src
+            (lambda _ (chdir "src/github.com/docker/distribution")))
+          (add-after 'chdir-to-src 'fix-versioning
+            (lambda _
+              ;; The Makefile use git to compute the version and the
+              ;; revision. This requires the .git directory that we don't
+              ;; have anymore in the unpacked source.
+              (substitute* "Makefile" (("^VERSION=\\$\\(.*\\)")
+                                       (string-append "VERSION=v" #$version))
+                           ;; The revision originally used the git hash with .m
+                           ;; appended if there was any local modifications.
+                           (("^REVISION=\\$\\(.*\\)") "REVISION=0"))))
+          (replace 'build
+            (lambda _
+              (invoke "make" "binaries")))
+          (replace 'install
+            (lambda _
+              (let ((bin (string-append #$output "/bin")))
+                (mkdir-p bin)
+                (for-each
+                 (lambda (file)
+                   (install-file (string-append "bin/" file) bin))
+                 '("digest"
+                   "registry"
+                   "registry-api-descriptor-template")))
+              (let ((doc (string-append
+                          #$output "/share/doc/" #$name "-" #$version)))
+                (mkdir-p doc)
+                (for-each
+                 (lambda (file)
+                   (install-file file doc))
+                 '("BUILDING.md"
+                   "CONTRIBUTING.md"
+                   "LICENSE"
+                   "MAINTAINERS"
+                   "README.md"
+                   "ROADMAP.md"))
+                (copy-recursively "docs/" (string-append doc "/docs")))
+              (let ((examples
+                     (string-append
+                      #$output "/share/doc/" #$name "-" #$version
+                      "/registry-example-configs")))
+                (mkdir-p examples)
+                (for-each
+                 (lambda (file)
+                   (install-file (string-append "cmd/registry/" file) examples))
+                 '("config-cache.yml"
+                   "config-example.yml"
+                   "config-dev.yml")))))
+      (delete 'install-license-files))))
+  (home-page "https://github.com/docker/distribution")
+  (synopsis "Docker registry server and associated tools")
+  (description "The Docker registry server enable you to host your own
+docker registry. With it, there is also two other utilities:
+@itemize
+@item The digest utility is a tool that generates checksums compatibles with
+various docker manifest files.
+@item The registry-api-descriptor-template is a tool for generating API
+specifications from the docs/spec/api.md.tmpl file.
+@end itemize")
+  (license license:asl2.0)))

base-commit: ef0613a81dca73602e702cb5f5444ee94566f983
-- 
2.38.1





^ permalink raw reply related	[relevance 63%]

* [bug#60770] [PATCH v1] gnu: Add docker-registry
@ 2023-01-13  4:59 63% Denis 'GNUtoo' Carikli
  2023-01-14 18:26 63% ` [bug#60770] [PATCH v2] " Denis 'GNUtoo' Carikli
  0 siblings, 1 reply; 149+ results
From: Denis 'GNUtoo' Carikli @ 2023-01-13  4:59 UTC (permalink / raw)
  To: 60770; +Cc: Denis 'GNUtoo' Carikli

* gnu/packages/docker.scm (docker-registry): New variable.

Signed-off-by: Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
---
 gnu/packages/docker.scm | 80 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 80 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 7d109dc94c..807c855a1a 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -724,3 +724,83 @@ (define-public tini
 processes produced from it are reaped and that signals are properly forwarded.
 Tini is integrated with Docker.")
     (license license:expat)))
+
+(define-public docker-registry
+  (package
+    (name "docker-registry")
+    (version "2.8.1")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/docker/distribution")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1w8zr97p2c62gm1lrdwqa704ivjsy25ylznrddbbpv63idwdbi9k"))))
+    (build-system go-build-system)
+    (arguments
+     (list
+      #:import-path "github.com/docker/distribution"
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'chdir-to-src
+            (lambda _ (chdir "src/github.com/docker/distribution")))
+          (add-after 'chdir-to-src 'fix-versioning
+            (lambda _
+              ;; The Makefile use git to compute the version and the
+              ;; revision. This requires the .git directory that we don't
+              ;; have anymore in the unpacked source.
+              (substitute* "Makefile" (("^VERSION=\\$\\(.*\\)")
+                                       (string-append "VERSION=v" #$version))
+                           ;; The revision originally used the git hash with .m
+                           ;; appended if there was any local modifications.
+                           (("^REVISION=\\$\\(.*\\)") "REVISION=0"))))
+          (replace 'build
+            (lambda _
+              (invoke "make" "binaries")))
+          (replace 'install
+            (lambda _
+              (let ((bin (string-append #$output "/bin")))
+                (mkdir-p bin)
+                (for-each
+                 (lambda (file)
+                   (install-file (string-append "bin/" file) bin))
+                 '("digest"
+                   "registry"
+                   "registry-api-descriptor-template")))
+              (let ((doc (string-append
+                          #$output "/share/doc/" #$name "-" #$version)))
+                (mkdir-p doc)
+                (for-each
+                 (lambda (file)
+                   (install-file file doc))
+                 '("BUILDING.md"
+                   "CONTRIBUTING.md"
+                   "LICENSE"
+                   "MAINTAINERS"
+                   "README.md"
+                   "ROADMAP.md")))
+              (let ((examples
+                     (string-append
+                      #$output "/share/doc/" #$name "-" #$version
+                      "/registry-example-configs")))
+                (mkdir-p examples)
+                (for-each
+                 (lambda (file)
+                   (install-file (string-append "cmd/registry/" file) examples))
+                 '("config-cache.yml"
+                   "config-example.yml"
+                   "config-dev.yml")))))
+      (delete 'install-license-files))))
+  (home-page "https://github.com/docker/distribution")
+  (synopsis "Docker registry server and associated tools")
+  (description "The Docker registry server enable you to host your own
+docker registry. With it, there is also two other utilities:
+@itemize
+@item The digest utility is a tool that generates checksums compatibles with
+various docker manifest files.
+@item The registry-api-descriptor-template is a tool for generating API
+specifications from the docs/spec/api.md.tmpl file.
+@end itemize")
+  (license license:asl2.0)))

base-commit: ef0613a81dca73602e702cb5f5444ee94566f983
-- 
2.38.1





^ permalink raw reply related	[relevance 63%]

* [bug#58123]
  2022-09-27 17:16 56% [bug#58123] [PATCH] gnu: services: docker: Add docker-container-service-type guix-patches--- via
@ 2022-10-02 20:38 59% ` guix-patches--- via
  0 siblings, 0 replies; 149+ results
From: guix-patches--- via @ 2022-10-02 20:38 UTC (permalink / raw)
  To: 58123, maximedevos

[-- Attachment #1: Type: text/plain, Size: 288 bytes --]

I have applied the changes as you suggested. Thank you for your (as you
said) "superficial comments", they were really helpful! And I am happy
that you made them, as I'm sometimes too happy that I have made a
contribution and I forget that I don't write only for myself, but for
others.


[-- Attachment #2: 0001-Add-docker-container-management-with-shepherd.patch --]
[-- Type: text/x-patch, Size: 13525 bytes --]

---
 gnu/services/docker.scm | 240 +++++++++++++++++++++++++++++++++++++---
 1 file changed, 222 insertions(+), 18 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 741bab5a8c..f3a347981f 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2022 Maya Tomasek <maya.omase@disroot.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,7 +22,9 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (gnu services docker)
+(define-module (magi system docker)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
   #:use-module (gnu services base)
@@ -36,9 +39,191 @@ (define-module (gnu services docker)
   #:use-module (guix packages)
 
   #:export (docker-configuration
+            docker-container
             docker-service-type
             singularity-service-type))
 
+(define (pair-of-strings? val)
+  (and (pair? val)
+       (string? (car val))
+       (string? (cdr val))))
+
+(define (list-of-pair-of-strings? val)
+  (list-of pair-of-strings?))
+
+(define-configuration/no-serialization docker-container
+  (name
+   (symbol '())
+   "Name of the docker container. Will be used to denote service to Shepherd and must be unique!
+We recommend, that the name of the container is prefixed with @code{docker-}.")
+  (documentation
+   (string "")
+   "Documentation on the docker container (optional). It will be used for the shepherd service.")
+  (image-name
+   (string #f)
+   "A name of the image that will be used. (Note that the existence of the image
+is not guaranteed by this daemon.)")
+  (volumes
+   (list-of-pair-of-strings '())
+   "A list of volume bindings. In (HOST-PATH CONTAINER-PATH) format.")
+  (ports
+   (list-of-pair-of-strings '())
+   "A list of port bindings. In (HOST-PORT CONTAINER-PORT) or (HOST-PORT CONTAINER-PORT OPTIONS) format.
+For example, both port bindings are valid:
+
+@lisp
+(ports '((\"2222\" \"22\") (\"21\" \"21\" \"tcp\")))
+@end lisp")
+  (environments
+   (list-of-pair-of-strings '())
+   "A list of environment variables, inside the container environment, in (VARIABLE VALUE) format.")
+  (network
+   (string "none")
+   "Network type.
+
+Available types are:
+@table @code
+@c Copied from https://docs.docker.com/network/
+
+@item none
+
+The default option. For this container, disable all networking. Usually used in
+conjunction with a custom network driver. none is not available for swarm services.
+
+@item bridge
+
+Bridge networks are usually used when your applications run in standalone
+containers that need to communicate.
+
+@item host
+
+For standalone containers, remove network isolation between the container and the Docker host, 
+and use the host’s networking directly.
+
+@item overlay
+
+Overlay networks connect multiple Docker daemons together and enable swarm services to
+communicate with each other. You can also use overlay networks to facilitate
+communication between a swarm service and a standalone container, or between
+two standalone containers on different Docker daemons. This strategy removes
+the need to do OS-level routing between these containers.
+
+@item ipvlan
+
+IPvlan networks give users total control over both IPv4 and IPv6 addressing.
+The VLAN driver builds on top of that in giving operators complete control of
+layer 2 VLAN tagging and even IPvlan L3 routing for users interested in underlay
+network integration.
+
+@item macvlan
+
+Macvlan networks allow you to assign a MAC address to a container, making it appear
+as a physical device on your network. The Docker daemon routes traffic to containers
+by their MAC addresses. Using the macvlan driver is sometimes the best choice when
+dealing with legacy applications that expect to be directly connected to the physical
+network, rather than routed through the Docker host’s network stack.
+
+@end table")
+  (additional-arguments
+   (list-of-strings '())
+   "Additional arguments to the docker command line interface.")
+  (container-command
+   (list-of-strings '())
+   "Command to send into the container.")
+  (pid-file-timeout
+   (number 5)
+   "If the docker container does not show up in @code{docker ps} as @code{running} in less than pid-file-timeout seconds, the container is considered as failing to start.
+
+Note that some containers take a really long time to start, so you should adjust it accordingly."))
+
+(define (serialize-volumes config)
+  "Serialize list of pairs into flat list of @code{(\"-v\" \"HOST_PATH:CONTAINER_PATH\" ...)}"
+  (append-map
+   (lambda (volume-bind)
+     (list "-v" (apply format #f "~a:~a~^:~a" volume-bind)))
+   (docker-container-volumes config)))
+
+(define (serialize-ports config)
+  "Serialize list of either pairs, or lists into flat list of
+@code{(\"-p\" \"NUMBER:NUMBER\" \"-p\" \"NUMBER:NUMBER/PROTOCOL\" ...)}"
+  (append-map
+   (lambda (port-bind)
+     (list "-p" (apply format #f "~a:~a~^/~a" port-bind)))
+   (docker-container-ports config)))
+
+(define (serialize-environments config)
+  "Serialize list of pairs into flat list of @code{(\"-e\" \"VAR=val\" \"-e\" \"VAR=val\" ...)}."
+  (append-map
+   (lambda (env-bind)
+     (list "-e" (apply format #f "~a=~a" env-bind)))
+   (docker-container-environments config)))
+
+(define (docker-container-startup-script docker-cli container-name cid-file config)
+  "Return a program file, that executes the startup sequence of the @code{docker-container-shepherd-service}."
+  (let* ((image-name (docker-container-image-name config))
+         (volumes (serialize-volumes config))
+         (ports (serialize-ports config))
+         (envs (serialize-environments config))
+         (network (docker-container-network config))
+         (additional-arguments (docker-container-additional-arguments config))
+         (container-command (docker-container-container-command config)))
+    (with-imported-modules
+     '((guix build utils))
+     (program-file
+      (string-append "start-" container-name "-container")
+      #~(let ((docker (string-append #$docker-cli "/bin/docker")))
+          (use-modules (guix build utils))
+          ;; These two commands should fail
+          ;; they are there as a failsafe to
+          ;; prevent contamination from unremoved containers
+          (system* docker "stop" #$container-name)
+          (system* docker "rm" #$container-name)
+          (apply invoke `(,docker
+                           "run"
+                           ,(string-append "--name=" #$container-name)
+                           ;; Automatically remove the container when stopping
+                           ;; If you want persistent data, you need to use
+                           ;; volume binds or other methods.
+                           "--rm"
+                           ,(string-append "--network=" #$network)
+                           ;; Write to a cid file the container id, this allows
+                           ;; for shepherd to manage container even when the process
+                           ;; itself gets detached from the container
+                           "--cidfile" #$cid-file
+                           #$@volumes
+                           #$@ports
+                           #$@envs
+                           #$@additional-arguments
+                           ,#$image-name
+                           #$@container-command)))))))
+
+(define (docker-container-shepherd-service docker-cli config)
+  "Return a shepherd-service that runs CONTAINER."
+  (let* ((container-name (symbol->string (docker-container-name config)))
+         (cid-file (string-append "/var/run/docker/" container-name ".pid"))
+         (pid-file-timeout (docker-container-pid-file-timeout config)))
+    (shepherd-service
+     (provision (list (docker-container-name config)))
+     (requirement `(dockerd))
+     (documentation (docker-container-documentation config))
+     (start #~(apply make-forkexec-constructor
+                     `(,(list #$(docker-container-startup-script docker-cli container-name cid-file config))
+                       ;; Watch the cid-file instead of the docker run command, as the daemon can
+                       ;; still be running even when the command terminates
+                       #:pid-file #$cid-file
+                       #:pid-file-timeout #$pid-file-timeout)))
+     (stop #~(lambda _
+               (invoke
+                (string-append #$docker-cli "/bin/docker")
+                "stop"
+                #$container-name)
+               ;; Shepherd expects the stop command to return #f if it succeeds
+               ;; docker stop should always succeed
+               #f)))))
+
+(define (list-of-docker-containers? val)
+  (list-of docker-container?))
+
 (define-configuration docker-configuration
   (docker
    (file-like docker)
@@ -65,8 +250,21 @@ (define-configuration docker-configuration
   (environment-variables
    (list '())
    "Environment variables to set for dockerd")
+  (containers
+   (list-of-docker-containers '())
+   "List of docker containers to run as shepherd services.")
   (no-serialization))
 
+(define (docker-container-shepherd-services config)
+  "Return shepherd services for all containers inside config."
+  (let ((docker-cli (docker-configuration-docker-cli config)))
+    (map
+     (lambda (container)
+       (docker-container-shepherd-service
+        docker-cli
+        container))
+     (docker-configuration-containers config))))
+
 (define %docker-accounts
   (list (user-group (name "docker") (system? #t))))
 
@@ -88,20 +286,20 @@ (define (containerd-shepherd-service config)
          (debug? (docker-configuration-debug? config))
          (containerd (docker-configuration-containerd config)))
     (shepherd-service
-           (documentation "containerd daemon.")
-           (provision '(containerd))
-           (start #~(make-forkexec-constructor
-                     (list (string-append #$package "/bin/containerd")
-                           #$@(if debug?
-                                  '("--log-level=debug")
-                                  '()))
-                     ;; For finding containerd-shim binary.
-                     #:environment-variables
-                     (list (string-append "PATH=" #$containerd "/bin"))
-                     #:pid-file "/run/containerd/containerd.pid"
-                     #:pid-file-timeout 300
-                     #:log-file "/var/log/containerd.log"))
-           (stop #~(make-kill-destructor)))))
+     (documentation "containerd daemon.")
+     (provision '(containerd))
+     (start #~(make-forkexec-constructor
+               (list (string-append #$package "/bin/containerd")
+                     #$@(if debug?
+                            '("--log-level=debug")
+                            '()))
+               ;; For finding containerd-shim binary.
+               #:environment-variables
+               (list (string-append "PATH=" #$containerd "/bin"))
+               #:pid-file "/run/containerd/containerd.pid"
+               #:pid-file-timeout 300
+               #:log-file "/var/log/containerd.log"))
+     (stop #~(make-kill-destructor)))))
 
 (define (docker-shepherd-service config)
   (let* ((docker (docker-configuration-docker config))
@@ -148,7 +346,7 @@ (define (docker-shepherd-service config)
 (define docker-service-type
   (service-type (name 'docker)
                 (description "Provide capability to run Docker application
-bundles in Docker containers.")
+bundles in Docker containers and optionally wrap those containers in shepherd services.")
                 (extensions
                  (list
                   ;; Make sure the 'docker' command is available.
@@ -158,10 +356,16 @@ (define docker-service-type
                                      %docker-activation)
                   (service-extension shepherd-root-service-type
                                      (lambda (config)
-                                       (list (containerd-shepherd-service config)
-                                             (docker-shepherd-service config))))
+                                       (cons* (containerd-shepherd-service config)
+                                              (docker-shepherd-service config)
+                                              (docker-container-shepherd-services config))))
                   (service-extension account-service-type
                                      (const %docker-accounts))))
+                (compose concatenate)
+                (extend (lambda (config containers)
+                          (docker-configuration
+                           (inherit config)
+                           (containers (append containers (docker-configuration-containers config))))))
                 (default-value (docker-configuration))))
 
 \f
-- 
2.37.3


^ permalink raw reply related	[relevance 59%]

* [bug#58123] [PATCH] gnu: services: docker: Add docker-container-service-type
@ 2022-09-27 17:16 56% guix-patches--- via
  2022-10-02 20:38 59% ` [bug#58123] guix-patches--- via
  0 siblings, 1 reply; 149+ results
From: guix-patches--- via @ 2022-09-27 17:16 UTC (permalink / raw)
  To: 58123


This patch provides a new service type, which allows the creation of shepherd
services from docker containers.
---
Hi,

I have written a definition of the docker-container-service-type. It is
a service that allows you to convert docker containers into shepherd
services.

It has some limitations:

1. Containers are deleted when stopping.
   This makes it easier to manage them from shepherd. You can achieve
   persistence with volume binds.
   
2. Containers must be either attached or detached.
   Some containers simply run a command inside the container, and when
   run with docker run, they stay attached and the docker run command
   therefore behaves like a normal command. However, some containers use
   docker's "init system", that means that they won't block the docker
   run command. Sadly attached containers don't properly report that
   they are initialized, so to docker they are in the "starting" state
   until termination. This means that docker doesn't create a cid
   file (pid file for containers). To sum it up, there is no way to tell
   how will the container report it's state, and this process must be
   specified by the user, if the container runs attached or detached.

3. Images are not managed.
   Docker does manage images in a really stupid way. My original idea
   was to have a file-like object to define an image (from an image
   archive), but sadly it has been more complex than I initially
   thought. Docker uses 2 versions of archive manifests, and each
   archive can have multiple images, depending on the architecture. And
   those images can be composed from layers, which are also images. The
   daemon determines ad-hoc which images from the archive it will use,
   and there is no official tool (at leats when I looked for it) to get
   image ids reliably. As the docker load command can return multiple
   images. I will expand on the process on how the images could be used
   in a managed way, but I have to say something to the current
   interface. It works by expecting an image by name from the image-name
   field. That means that docker must already have the image in its
   database. There is currently no way to ensure that images will be in
   docker database before running shepherd services, but I expect they
   should simply fail to start.

There is currently no documentation outside of docstrings, I plan to
write it, but first I would welcome comments from you, maybe this
service isn't suitable for guix, as it does imply breaking of the
declarative guix model, but that goes for docker and flatpak too, so I
thought I can try it.

Now finally to images. The idea is that all images belonging to a
docker-container-configuration are tagged (via docker tag) with the name
o the docker-container-configuration-name (as this is unique). The
activation service would get the propper image-id (which is not easy to
get from the manifest, but with some json parsing, it can be done). Then
it would load the image into the docker database with docker load, and
tag the new image with the docker-configuration-name tag. This would
automatically update the image from which the container is running
without having to modify the shepherd service.

Sadly docker does not allow for containers to be ran directly from the
image archive and this is the most straightforward workaround I could
think of.

I hope this patch finds you in good mood,

Maya

PS. I found out that the original docker-service-type wasn't
indent-region. And it got snuck into the patch, I hope this will still
be a valid patch.

 gnu/services/docker.scm | 289 +++++++++++++++++++++++++++++++++-------
 1 file changed, 242 insertions(+), 47 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 741bab5a8c..b05804aa16 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2022 Maya Tomasek <maya.omase@disroot.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,6 +38,8 @@ (define-module (gnu services docker)
 
   #:export (docker-configuration
             docker-service-type
+            docker-container-configuration
+            docker-container-service-type
             singularity-service-type))
 
 (define-configuration docker-configuration
@@ -164,6 +167,198 @@ (define docker-service-type
                                      (const %docker-accounts))))
                 (default-value (docker-configuration))))
 
+(define (pair-of-strings? val)
+  (and (pair val)
+       (string? (car val))
+       (string? (cdr val))))
+
+(define (list-of-pair-of-strings? val)
+  (list-of pair-of-strings?))
+
+(define-configuration/no-serialization docker-container-configuration
+  (name
+   (symbol '())
+   "Name of the docker container. Will be used to denote service to Shepherd and must be unique!
+We recommend, that the name of the container is prefixed with @code{docker-}.")
+  (comment
+   (string "")
+   "A documentation on the docker container.")
+  (image-name
+   (string)
+   "A name of the image that will be used. (Note that the existence of the image
+is not guaranteed by this daemon.)")
+  (volumes
+   (list-of-pair-of-strings '())
+   "A list of volume binds. In (HOST_PATH CONTAINER_PATH) format.")
+  (ports
+   (list-of-pair-of-strings '())
+   "A list of port binds. In (HOST_PORT CONTAINER_PORT) or (HOST_PORT CONTAINER_PORT OPTIONS) format.
+For example, both port bindings are valid:
+
+@lisp
+(ports '((\"2222\" \"22\") (\"21\" \"21\" \"tcp\")))
+@end lisp"
+   (environments
+    (list-of-pair-of-strings '())
+    "A list of variable binds, inside the container enviornment. In (VARIABLE VALUE) format."))
+  (network
+   (string "none")
+   "Network type.")
+  (additional-arguments
+   (list-of-strings '())
+   "Additional arguments to the docker command line interface.")
+  (container-command
+   (list-of-strings '())
+   "Command to send into the container.")
+  (attached?
+   (boolean #t)
+   "Run the container as an normal attached process (sending SIGTERM).
+Or run the container as a isolated environment that must be stopped with @code{docker stop}.
+
+Please verify first, that you container is indeed not attached, otherwise @code{shepherd} might
+assume the process is dead, even when it is not.
+
+You can do that, by first running your container with @code{docker run image-name}.
+
+Then check @code{docker ps}, if the command shows beside your container the word @code{running}.
+Your container is indeed detached, but if it shows @code{starting}, and it doesn't flip to
+@code{running} after a while, it means that you container is attached, and you need to keep this
+option turned @code{#t}."))
+
+(define (serialize-volumes config)
+  "Serialize list of pairs into flat list of @code{(\"-v\" \"HOST_PATH:CONTAINER_PATH\" ...)}"
+  (append-map
+   (lambda (volume-bind)
+     (list "-v" (format #f "~?" "~a:~a" volume-bind)))
+   (docker-container-configuration-volumes config)))
+
+(define (serialize-ports config)
+  "Serialize list of either pairs, or lists into flat list of
+@code{(\"-p\" \"NUMBER:NUMBER\" \"-p\" \"NUMBER:NUMBER/PROTOCOL\" ...)}"
+  (append-map
+   (lambda (port-bind)
+     (list "-p" (format #f "~?" "~a:~a~^/~a" port-bind)))
+   (docker-container-configuration-ports config)))
+
+(define (serialized-environments config)
+  "Serialize list of pairs into flat list of @code{(\"-e\" \"VAR=val\" \"-e\" \"VAR=val\" ...)}."
+  (append-map
+   (lambda (env-bind)
+     (list "-e" (format #f "~?" "~a=~a" env-bind)))
+   (docker-container-configuration-environments config)))
+
+(define (docker-container-startup-script docker-cli container-name config)
+  "Return a program file, that executes the startup sequence of the @code{docker-container-shepherd-service}."
+  (let* ((attached? (docker-container-configuration-attached? config))
+         (image-name (docker-container-configuration-image config))
+         (volumes (serialize-volumes config))
+         (ports (serialize-ports config))
+         (envs (serialize-environments config))
+         (network (docker-container-configuration-network config))
+         (additional-arguments (docker-container-configuration-additional-arguments config))
+         (container-command (docker-container-configuration-container-command config)))
+    (program-file
+     (string-append "start-" container-name "-container")
+     #~(let ((docker (string-append #$docker-cli "/bin/docker")))
+         (system* docker "stop" #$container-name)
+         (system* docker "rm" #$container-name)
+         (apply system* `(,docker
+                          "run"
+                          ,(string-append "--name=" #$container-name)
+                          ;; Automatically remove the container when stopping
+                          ;; If you want persistent data, you need to use
+                          ;; volume binds or other methods.
+                          "--rm"
+                          ,(string-append "--network=" #$network)
+                          ;; TODO:
+                          ;; Write to a cid file the container id, this allows
+                          ;; for shepherd to manage container even when the process
+                          ;; itself gets detached from the container
+                          ,@(if (not #$attached) '("--cidfile" #$cid-file) '())
+                          #$@volumes
+                          #$@ports
+                          #$@envs
+                          #$@additional-arguments
+                          ,#$image-name
+                          #$@container-command))))))
+
+(define (docker-container-shepherd-service docker-cli config)
+  "Return a shepherd-service that runs CONTAINER."
+  (let* ((container-name (symbol->string (docker-container-configuration-name config)))
+         (cid-file (string-append "/var/run/docker/" container-name ".pid"))
+         (attached? (docker-container-configuration-attached? config)))
+    (shepherd-service
+     (provision (list (docker-container-configuration-name config)))
+     (requirement `(dockerd))
+     (start #~(make-forkexec-constructor
+               (list #$(docker-container-startup-script docker-cli container-name config))
+               ;; Watch the cid-file instead of the docker run command, as the daemon can
+               ;; still be running even when the command terminates
+               (if (not #$attached?)
+                   #:pid-file #$cid-file)))
+     (stop (if #$attached?
+               #~(make-kill-destructor)
+               #~(lambda _
+                   (exec-command (list
+                                  (string-append #$docker-cli "/bin/docker")
+                                  "stop" #$container-name))
+                   #f))))))
+
+
+(define (list-of-docker-container-configurations? val)
+  (list-of docker-container-configuration?))
+
+(define-configuration/no-serialization docker-container-service-configuration
+  (docker-cli
+   (file-like docker-cli)
+   "The docker package to use.")
+  (containers
+   (list-of-docker-container-configurations '())
+   "The docker containers to run."))
+
+(define (docker-container-shepherd-services config)
+  "Return shepherd services for all containers inside config."
+  (let ((docker-cli (docker-container-service-configuration-docker-cli config)))
+    (map
+     (lambda (container)
+       (docker-container-shepherd-service
+        docker-cli
+        container))
+     (docker-container-service-configuration-containers config))))
+
+(define docker-container-service-type
+  "This is the type of the service that runs docker containers using GNU Shepherd.
+It allows for declarative management of running containers inside the Guix System.
+
+This service can be extended with list of @code{<docker-container-configuration>} objects.
+
+The following is an example @code{docker-container-service-type} configuration.
+
+@lisp
+(service docker-container-service-type
+  (containers (list
+                (docker-container-configuration
+                  (name 'docker-example)
+                  (comment \"An example docker container configuration\")
+                  (image-name \"example/example:latest\") ;; Note that images must be provided separately.
+                  (volumes '((\"/mnt\" \"/\") (\"/home/example\" \"/home/user\")))
+                  (ports '((\"21\" \"21\" \"tcp\") (\"22\" \"22\")))
+                  (network \"host\")))))
+@end lisp"
+  (service-type
+   (name 'docker-container)
+   (description "Manage docker containers with shepherd.")
+   (extensions
+    (list (service-extension shepherd-root-service-type docker-container-shepherd-services)))
+   (compose concatenate)
+   (extend (lambda (config containers)
+             (let ((docker-cli (docker-container-service-configuration-docker-cli config))
+                   (initial-containers (docker-container-service-configuration-containers config)))
+               (docker-container-service-configuration
+                (docker-cli docker-cli)
+                (containers (append initial-containers containers))))))
+   (default-value (docker-container-service-configuration))))
+
 \f
 ;;;
 ;;; Singularity.
-- 
2.37.3





^ permalink raw reply related	[relevance 56%]

* [bug#52790] [PATCH v3 7/7] gnu: docker: Switch to gexp and new input style.
                       ` (4 preceding siblings ...)
  2022-05-09 23:35 83%   ` [bug#52790] [PATCH v3 6/7] gnu: docker: Update to 20.10.15 Pierre Langlois
@ 2022-05-09 23:35 51%   ` Pierre Langlois
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-05-09 23:35 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (docker)[arguments]: Rewrite as gexps.  Switch
to using search-input-file.
[inputs]: Use new style inputs.
---
 gnu/packages/docker.scm | 483 ++++++++++++++++++++--------------------
 1 file changed, 241 insertions(+), 242 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index a3d3e5fb51..2df4cdb98a 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -326,260 +326,259 @@ (define-public docker
         (base32 "1z816496aqla4nq0aksf0kpy8qk8x1a6y5hrazzkqliycbjnqizq"))))
     (build-system gnu-build-system)
     (arguments
-     `(#:modules
-       ((guix build gnu-build-system)
+     (list
+      #:modules
+      '((guix build gnu-build-system)
         ((guix build go-build-system) #:prefix go:)
         (guix build union)
         (guix build utils))
-       #:imported-modules
-       (,@%gnu-build-system-modules
+      #:imported-modules
+      `(,@%gnu-build-system-modules
         (guix build union)
         (guix build go-build-system))
-       #:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'patch-paths
-           (lambda* (#:key inputs #:allow-other-keys)
-             (substitute* "builder/builder-next/executor_unix.go"
-               (("CommandCandidates:.*runc.*")
-                (string-append "CommandCandidates: []string{\""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"},\n")))
-             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-               (("DefaultCommand = .*")
-                (string-append "DefaultCommand = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
-               (("defaultRuntime[ \t]*=.*")
-                (string-append "defaultRuntime = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("defaultShim[ \t]*=.*")
-                (string-append "defaultShim = \""
-                               (assoc-ref inputs "containerd")
-                               "/bin/containerd-shim\"\n")))
-             (substitute* "daemon/daemon_unix.go"
-               (("DefaultShimBinary = .*")
-                (string-append "DefaultShimBinary = \""
-                               (assoc-ref inputs "containerd")
-                               "/bin/containerd-shim\"\n"))
-               (("DefaultRuntimeBinary = .*")
-                (string-append "DefaultRuntimeBinary = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "daemon/runtime_unix.go"
-               (("defaultRuntimeName = .*")
-                (string-append "defaultRuntimeName = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "daemon/config/config.go"
-               (("StockRuntimeName = .*")
-                (string-append "StockRuntimeName = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultInitBinary = .*")
-                (string-append "DefaultInitBinary = \""
-                               (assoc-ref inputs "tini")
-                               "/bin/tini-static\"\n")))
-             (substitute* "daemon/config/config_common_unix_test.go"
-               (("expectedInitPath: \"docker-init\"")
-                (string-append "expectedInitPath: \""
-                               (assoc-ref inputs "tini")
-                               "/bin/tini-static\"")))
-             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
-               (("var defaultCommandCandidates = .*")
-                (string-append "var defaultCommandCandidates = []string{\""
-                               (assoc-ref inputs "runc") "/sbin/runc\"}")))
-             (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
-               (("var userlandProxyCommandName = .*")
-                (string-append "var userlandProxyCommandName = \""
-                               (assoc-ref inputs "docker-proxy")
-                               "/bin/proxy\"\n")))
-             (substitute* "pkg/archive/archive.go"
-               (("string\\{\"xz")
-                (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'patch-paths
+            (lambda* (#:key inputs #:allow-other-keys)
+              (substitute* "builder/builder-next/executor_unix.go"
+                (("CommandCandidates:.*runc.*")
+                 (string-append "CommandCandidates: []string{\""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"},\n")))
+              (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+                (("DefaultCommand = .*")
+                 (string-append "DefaultCommand = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
+                (("defaultRuntime[ \t]*=.*")
+                 (string-append "defaultRuntime = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n"))
+                (("defaultShim[ \t]*=.*")
+                 (string-append "defaultShim = \""
+                                (search-input-file inputs "/bin/containerd-shim")
+                                "\"\n")))
+              (substitute* "daemon/daemon_unix.go"
+                (("DefaultShimBinary = .*")
+                 (string-append "DefaultShimBinary = \""
+                                (search-input-file inputs "/bin/containerd-shim")
+                                "\"\n"))
+                (("DefaultRuntimeBinary = .*")
+                 (string-append "DefaultRuntimeBinary = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "daemon/runtime_unix.go"
+                (("defaultRuntimeName = .*")
+                 (string-append "defaultRuntimeName = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "daemon/config/config.go"
+                (("StockRuntimeName = .*")
+                 (string-append "StockRuntimeName = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n"))
+                (("DefaultInitBinary = .*")
+                 (string-append "DefaultInitBinary = \""
+                                (search-input-file inputs "/bin/tini-static")
+                                "\"\n")))
+              (substitute* "daemon/config/config_common_unix_test.go"
+                (("expectedInitPath: \"docker-init\"")
+                 (string-append "expectedInitPath: \""
+                                (search-input-file inputs "/bin/tini-static")
+                                "\"")))
+              (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+                (("var defaultCommandCandidates = .*")
+                 (string-append "var defaultCommandCandidates = []string{\""
+                                (search-input-file inputs "/sbin/runc") "\"}")))
+              (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
+                (("var userlandProxyCommandName = .*")
+                 (string-append "var userlandProxyCommandName = \""
+                                (search-input-file inputs "/bin/proxy")
+                                "\"\n")))
+              (substitute* "pkg/archive/archive.go"
+                (("string\\{\"xz")
+                 (string-append "string{\"" (search-input-file inputs "/bin/xz"))))

-             (let ((source-files (filter (lambda (name)
-                                           (not (string-contains name "test")))
-                                         (find-files "." "\\.go$"))))
-               (let-syntax ((substitute-LookPath*
-                             (syntax-rules ()
-                               ((_ (source-text package relative-path) ...)
-                                (substitute* source-files
-                                  (((string-append "\\<exec\\.LookPath\\(\""
-                                                   source-text
-                                                   "\")"))
-                                   (string-append "\""
-                                                  (assoc-ref inputs package)
-                                                  "/" relative-path
-                                                  "\", error(nil)")) ...))))
-                            (substitute-Command*
-                             (syntax-rules ()
-                               ((_ (source-text package relative-path) ...)
-                                (substitute* source-files
-                                  (((string-append "\\<(re)?exec\\.Command\\(\""
-                                                   source-text
-                                                   "\"") _ re?)
-                                   (string-append (if re? re? "")
-                                                  "exec.Command(\""
-                                                  (assoc-ref inputs package)
-                                                  "/" relative-path
-                                                  "\"")) ...)))))
-                 (substitute-LookPath*
-                  ("containerd" "containerd" "bin/containerd")
-                  ("ps" "procps" "bin/ps")
-                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                  ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
-                  ("pvdisplay" "lvm2" "sbin/pvdisplay")
-                  ("blkid" "util-linux" "sbin/blkid")
-                  ("unpigz" "pigz" "bin/unpigz")
-                  ("iptables" "iptables" "sbin/iptables")
-                  ("ip6tables" "iptables" "sbin/ip6tables")
-                  ("iptables-legacy" "iptables" "sbin/iptables")
-                  ("ip" "iproute2" "sbin/ip"))
+              (let ((source-files (filter (lambda (name)
+                                            (not (string-contains name "test")))
+                                          (find-files "." "\\.go$"))))
+                (let-syntax ((substitute-LookPath*
+                              (syntax-rules ()
+                                ((_ (source-text path) ...)
+                                 (substitute* source-files
+                                   (((string-append "\\<exec\\.LookPath\\(\""
+                                                    source-text
+                                                    "\")"))
+                                    (string-append "\""
+                                                   (search-input-file inputs path)
+                                                   "\", error(nil)")) ...))))
+                             (substitute-Command*
+                              (syntax-rules ()
+                                ((_ (source-text path) ...)
+                                 (substitute* source-files
+                                   (((string-append "\\<(re)?exec\\.Command\\(\""
+                                                    source-text
+                                                    "\"") _ re?)
+                                    (string-append (if re? re? "")
+                                                   "exec.Command(\""
+                                                   (search-input-file inputs path)
+                                                   "\"")) ...)))))
+                  (substitute-LookPath*
+                   ("containerd" "/bin/containerd")
+                   ("ps" "/bin/ps")
+                   ("mkfs.xfs" "/sbin/mkfs.xfs")
+                   ("lvmdiskscan" "/sbin/lvmdiskscan")
+                   ("pvdisplay" "/sbin/pvdisplay")
+                   ("blkid" "/sbin/blkid")
+                   ("unpigz" "/bin/unpigz")
+                   ("iptables" "/sbin/iptables")
+                   ("ip6tables" "/sbin/ip6tables")
+                   ("iptables-legacy" "/sbin/iptables")
+                   ("ip" "/sbin/ip"))

-                 (substitute-Command*
-                  ("modprobe" "kmod" "bin/modprobe")
-                  ("pvcreate" "lvm2" "sbin/pvcreate")
-                  ("vgcreate" "lvm2" "sbin/vgcreate")
-                  ("lvcreate" "lvm2" "sbin/lvcreate")
-                  ("lvconvert" "lvm2" "sbin/lvconvert")
-                  ("lvchange" "lvm2" "sbin/lvchange")
-                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                  ("xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
-                  ("mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
-                  ("tune2fs" "e2fsprogs" "sbin/tune2fs")
-                  ("blkid" "util-linux" "sbin/blkid")
-                  ("resize2fs" "e2fsprogs" "sbin/resize2fs")
-                  ("ps" "procps" "bin/ps")
-                  ("losetup" "util-linux" "sbin/losetup")
-                  ("uname" "coreutils" "bin/uname")
-                  ("dbus-launch" "dbus" "bin/dbus-launch")
-                  ("git" "git" "bin/git")))
-               ;; docker-mountfrom ??
-               ;; docker
-               ;; docker-untar ??
-               ;; docker-applyLayer ??
-               ;; /usr/bin/uname
-               ;; grep
-               ;; apparmor_parser
+                  (substitute-Command*
+                   ("modprobe" "/bin/modprobe")
+                   ("pvcreate" "/sbin/pvcreate")
+                   ("vgcreate" "/sbin/vgcreate")
+                   ("lvcreate" "/sbin/lvcreate")
+                   ("lvconvert" "/sbin/lvconvert")
+                   ("lvchange" "/sbin/lvchange")
+                   ("mkfs.xfs" "/sbin/mkfs.xfs")
+                   ("xfs_growfs" "/sbin/xfs_growfs")
+                   ("mkfs.ext4" "/sbin/mkfs.ext4")
+                   ("tune2fs" "/sbin/tune2fs")
+                   ("blkid" "/sbin/blkid")
+                   ("resize2fs" "/sbin/resize2fs")
+                   ("ps" "/bin/ps")
+                   ("losetup" "/sbin/losetup")
+                   ("uname" "/bin/uname")
+                   ("dbus-launch" "/bin/dbus-launch")
+                   ("git" "/bin/git")))
+                ;; docker-mountfrom ??
+                ;; docker
+                ;; docker-untar ??
+                ;; docker-applyLayer ??
+                ;; /usr/bin/uname
+                ;; grep
+                ;; apparmor_parser

-               ;; Make compilation fail when, in future versions, Docker
-               ;; invokes other programs we don't know about and thus don't
-               ;; substitute.
-               (substitute* source-files
-                 ;; Search for Java in PATH.
-                 (("\\<exec\\.Command\\(\"java\"")
-                  "xxec.Command(\"java\"")
-                 ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                 (("\\<exec\\.Command\\(\"auplink\"")
-                  "xxec.Command(\"auplink\"")
-                 ;; Fail on other unsubstituted commands.
-                 (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                   _ executable)
-                  (string-append "exec.Guix_doesnt_want_Command(\""
-                                 executable "\""))
-                 (("\\<xxec\\.Command")
-                  "exec.Command")
-                 ;; Search for ZFS in PATH.
-                 (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                ;; Make compilation fail when, in future versions, Docker
+                ;; invokes other programs we don't know about and thus don't
+                ;; substitute.
+                (substitute* source-files
+                  ;; Search for Java in PATH.
+                  (("\\<exec\\.Command\\(\"java\"")
+                   "xxec.Command(\"java\"")
+                  ;; Search for AUFS in PATH (mainline Linux doesn't support it).
+                  (("\\<exec\\.Command\\(\"auplink\"")
+                   "xxec.Command(\"auplink\"")
+                  ;; Fail on other unsubstituted commands.
+                  (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
+                    _ executable)
+                   (string-append "exec.Guix_doesnt_want_Command(\""
+                                  executable "\""))
+                  (("\\<xxec\\.Command")
+                   "exec.Command")
+                  ;; Search for ZFS in PATH.
+                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
                  ;; Do not fail when buildkit-qemu-<target> isn't found.
                  ;; FIXME: We might need to package buildkit and docker's
                  ;; buildx plugin, to support qemu-based docker containers.
-                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
-                 ;; Fail on other unsubstituted LookPaths.
-                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))))
-         (add-after 'patch-paths 'delete-failing-tests
-           (lambda _
-             ;; Needs internet access.
-             (delete-file "builder/remotecontext/git/gitutils_test.go")
-             ;; Permission denied.
-             (delete-file "daemon/graphdriver/devmapper/devmapper_test.go")
-             ;; Operation not permitted (idtools.MkdirAllAndChown).
-             (delete-file "daemon/graphdriver/vfs/vfs_test.go")
-             ;; Timeouts after 5 min.
-             (delete-file "plugin/manager_linux_test.go")
-             ;; Operation not permitted.
-             (delete-file "daemon/graphdriver/aufs/aufs_test.go")
-             (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
-             (delete-file "daemon/graphdriver/overlay/overlay_test.go")
-             (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
-             (delete-file "pkg/chrootarchive/archive_unix_test.go")
-             (delete-file "daemon/container_unix_test.go")
-             ;; This file uses cgroups and /proc.
-             (delete-file "pkg/sysinfo/sysinfo_linux_test.go")
-             ;; This file uses cgroups.
-             (delete-file "runconfig/config_test.go")
-             ;; This file uses /var.
-             (delete-file "daemon/oci_linux_test.go")
-             ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")))
-         (replace 'configure
-           (lambda _
-             (setenv "DOCKER_BUILDTAGS" "seccomp")
-             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
-             (setenv "VERSION" (string-append ,%docker-version "-ce"))
-             ;; Automatically use bundled dependencies.
-             ;; TODO: Unbundle - see file "vendor.conf".
-             (setenv "AUTO_GOPATH" "1")
-             ;; Respectively, strip the symbol table and debug
-             ;; information, and the DWARF symbol table.
-             (setenv "LDFLAGS" "-s -w")
-             ;; Make build faster
-             (setenv "GOCACHE" "/tmp")))
-         (add-before 'build 'setup-go-environment
-           (assoc-ref go:%standard-phases 'setup-go-environment))
-         (replace 'build
-           (lambda _
-             ;; Our LD doesn't like the statically linked relocatable things
-             ;; that go produces, so install the dynamic version of
-             ;; dockerd instead.
-             (invoke "hack/make.sh" "dynbinary")))
-         (replace 'check
-           (lambda _
-             ;; The build process generated a file because the environment
-             ;; variable "AUTO_GOPATH" was set.  Use it.
-             (setenv "GOPATH" (string-append (getcwd) "/.gopath"))
-             ;; ".gopath/src/github.com/docker/docker" is a link to the current
-             ;; directory and chdir would canonicalize to that.
-             ;; But go needs to have the uncanonicalized directory name, so
-             ;; store that.
-             (setenv "PWD" (string-append (getcwd)
-                                          "/.gopath/src/github.com/docker/docker"))
-             (with-directory-excursion ".gopath/src/github.com/docker/docker"
-               (invoke "hack/test/unit"))
-             (setenv "PWD" #f)))
-         (replace 'install
-           (lambda* (#:key outputs #:allow-other-keys)
-             (let* ((out (assoc-ref outputs "out"))
-                    (out-bin (string-append out "/bin")))
-               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
-               (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
-                                            (getenv "VERSION"))
-                             out-bin))))
-         (add-after 'install 'remove-go-references
-           (assoc-ref go:%standard-phases 'remove-go-references)))))
+                  (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
+                  ;; Fail on other unsubstituted LookPaths.
+                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
+                  (("\\<LooxPath") "LookPath")))))
+          (add-after 'patch-paths 'delete-failing-tests
+            (lambda _
+              ;; Needs internet access.
+              (delete-file "builder/remotecontext/git/gitutils_test.go")
+              ;; Permission denied.
+              (delete-file "daemon/graphdriver/devmapper/devmapper_test.go")
+              ;; Operation not permitted (idtools.MkdirAllAndChown).
+              (delete-file "daemon/graphdriver/vfs/vfs_test.go")
+              ;; Timeouts after 5 min.
+              (delete-file "plugin/manager_linux_test.go")
+              ;; Operation not permitted.
+              (delete-file "daemon/graphdriver/aufs/aufs_test.go")
+              (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
+              (delete-file "daemon/graphdriver/overlay/overlay_test.go")
+              (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
+              (delete-file "pkg/chrootarchive/archive_unix_test.go")
+              (delete-file "daemon/container_unix_test.go")
+              ;; This file uses cgroups and /proc.
+              (delete-file "pkg/sysinfo/sysinfo_linux_test.go")
+              ;; This file uses cgroups.
+              (delete-file "runconfig/config_test.go")
+              ;; This file uses /var.
+              (delete-file "daemon/oci_linux_test.go")
+              ;; Signal tests fail in bizarre ways
+              (delete-file "pkg/signal/signal_linux_test.go")))
+          (replace 'configure
+            (lambda _
+              (setenv "DOCKER_BUILDTAGS" "seccomp")
+              (setenv "DOCKER_GITCOMMIT" (string-append "v" #$%docker-version))
+              (setenv "VERSION" (string-append #$%docker-version "-ce"))
+              ;; Automatically use bundled dependencies.
+              ;; TODO: Unbundle - see file "vendor.conf".
+              (setenv "AUTO_GOPATH" "1")
+              ;; Respectively, strip the symbol table and debug
+              ;; information, and the DWARF symbol table.
+              (setenv "LDFLAGS" "-s -w")
+              ;; Make build faster
+              (setenv "GOCACHE" "/tmp")))
+          (add-before 'build 'setup-go-environment
+            (assoc-ref go:%standard-phases 'setup-go-environment))
+          (replace 'build
+            (lambda _
+              ;; Our LD doesn't like the statically linked relocatable things
+              ;; that go produces, so install the dynamic version of
+              ;; dockerd instead.
+              (invoke "hack/make.sh" "dynbinary")))
+          (replace 'check
+            (lambda _
+              ;; The build process generated a file because the environment
+              ;; variable "AUTO_GOPATH" was set.  Use it.
+              (setenv "GOPATH" (string-append (getcwd) "/.gopath"))
+              ;; ".gopath/src/github.com/docker/docker" is a link to the current
+              ;; directory and chdir would canonicalize to that.
+              ;; But go needs to have the uncanonicalized directory name, so
+              ;; store that.
+              (setenv "PWD" (string-append (getcwd)
+                                           "/.gopath/src/github.com/docker/docker"))
+              (with-directory-excursion ".gopath/src/github.com/docker/docker"
+                (invoke "hack/test/unit"))
+              (setenv "PWD" #f)))
+          (replace 'install
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((out (assoc-ref outputs "out"))
+                     (out-bin (string-append out "/bin")))
+                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
+                                             (getenv "VERSION"))
+                              out-bin))))
+          (add-after 'install 'remove-go-references
+            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
-     `(("btrfs-progs" ,btrfs-progs)
-       ("containerd" ,containerd)       ; for containerd-shim
-       ("coreutils" ,coreutils)
-       ("dbus" ,dbus)
-       ("docker-proxy" ,docker-libnetwork-cmd-proxy)
-       ("e2fsprogs" ,e2fsprogs)
-       ("git" ,git)
-       ("iproute2" ,iproute)
-       ("iptables" ,iptables)
-       ("kmod" ,kmod)
-       ("libseccomp" ,libseccomp)
-       ("pigz" ,pigz)
-       ("procps" ,procps)
-       ("runc" ,runc)
-       ("util-linux" ,util-linux)
-       ("lvm2" ,lvm2)
-       ("tini" ,tini)
-       ("xfsprogs" ,xfsprogs)
-       ("xz" ,xz)))
+     (list btrfs-progs
+           containerd       ; for containerd-shim
+           coreutils
+           dbus
+           docker-libnetwork-cmd-proxy
+           e2fsprogs
+           git
+           iproute
+           iptables
+           kmod
+           libseccomp
+           pigz
+           procps
+           runc
+           util-linux
+           lvm2
+           tini
+           xfsprogs
+           xz))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
            go gotestsum pkg-config))
--
2.36.0





^ permalink raw reply related	[relevance 51%]

* [bug#52790] [PATCH v3 5/7] gnu: docker: Fix mkfs.xfs reference.
                       ` (2 preceding siblings ...)
  2022-05-09 23:35 80%   ` [bug#52790] [PATCH v3 4/7] gnu: containerd: Switch to gexp arguments Pierre Langlois
@ 2022-05-09 23:35 92%   ` Pierre Langlois
  2022-05-09 23:35 83%   ` [bug#52790] [PATCH v3 6/7] gnu: docker: Update to 20.10.15 Pierre Langlois
  2022-05-09 23:35 51%   ` [bug#52790] [PATCH v3 7/7] gnu: docker: Switch to gexp and new input style Pierre Langlois
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-05-09 23:35 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (docker)[arguments]: Refer to sbin/mkfs.xfs
instead of bin/mkfs.xfs.
---
 gnu/packages/docker.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index aa5f4d523b..ff9bbecab6 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -440,7 +440,7 @@ (define-public docker
                  (substitute-LookPath*
                   ("containerd" "containerd" "bin/containerd")
                   ("ps" "procps" "bin/ps")
-                  ("mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
+                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
                   ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
                   ("pvdisplay" "lvm2" "sbin/pvdisplay")
                   ("blkid" "util-linux" "sbin/blkid")
--
2.36.0





^ permalink raw reply related	[relevance 92%]

* [bug#52790] [PATCH v3 3/7] gnu: containerd: Update to 1.6.4.
    2022-05-09 23:35 92%   ` [bug#52790] [PATCH v3 2/7] gnu: containerd: Fix patch-paths build phase Pierre Langlois
@ 2022-05-09 23:35 90%   ` Pierre Langlois
  2022-05-09 23:35 80%   ` [bug#52790] [PATCH v3 4/7] gnu: containerd: Switch to gexp arguments Pierre Langlois
                     ` (3 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-05-09 23:35 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd): Update to 1.6.4.
[arguments]: Substitute runc binary for "pkg/cri/config/config_unix.go".  Set
PREFIX to empty string, as the install directory is $DESTDIR/$PREFIX.
---
 gnu/packages/docker.scm | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 5c0f4d496d..e95614cfae 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -174,7 +174,7 @@ (define-public python-docker-pycreds
 (define-public containerd
   (package
     (name "containerd")
-    (version "1.4.4")
+    (version "1.6.4")
     (source
      (origin
        (method git-fetch)
@@ -183,7 +183,7 @@ (define-public containerd
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0qjbfj1dw6pykxhh8zahcxlgpyjzgnrngk5vjaf34akwyan8nrxb"))))
+        (base32 "1hy5jaf5x8lffh3p4hdkk6ar8i4w84i0b539k1h5baqx9gnq2l2s"))))
     (build-system go-build-system)
     (arguments
      (let ((make-flags (list (string-append "VERSION=" version)
@@ -203,6 +203,11 @@ (define-public containerd
                     (string-append "defaultShim = \""
                                    (assoc-ref outputs "out")
                                    "/bin/containerd-shim\"\n")))
+                 (substitute* "pkg/cri/config/config_unix.go"
+                   (("DefaultRuntimeName: \"runc\"")
+                    (string-append "DefaultRuntimeName: \""
+                                   (assoc-ref inputs "runc")
+                                   "/sbin/runc\"")))
                  (substitute* "vendor/github.com/containerd/go-runc/runc.go"
                    (("DefaultCommand[ \t]*=.*")
                     (string-append "DefaultCommand = \""
@@ -226,8 +231,8 @@ (define-public containerd
              (lambda* (#:key import-path outputs #:allow-other-keys)
                (with-directory-excursion (string-append "src/" import-path)
                  (let* ((out (assoc-ref outputs "out")))
-                   (apply invoke "make" (string-append "DESTDIR=" out) "install"
-                          ',make-flags)))))))))
+                   (apply invoke "make" (string-append "DESTDIR=" out)
+                          "PREFIX=" "install" ',make-flags)))))))))
     (inputs
      (list btrfs-progs libseccomp pigz runc util-linux))
     (native-inputs
--
2.36.0





^ permalink raw reply related	[relevance 90%]

* [bug#52790] [PATCH v3 2/7] gnu: containerd: Fix patch-paths build phase.
  @ 2022-05-09 23:35 92%   ` Pierre Langlois
  2022-05-09 23:35 90%   ` [bug#52790] [PATCH v3 3/7] gnu: containerd: Update to 1.6.4 Pierre Langlois
                     ` (4 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-05-09 23:35 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd)[arguments]: Add 'patch-paths
phases after 'unpack because 'chdir doesn't exist.
---
 gnu/packages/docker.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 07731886ae..5c0f4d496d 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -190,7 +191,7 @@ (define-public containerd
        `(#:import-path "github.com/containerd/containerd"
          #:phases
          (modify-phases %standard-phases
-           (add-after 'chdir 'patch-paths
+           (add-after 'unpack 'patch-paths
              (lambda* (#:key inputs import-path outputs #:allow-other-keys)
                (with-directory-excursion (string-append "src/" import-path)
                  (substitute* "runtime/v1/linux/runtime.go"
--
2.36.0





^ permalink raw reply related	[relevance 92%]

* [bug#52790] [PATCH v3 4/7] gnu: containerd: Switch to gexp arguments.
    2022-05-09 23:35 92%   ` [bug#52790] [PATCH v3 2/7] gnu: containerd: Fix patch-paths build phase Pierre Langlois
  2022-05-09 23:35 90%   ` [bug#52790] [PATCH v3 3/7] gnu: containerd: Update to 1.6.4 Pierre Langlois
@ 2022-05-09 23:35 80%   ` Pierre Langlois
  2022-05-09 23:35 92%   ` [bug#52790] [PATCH v3 5/7] gnu: docker: Fix mkfs.xfs reference Pierre Langlois
                     ` (2 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-05-09 23:35 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd)[arguments]: Rewrite as gexps.
Pass all flags via make-flags variable.  Switch to using
search-input-file.
---
 gnu/packages/docker.scm | 95 +++++++++++++++++++++--------------------
 1 file changed, 49 insertions(+), 46 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index e95614cfae..aa5f4d523b 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -29,6 +29,7 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages)
   #:use-module (guix packages)
   #:use-module (guix download)
+  #:use-module (guix gexp)
   #:use-module (guix git-download)
   #:use-module (guix build-system cmake)
   #:use-module (guix build-system gnu)
@@ -186,53 +187,55 @@ (define-public containerd
         (base32 "1hy5jaf5x8lffh3p4hdkk6ar8i4w84i0b539k1h5baqx9gnq2l2s"))))
     (build-system go-build-system)
     (arguments
-     (let ((make-flags (list (string-append "VERSION=" version)
-                             "REVISION=0")))
-       `(#:import-path "github.com/containerd/containerd"
-         #:phases
-         (modify-phases %standard-phases
-           (add-after 'unpack 'patch-paths
-             (lambda* (#:key inputs import-path outputs #:allow-other-keys)
-               (with-directory-excursion (string-append "src/" import-path)
-                 (substitute* "runtime/v1/linux/runtime.go"
-                   (("defaultRuntime[ \t]*=.*")
-                    (string-append "defaultRuntime = \""
-                                   (assoc-ref inputs "runc")
-                                   "/sbin/runc\"\n"))
-                   (("defaultShim[ \t]*=.*")
-                    (string-append "defaultShim = \""
-                                   (assoc-ref outputs "out")
-                                   "/bin/containerd-shim\"\n")))
-                 (substitute* "pkg/cri/config/config_unix.go"
-                   (("DefaultRuntimeName: \"runc\"")
-                    (string-append "DefaultRuntimeName: \""
-                                   (assoc-ref inputs "runc")
-                                   "/sbin/runc\"")))
-                 (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-                   (("DefaultCommand[ \t]*=.*")
-                    (string-append "DefaultCommand = \""
-                                   (assoc-ref inputs "runc")
-                                   "/sbin/runc\"\n")))
-                 (substitute* "vendor/github.com/containerd/continuity/testutil\
+     (let ((make-flags #~(list (string-append "VERSION=" #$version)
+                               (string-append "DESTDIR=" #$output)
+                               "PREFIX="
+                               "REVISION=0")))
+       (list
+        #:import-path "github.com/containerd/containerd"
+        #:phases
+        #~(modify-phases %standard-phases
+            (add-after 'unpack 'patch-paths
+              (lambda* (#:key inputs import-path outputs #:allow-other-keys)
+                (with-directory-excursion (string-append "src/" import-path)
+                  (substitute* "runtime/v1/linux/runtime.go"
+                    (("defaultRuntime[ \t]*=.*")
+                     (string-append "defaultRuntime = \""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\"\n"))
+                    (("defaultShim[ \t]*=.*")
+                     (string-append "defaultShim = \""
+                                    (assoc-ref outputs "out")
+                                    "/bin/containerd-shim\"\n")))
+                  (substitute* "pkg/cri/config/config_unix.go"
+                    (("DefaultRuntimeName: \"runc\"")
+                     (string-append "DefaultRuntimeName: \""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\"")))
+                  (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+                    (("DefaultCommand[ \t]*=.*")
+                     (string-append "DefaultCommand = \""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\"\n")))
+                  (substitute* "vendor/github.com/containerd/continuity/testutil\
 /loopback/loopback_linux.go"
-                   (("exec\\.Command\\(\"losetup\"")
-                    (string-append "exec.Command(\""
-                                   (assoc-ref inputs "util-linux")
-                                   "/sbin/losetup\"")))
-                 (substitute* "archive/compression/compression.go"
-                   (("exec\\.LookPath\\(\"unpigz\"\\)")
-                    (string-append "\"" (assoc-ref inputs "pigz")
-                                   "/bin/unpigz\", error(nil)"))))))
-           (replace 'build
-             (lambda* (#:key import-path #:allow-other-keys)
-               (with-directory-excursion (string-append "src/" import-path)
-                 (apply invoke "make" ',make-flags))))
-           (replace 'install
-             (lambda* (#:key import-path outputs #:allow-other-keys)
-               (with-directory-excursion (string-append "src/" import-path)
-                 (let* ((out (assoc-ref outputs "out")))
-                   (apply invoke "make" (string-append "DESTDIR=" out)
-                          "PREFIX=" "install" ',make-flags)))))))))
+                    (("exec\\.Command\\(\"losetup\"")
+                     (string-append "exec.Command(\""
+                                    (search-input-file inputs "/sbin/losetup")
+                                    "\"")))
+                  (substitute* "archive/compression/compression.go"
+                    (("exec\\.LookPath\\(\"unpigz\"\\)")
+                     (string-append "\""
+                                    (search-input-file inputs "/bin/unpigz")
+                                    "\", error(nil)"))))))
+            (replace 'build
+              (lambda* (#:key import-path #:allow-other-keys)
+                (with-directory-excursion (string-append "src/" import-path)
+                  (apply invoke "make" #$make-flags))))
+            (replace 'install
+              (lambda* (#:key import-path #:allow-other-keys)
+                (with-directory-excursion (string-append "src/" import-path)
+                  (apply invoke "make" "install" #$make-flags))))))))
     (inputs
      (list btrfs-progs libseccomp pigz runc util-linux))
     (native-inputs
--
2.36.0





^ permalink raw reply related	[relevance 80%]

* [bug#52790] [PATCH v3 6/7] gnu: docker: Update to 20.10.15.
                       ` (3 preceding siblings ...)
  2022-05-09 23:35 92%   ` [bug#52790] [PATCH v3 5/7] gnu: docker: Fix mkfs.xfs reference Pierre Langlois
@ 2022-05-09 23:35 83%   ` Pierre Langlois
  2022-05-09 23:35 51%   ` [bug#52790] [PATCH v3 7/7] gnu: docker: Switch to gexp and new input style Pierre Langlois
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-05-09 23:35 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (%docker-version): Update to 20.10.15.
(docker-libnetwork): Update commit according to vendor.conf.
(docker)[origin]: Remove docker-fix-tests.patch.
[arguments]: Adapt 'patch-paths phase, substitute "ip6tables" and
buildkit-qemu.  Remove trailing #t.
[native-inputs]: Replace go-1.14 by go.
(docker-cli)[arguments]: Set GO_LINKMODE to "dynamic".  Remove trailing #t.
* gnu/packages/networking.scm (go-sctp): Update commit according to
docker-libnetwork's vendor.conf.
* gnu/packages/patches/docker-fix-tests.patch: Delete.
* gnu/local.mk (dist_patch_DATA): Remove patch.
---
 gnu/local.mk                                |  1 -
 gnu/packages/docker.scm                     | 72 +++++++++------------
 gnu/packages/networking.scm                 |  6 +-
 gnu/packages/patches/docker-fix-tests.patch | 28 --------
 4 files changed, 32 insertions(+), 75 deletions(-)
 delete mode 100644 gnu/packages/patches/docker-fix-tests.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index 3b7db46b26..69d3f404b7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1008,7 +1008,6 @@ dist_patch_DATA =						\
   %D%/packages/patches/docbook-xsl-support-old-url.patch	\
   %D%/packages/patches/doc++-include-directives.patch		\
   %D%/packages/patches/doc++-segfault-fix.patch			\
-  %D%/packages/patches/docker-fix-tests.patch			\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/dstat-fix-crash-when-specifying-delay.patch	\
   %D%/packages/patches/dstat-skip-devices-without-io.patch	\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index ff9bbecab6..a3d3e5fb51 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -54,7 +54,7 @@ (define-module (gnu packages docker)

 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "19.03.15")
+(define %docker-version "20.10.15")

 (define-public python-docker
   (package
@@ -252,13 +252,12 @@ (define-public containerd
 ;;; anyway, as it needs many dependencies that aren't being satisfied.
 (define docker-libnetwork
   ;; There are no recent release for libnetwork, so choose the last commit of
-  ;; the branch that Docker uses, as can be seen in the Docker source file
-  ;; 'hack/dockerfile/install/proxy.installer'. NOTE - It is important that
-  ;; this version is kept in sync with the version of Docker being used.
-  ;; This commit is the "bump_19.03" branch, as mentioned in Docker's vendor.conf.
-  (let ((commit "55e924b8a84231a065879156c0de95aefc5f5435")
+  ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
+  ;; source file.  NOTE - It is important that this version is kept in sync
+  ;; with the version of Docker being used.
+  (let ((commit "339b972b464ee3d401b5788b2af9e31d09d6b7da")
         (version (version-major+minor %docker-version))
-        (revision "1"))
+        (revision "2"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -271,7 +270,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "19syb3scwiykn44gqfaqrgqv8a0df4ps0ykf3za9xkjc5cyi99mp"))
+                  "0wx2hdwx56cbxiaky9kw2bi1prdfgzwr776lq1k0slw8kvn0cn32"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(begin
@@ -324,9 +323,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0419iha9zmwlhzhnbfxlsa13vgd04yifnsr8qqnj2ks5dxrcajl8"))
-       (patches
-        (search-patches "docker-fix-tests.patch"))))
+        (base32 "1z816496aqla4nq0aksf0kpy8qk8x1a6y5hrazzkqliycbjnqizq"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -369,9 +366,10 @@ (define-public docker
                (("DefaultRuntimeBinary = .*")
                 (string-append "DefaultRuntimeBinary = \""
                                (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultRuntimeName = .*")
-                (string-append "DefaultRuntimeName = \""
+                               "/sbin/runc\"\n")))
+             (substitute* "daemon/runtime_unix.go"
+               (("defaultRuntimeName = .*")
+                (string-append "defaultRuntimeName = \""
                                (assoc-ref inputs "runc")
                                "/sbin/runc\"\n")))
              (substitute* "daemon/config/config.go"
@@ -400,16 +398,6 @@ (define-public docker
              (substitute* "pkg/archive/archive.go"
                (("string\\{\"xz")
                 (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "registry/resumable/resumablerequestreader_test.go"
-               (("I%27m%20not%20an%20url" all)
-                (string-append "\"" all "\"")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "vendor/gotest.tools/x/subtest/context.go"
-               (("func \\(tc \\*testcase\\) Cleanup\\(" all)
-                (string-append all "func()"))
-               (("tc\\.Cleanup\\(" all)
-                (string-append all "nil")))

              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
@@ -446,6 +434,7 @@ (define-public docker
                   ("blkid" "util-linux" "sbin/blkid")
                   ("unpigz" "pigz" "bin/unpigz")
                   ("iptables" "iptables" "sbin/iptables")
+                  ("ip6tables" "iptables" "sbin/ip6tables")
                   ("iptables-legacy" "iptables" "sbin/iptables")
                   ("ip" "iproute2" "sbin/ip"))

@@ -494,10 +483,13 @@ (define-public docker
                   "exec.Command")
                  ;; Search for ZFS in PATH.
                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                 ;; Do not fail when buildkit-qemu-<target> isn't found.
+                 ;; FIXME: We might need to package buildkit and docker's
+                 ;; buildx plugin, to support qemu-based docker containers.
+                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
                  ;; Fail on other unsubstituted LookPaths.
                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))
-             #t))
+                 (("\\<LooxPath") "LookPath")))))
          (add-after 'patch-paths 'delete-failing-tests
            (lambda _
              ;; Needs internet access.
@@ -522,8 +514,7 @@ (define-public docker
              ;; This file uses /var.
              (delete-file "daemon/oci_linux_test.go")
              ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")
-             #t))
+             (delete-file "pkg/signal/signal_linux_test.go")))
          (replace 'configure
            (lambda _
              (setenv "DOCKER_BUILDTAGS" "seccomp")
@@ -536,8 +527,7 @@ (define-public docker
              ;; information, and the DWARF symbol table.
              (setenv "LDFLAGS" "-s -w")
              ;; Make build faster
-             (setenv "GOCACHE" "/tmp")
-             #t))
+             (setenv "GOCACHE" "/tmp")))
          (add-before 'build 'setup-go-environment
            (assoc-ref go:%standard-phases 'setup-go-environment))
          (replace 'build
@@ -559,8 +549,7 @@ (define-public docker
                                           "/.gopath/src/github.com/docker/docker"))
              (with-directory-excursion ".gopath/src/github.com/docker/docker"
                (invoke "hack/test/unit"))
-             (setenv "PWD" #f)
-             #t))
+             (setenv "PWD" #f)))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -568,8 +557,7 @@ (define-public docker
                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
                                             (getenv "VERSION"))
-                             out-bin)
-               #t)))
+                             out-bin))))
          (add-after 'install 'remove-go-references
            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
@@ -594,7 +582,7 @@ (define-public docker
        ("xz" ,xz)))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
-           go-1.14 gotestsum pkg-config))
+           go gotestsum pkg-config))
     (synopsis "Docker container component library, and daemon")
     (description "This package provides a framework to assemble specialized
 container systems.  It includes components for orchestration, image
@@ -615,7 +603,7 @@ (define-public docker-cli
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "1asapjj8brvbkd5irgdq82fx1ihrc14qaq30jxvjwflfm5yb7lv0"))))
+       (base32 "1jnql7szdk2wd3f5g1bxcairsmzirzybn3hy7xzqx1i679f2fg5v"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
@@ -635,11 +623,11 @@ (define-public docker-cli
              ;; Make build reproducible.
              (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
              (symlink "src/github.com/docker/cli/scripts" "./scripts")
-             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
-             #t))
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")))
          (replace 'build
            (lambda _
-             (invoke "./scripts/build/dynbinary")))
+             (setenv "GO_LINKMODE" "dynamic")
+             (invoke "./scripts/build/binary")))
          (replace 'check
            (lambda* (#:key make-flags tests? #:allow-other-keys)
              (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
@@ -648,8 +636,7 @@ (define-public docker-cli
                  (with-directory-excursion "src/github.com/docker/cli"
                    ;; TODO: Run test-e2e as well?
                    (apply invoke "make" "-f" "docker.Makefile" "test-unit"
-                          (or make-flags '())))
-                 #t)))
+                          (or make-flags '()))))))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -662,8 +649,7 @@ (define-public docker-cli
                                (string-append etc "/fish/completions"))
                  (install-file "zsh/_docker"
                                (string-append etc "/zsh/site-functions")))
-               (install-file "build/docker" out-bin)
-               #t))))))
+               (install-file "build/docker" out-bin)))))))
     (native-inputs
      (list go libltdl pkg-config))
     (synopsis "Command line interface to Docker")
diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 9010e1f120..28ef92679d 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -1691,8 +1691,8 @@ (define-public go-netns
 (define-public go-sctp
   ;; docker-libnetwork-cmd-proxy requires this exact commit.
   ;; This commit is mentioned in docker-libnetwork-cmd-proxy's vendor.conf.
-  (let ((commit "6e2cb1366111dcf547c13531e3a263a067715847")
-        (revision "2"))
+  (let ((commit "f2269e66cdee387bd321445d5d300893449805be")
+        (revision "3"))
     (package
       (name "go-sctp")
       (version (git-version "0.0.0" revision commit))
@@ -1704,7 +1704,7 @@ (define-public go-sctp
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "1ba90fmpdwxa1ba4hrsjhi3gfy3pwmz7x8amw1p5dc9p5a7nnqrb"))))
+                  "04463rnn9y9psp11ac5di6wrwxlhymw5h9hfhhhnxqwla90ikp0g"))))
       (build-system go-build-system)
       (arguments
        `(#:tests? #f    ; Test suite is flakey.
diff --git a/gnu/packages/patches/docker-fix-tests.patch b/gnu/packages/patches/docker-fix-tests.patch
deleted file mode 100644
index 3e3e318e25..0000000000
--- a/gnu/packages/patches/docker-fix-tests.patch
+++ /dev/null
@@ -1,28 +0,0 @@
-Author: Danny Milosavljevic <dannym@scratchpost.org>
-The socket name ended up too long inside the container.
-Use a shorter one.
---- a/pkg/authorization/authz_unix_test.go	2019-01-10 01:55:02.997985947 +0100
-+++ b/pkg/authorization/authz_unix_test.go	2019-01-10 02:03:21.177439757 +0100
-@@ -24,7 +24,7 @@
- )
-
- const (
--	pluginAddress = "authz-test-plugin.sock"
-+	pluginAddress = "/tmp/authz-test-plugin.sock"
- )
-
- func TestAuthZRequestPluginError(t *testing.T) {
-@@ -263,12 +263,7 @@
-
- // createTestPlugin creates a new sample authorization plugin
- func createTestPlugin(t *testing.T) *authorizationPlugin {
--	pwd, err := os.Getwd()
--	if err != nil {
--		t.Fatal(err)
--	}
--
--	client, err := plugins.NewClient("unix:///"+path.Join(pwd, pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
-+	client, err := plugins.NewClient("unix:///"+path.Join("/", pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
- 	if err != nil {
- 		t.Fatalf("Failed to create client %v", err)
- 	}
--
2.36.0





^ permalink raw reply related	[relevance 83%]

* [bug#54934] [PATCH 2/4] gnu: docker-compose: Use python-pyyaml@5.
  @ 2022-04-14 11:10 72% ` zimoun
  0 siblings, 0 replies; 149+ results
From: zimoun @ 2022-04-14 11:10 UTC (permalink / raw)
  To: 54934; +Cc: zimoun

* gnu/packages/docker.scm (docker-compose)[inputs]: Replace python-pyyaml by
python-pyyaml-5.
---
 gnu/packages/docker.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3f52f4f8db..07731886ae 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -122,7 +122,7 @@ (define-public docker-compose
            python-docopt
            python-dotenv
            python-jsonschema
-           python-pyyaml
+           python-pyyaml-5
            python-requests
            python-six
            python-texttable
-- 
2.35.1





^ permalink raw reply related	[relevance 72%]

* [bug#54866] [PATCH] docker-compose, python-pyyaml
@ 2022-04-11 22:28 65% daniel.herzig
  0 siblings, 0 replies; 149+ results
From: daniel.herzig @ 2022-04-11 22:28 UTC (permalink / raw)
  To: 54866


[-- Attachment #1.1: Type: text/plain, Size: 608 bytes --]

Hi Guix,

I noticed that after my last pull to 6413d0898b92, docker-compose did
not build anymore. The backtrace showed that it fails in the sanity-
check-phase due to the requirement python-pyyaml <6.

As it builds nicely on guix 9bd4ed3, which still features
python-pyyaml@5.4.1 I took the definition from there, re-added it to
python-xyz.scm and adjusted docker-compose in docker.scm.  You find the
patchfile attached, as evolution seems to mess with line-breaks
(docker-compose build tested on x86_64 only, as I don't have anything
else around).

Best & thanks for your great work,
Daniel

[-- Attachment #1.2: 0001-re-adding-python-pyyaml-5.4.1-for-compatibility-with.patch --]
[-- Type: text/x-patch, Size: 2191 bytes --]

From eab4590fe2c9726920dbe07202616908065dad62 Mon Sep 17 00:00:00 2001
From: Daniel <daniel.herzig@outlook.at>
Date: Tue, 12 Apr 2022 00:04:27 +0200
Subject: [PATCH] re-adding python-pyyaml@5.4.1 for compatibility with
 docker-compose@1.29.2

---
 gnu/packages/docker.scm     |  2 +-
 gnu/packages/python-xyz.scm | 24 ++++++++++++++++++++++++
 2 files changed, 25 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3f52f4f8db..07731886ae 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -122,7 +122,7 @@ (define-public docker-compose
            python-docopt
            python-dotenv
            python-jsonschema
-           python-pyyaml
+           python-pyyaml-5
            python-requests
            python-six
            python-texttable
diff --git a/gnu/packages/python-xyz.scm b/gnu/packages/python-xyz.scm
index e83eb017f5..12b538594e 100644
--- a/gnu/packages/python-xyz.scm
+++ b/gnu/packages/python-xyz.scm
@@ -3928,6 +3928,30 @@ (define-public python-pyyaml
     (license license:expat)
     (properties `((python2-variant . ,(delay python2-pyyaml))))))
 
+;; for docker-compose 1.29.2 compatibility
+(define-public python-pyyaml-5
+  (package
+    (name "python-pyyaml")
+    (version "5.4.1")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (pypi-uri "PyYAML" version))
+       (sha256
+	(base32
+	 "0pm440pmpvgv5rbbnm8hk4qga5a292kvlm1bh3x2nwr8pb5p8xv0"))))
+    (build-system python-build-system)
+    (inputs
+     (list libyaml python-cython))
+    (home-page "https://pyyaml.org")
+    (synopsis "YAML parser and emitter for Python")
+    (description
+     "PyYAML is a YAML parser and emitter for Python.  PyYAML features a
+complete YAML 1.1 parser, Unicode support, pickle support, capable extension
+API, and sensible error messages.  PyYAML supports standard YAML tags and
+provides Python-specific tags that represent an arbitrary Python object.")
+    (license license:expat)))
+
 (define-public python2-pyyaml
   (let ((base (package-with-python2 (strip-python2-variant python-pyyaml))))
     (package

base-commit: 6413d0898b92efda8213b3ced0b6d1c736726b89
-- 
2.35.1


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 695 bytes --]

^ permalink raw reply related	[relevance 65%]

* [bug#52790] [PATCH v2 6/7] gnu: docker: Update to 20.10.14.
  2022-04-01  0:46 83% ` [bug#52790] [PATCH v2 6/7] gnu: docker: Update to 20.10.14 Pierre Langlois
@ 2022-04-01  1:11 70%   ` Pierre Langlois
  0 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-04-01  1:11 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois


[-- Attachment #1.1: Type: text/plain, Size: 7277 bytes --]


Pierre Langlois <pierre.langlois@gmx.com> writes:

> * gnu/packages/docker.scm (%docker-version): Update to 20.10.14.
> (docker-libnetwork): Update commit according to vendor.conf.
> (docker)[origin]: Remove docker-fix-tests.patch.
> [arguments]: Adapt 'patch-paths phase, substitute "ip6tables" and
> buildkit-qemu.  Remove trailing #t.
> [native-inputs]: Replace go-1.14 by go.
> (docker-cli)[arguments]: Set GO_LINKMODE to "dynamic".  Remove trailing #t.
> * gnu/packages/networking.scm (go-sctp): Update commit according to
> docker-libnetwork's vendor.conf.
> * gnu/packages/patches/docker-fix-tests.patch: Delete.
> * gnu/local.mk (dist_patch_DATA): Remove patch.
> ---
>  gnu/local.mk                                |  1 -
>  gnu/packages/docker.scm                     | 69 ++++++++-------------
>  gnu/packages/networking.scm                 |  6 +-
>  gnu/packages/patches/docker-fix-tests.patch | 28 ---------
>  4 files changed, 29 insertions(+), 75 deletions(-)
>  delete mode 100644 gnu/packages/patches/docker-fix-tests.patch
>
> diff --git a/gnu/local.mk b/gnu/local.mk
> index a704161abc..d5b3d4bba3 100644
> --- a/gnu/local.mk
> +++ b/gnu/local.mk
> @@ -1007,7 +1007,6 @@ dist_patch_DATA =						\
>    %D%/packages/patches/docbook-xsl-support-old-url.patch	\
>    %D%/packages/patches/doc++-include-directives.patch		\
>    %D%/packages/patches/doc++-segfault-fix.patch			\
> -  %D%/packages/patches/docker-fix-tests.patch			\
>    %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
>    %D%/packages/patches/dstat-fix-crash-when-specifying-delay.patch	\
>    %D%/packages/patches/dstat-skip-devices-without-io.patch	\
> diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
> index 0d721ead38..020c89bb11 100644
> --- a/gnu/packages/docker.scm
> +++ b/gnu/packages/docker.scm
> @@ -54,7 +54,7 @@ (define-module (gnu packages docker)
>
>  ;; Note - when changing Docker versions it is important to update the versions
>  ;; of several associated packages (docker-libnetwork and go-sctp).
> -(define %docker-version "19.03.15")
> +(define %docker-version "20.10.14")
>
>  (define-public python-docker
>    (package
> @@ -252,13 +252,12 @@ (define-public containerd
>  ;;; anyway, as it needs many dependencies that aren't being satisfied.
>  (define docker-libnetwork
>    ;; There are no recent release for libnetwork, so choose the last commit of
> -  ;; the branch that Docker uses, as can be seen in the Docker source file
> -  ;; 'hack/dockerfile/install/proxy.installer'. NOTE - It is important that
> -  ;; this version is kept in sync with the version of Docker being used.
> -  ;; This commit is the "bump_19.03" branch, as mentioned in Docker's vendor.conf.
> -  (let ((commit "55e924b8a84231a065879156c0de95aefc5f5435")
> +  ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
> +  ;; source file.  NOTE - It is important that this version is kept in sync
> +  ;; with the version of Docker being used.
> +  (let ((commit "339b972b464ee3d401b5788b2af9e31d09d6b7da")
>          (version (version-major+minor %docker-version))
> -        (revision "1"))
> +        (revision "2"))
>      (package
>        (name "docker-libnetwork")
>        (version (git-version version revision commit))
> @@ -271,7 +270,7 @@ (define docker-libnetwork
>                  (file-name (git-file-name name version))
>                  (sha256
>                   (base32
> -                  "19syb3scwiykn44gqfaqrgqv8a0df4ps0ykf3za9xkjc5cyi99mp"))
> +                  "0wx2hdwx56cbxiaky9kw2bi1prdfgzwr776lq1k0slw8kvn0cn32"))
>                  ;; Delete bundled ("vendored") free software source code.
>                  (modules '((guix build utils)))
>                  (snippet '(begin
> @@ -324,9 +323,7 @@ (define-public docker
>               (commit (string-append "v" version))))
>         (file-name (git-file-name name version))
>         (sha256
> -        (base32 "0419iha9zmwlhzhnbfxlsa13vgd04yifnsr8qqnj2ks5dxrcajl8"))
> -       (patches
> -        (search-patches "docker-fix-tests.patch"))))
> +        (base32 "18nid42p1n20mg7spz0knh4izkk8qgjz9xi6v54czvy7aaj336i3"))))
>      (build-system gnu-build-system)
>      (arguments
>       `(#:modules
> @@ -369,9 +366,10 @@ (define-public docker
>                 (("DefaultRuntimeBinary = .*")
>                  (string-append "DefaultRuntimeBinary = \""
>                                 (assoc-ref inputs "runc")
> -                               "/sbin/runc\"\n"))
> -               (("DefaultRuntimeName = .*")
> -                (string-append "DefaultRuntimeName = \""
> +                               "/sbin/runc\"\n")))
> +             (substitute* "daemon/runtime_unix.go"
> +               (("defaultRuntimeName = .*")
> +                (string-append "defaultRuntimeName = \""
>                                 (assoc-ref inputs "runc")
>                                 "/sbin/runc\"\n")))
>               (substitute* "daemon/config/config.go"
> @@ -400,16 +398,6 @@ (define-public docker
>               (substitute* "pkg/archive/archive.go"
>                 (("string\\{\"xz")
>                  (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
> -             ;; TODO: Remove when Docker proper uses v1.14.x to build
> -             (substitute* "registry/resumable/resumablerequestreader_test.go"
> -               (("I%27m%20not%20an%20url" all)
> -                (string-append "\"" all "\"")))
> -             ;; TODO: Remove when Docker proper uses v1.14.x to build
> -             (substitute* "vendor/gotest.tools/x/subtest/context.go"
> -               (("func \\(tc \\*testcase\\) Cleanup\\(" all)
> -                (string-append all "func()"))
> -               (("tc\\.Cleanup\\(" all)
> -                (string-append all "nil")))
>
>               (let ((source-files (filter (lambda (name)
>                                             (not (string-contains name "test")))
> @@ -446,6 +434,7 @@ (define-public docker
>                    ("blkid" "util-linux" "sbin/blkid")
>                    ("unpigz" "pigz" "bin/unpigz")
>                    ("iptables" "iptables" "sbin/iptables")
> +                  ("ip6tables" "iptables" "sbin/ip6tables")
>                    ("iptables-legacy" "iptables" "sbin/iptables")
>                    ("ip" "iproute2" "sbin/ip"))
>
> @@ -494,10 +483,10 @@ (define-public docker
>                    "exec.Command")
>                   ;; Search for ZFS in PATH.
>                   (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
> +                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")

I forgot, I wanted to add a comment to clarify the qemu change here.
IIUC, docker can do qemu-based emulation, but we don't support it yet in
Guix, I believe we'd need to add the following packages:

  - https://github.com/moby/buildkit: Seems to be a "next-gen" generic
    image builder backend.
  - https://github.com/docker/buildx: To have a `docker buildx' command,
    to link docker with the buildkit backend.

Here's a new 2.5 patch that adds the following note:

;; Do not fail when buildkit-qemu-<target> isn't found.
;; FIXME: We might need to package buildkit and docker's
;; buildx plugin, to support qemu-based docker containers.


[-- Attachment #1.2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0006-gnu-docker-Update-to-20.10.14.patch --]
[-- Type: text/x-patch, Size: 14244 bytes --]

From 7c9a1ac422d802234099b7c57e067dbe217ac386 Mon Sep 17 00:00:00 2001
From: Pierre Langlois <pierre.langlois@gmx.com>
Date: Sat, 25 Dec 2021 02:08:39 +0000
Subject: [PATCH v2.5 6/7] gnu: docker: Update to 20.10.14.

* gnu/packages/docker.scm (%docker-version): Update to 20.10.14.
(docker-libnetwork): Update commit according to vendor.conf.
(docker)[origin]: Remove docker-fix-tests.patch.
[arguments]: Adapt 'patch-paths phase, substitute "ip6tables" and
buildkit-qemu.  Remove trailing #t.
[native-inputs]: Replace go-1.14 by go.
(docker-cli)[arguments]: Set GO_LINKMODE to "dynamic".  Remove trailing #t.
* gnu/packages/networking.scm (go-sctp): Update commit according to
docker-libnetwork's vendor.conf.
* gnu/packages/patches/docker-fix-tests.patch: Delete.
* gnu/local.mk (dist_patch_DATA): Remove patch.
---
 gnu/local.mk                                |  1 -
 gnu/packages/docker.scm                     | 72 +++++++++------------
 gnu/packages/networking.scm                 |  6 +-
 gnu/packages/patches/docker-fix-tests.patch | 28 --------
 4 files changed, 32 insertions(+), 75 deletions(-)
 delete mode 100644 gnu/packages/patches/docker-fix-tests.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index a704161abc..d5b3d4bba3 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1007,7 +1007,6 @@ dist_patch_DATA =						\
   %D%/packages/patches/docbook-xsl-support-old-url.patch	\
   %D%/packages/patches/doc++-include-directives.patch		\
   %D%/packages/patches/doc++-segfault-fix.patch			\
-  %D%/packages/patches/docker-fix-tests.patch			\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/dstat-fix-crash-when-specifying-delay.patch	\
   %D%/packages/patches/dstat-skip-devices-without-io.patch	\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 0d721ead38..82c017157d 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -54,7 +54,7 @@ (define-module (gnu packages docker)

 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "19.03.15")
+(define %docker-version "20.10.14")

 (define-public python-docker
   (package
@@ -252,13 +252,12 @@ (define-public containerd
 ;;; anyway, as it needs many dependencies that aren't being satisfied.
 (define docker-libnetwork
   ;; There are no recent release for libnetwork, so choose the last commit of
-  ;; the branch that Docker uses, as can be seen in the Docker source file
-  ;; 'hack/dockerfile/install/proxy.installer'. NOTE - It is important that
-  ;; this version is kept in sync with the version of Docker being used.
-  ;; This commit is the "bump_19.03" branch, as mentioned in Docker's vendor.conf.
-  (let ((commit "55e924b8a84231a065879156c0de95aefc5f5435")
+  ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
+  ;; source file.  NOTE - It is important that this version is kept in sync
+  ;; with the version of Docker being used.
+  (let ((commit "339b972b464ee3d401b5788b2af9e31d09d6b7da")
         (version (version-major+minor %docker-version))
-        (revision "1"))
+        (revision "2"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -271,7 +270,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "19syb3scwiykn44gqfaqrgqv8a0df4ps0ykf3za9xkjc5cyi99mp"))
+                  "0wx2hdwx56cbxiaky9kw2bi1prdfgzwr776lq1k0slw8kvn0cn32"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(begin
@@ -324,9 +323,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0419iha9zmwlhzhnbfxlsa13vgd04yifnsr8qqnj2ks5dxrcajl8"))
-       (patches
-        (search-patches "docker-fix-tests.patch"))))
+        (base32 "18nid42p1n20mg7spz0knh4izkk8qgjz9xi6v54czvy7aaj336i3"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -369,9 +366,10 @@ (define-public docker
                (("DefaultRuntimeBinary = .*")
                 (string-append "DefaultRuntimeBinary = \""
                                (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultRuntimeName = .*")
-                (string-append "DefaultRuntimeName = \""
+                               "/sbin/runc\"\n")))
+             (substitute* "daemon/runtime_unix.go"
+               (("defaultRuntimeName = .*")
+                (string-append "defaultRuntimeName = \""
                                (assoc-ref inputs "runc")
                                "/sbin/runc\"\n")))
              (substitute* "daemon/config/config.go"
@@ -400,16 +398,6 @@ (define-public docker
              (substitute* "pkg/archive/archive.go"
                (("string\\{\"xz")
                 (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "registry/resumable/resumablerequestreader_test.go"
-               (("I%27m%20not%20an%20url" all)
-                (string-append "\"" all "\"")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "vendor/gotest.tools/x/subtest/context.go"
-               (("func \\(tc \\*testcase\\) Cleanup\\(" all)
-                (string-append all "func()"))
-               (("tc\\.Cleanup\\(" all)
-                (string-append all "nil")))

              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
@@ -446,6 +434,7 @@ (define-public docker
                   ("blkid" "util-linux" "sbin/blkid")
                   ("unpigz" "pigz" "bin/unpigz")
                   ("iptables" "iptables" "sbin/iptables")
+                  ("ip6tables" "iptables" "sbin/ip6tables")
                   ("iptables-legacy" "iptables" "sbin/iptables")
                   ("ip" "iproute2" "sbin/ip"))

@@ -494,10 +483,13 @@ (define-public docker
                   "exec.Command")
                  ;; Search for ZFS in PATH.
                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                 ;; Do not fail when buildkit-qemu-<target> isn't found.
+                 ;; FIXME: We might need to package buildkit and docker's
+                 ;; buildx plugin, to support qemu-based docker containers.
+                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
                  ;; Fail on other unsubstituted LookPaths.
                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))
-             #t))
+                 (("\\<LooxPath") "LookPath")))))
          (add-after 'patch-paths 'delete-failing-tests
            (lambda _
              ;; Needs internet access.
@@ -522,8 +514,7 @@ (define-public docker
              ;; This file uses /var.
              (delete-file "daemon/oci_linux_test.go")
              ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")
-             #t))
+             (delete-file "pkg/signal/signal_linux_test.go")))
          (replace 'configure
            (lambda _
              (setenv "DOCKER_BUILDTAGS" "seccomp")
@@ -536,8 +527,7 @@ (define-public docker
              ;; information, and the DWARF symbol table.
              (setenv "LDFLAGS" "-s -w")
              ;; Make build faster
-             (setenv "GOCACHE" "/tmp")
-             #t))
+             (setenv "GOCACHE" "/tmp")))
          (add-before 'build 'setup-go-environment
            (assoc-ref go:%standard-phases 'setup-go-environment))
          (replace 'build
@@ -559,8 +549,7 @@ (define-public docker
                                           "/.gopath/src/github.com/docker/docker"))
              (with-directory-excursion ".gopath/src/github.com/docker/docker"
                (invoke "hack/test/unit"))
-             (setenv "PWD" #f)
-             #t))
+             (setenv "PWD" #f)))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -568,8 +557,7 @@ (define-public docker
                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
                                             (getenv "VERSION"))
-                             out-bin)
-               #t)))
+                             out-bin))))
          (add-after 'install 'remove-go-references
            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
@@ -594,7 +582,7 @@ (define-public docker
        ("xz" ,xz)))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
-           go-1.14 gotestsum pkg-config))
+           go gotestsum pkg-config))
     (synopsis "Docker container component library, and daemon")
     (description "This package provides a framework to assemble specialized
 container systems.  It includes components for orchestration, image
@@ -615,7 +603,7 @@ (define-public docker-cli
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "1asapjj8brvbkd5irgdq82fx1ihrc14qaq30jxvjwflfm5yb7lv0"))))
+       (base32 "1nv6mzq9i9psgfbzx7hfx1qb6fjp649qg8y392z8z2kqbjl20g3q"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
@@ -635,11 +623,11 @@ (define-public docker-cli
              ;; Make build reproducible.
              (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
              (symlink "src/github.com/docker/cli/scripts" "./scripts")
-             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
-             #t))
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")))
          (replace 'build
            (lambda _
-             (invoke "./scripts/build/dynbinary")))
+             (setenv "GO_LINKMODE" "dynamic")
+             (invoke "./scripts/build/binary")))
          (replace 'check
            (lambda* (#:key make-flags tests? #:allow-other-keys)
              (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
@@ -648,8 +636,7 @@ (define-public docker-cli
                  (with-directory-excursion "src/github.com/docker/cli"
                    ;; TODO: Run test-e2e as well?
                    (apply invoke "make" "-f" "docker.Makefile" "test-unit"
-                          (or make-flags '())))
-                 #t)))
+                          (or make-flags '()))))))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -662,8 +649,7 @@ (define-public docker-cli
                                (string-append etc "/fish/completions"))
                  (install-file "zsh/_docker"
                                (string-append etc "/zsh/site-functions")))
-               (install-file "build/docker" out-bin)
-               #t))))))
+               (install-file "build/docker" out-bin)))))))
     (native-inputs
      (list go libltdl pkg-config))
     (synopsis "Command line interface to Docker")
diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index b45f2f79f2..54116e4f4c 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -1691,8 +1691,8 @@ (define-public go-netns
 (define-public go-sctp
   ;; docker-libnetwork-cmd-proxy requires this exact commit.
   ;; This commit is mentioned in docker-libnetwork-cmd-proxy's vendor.conf.
-  (let ((commit "6e2cb1366111dcf547c13531e3a263a067715847")
-        (revision "2"))
+  (let ((commit "f2269e66cdee387bd321445d5d300893449805be")
+        (revision "3"))
     (package
       (name "go-sctp")
       (version (git-version "0.0.0" revision commit))
@@ -1704,7 +1704,7 @@ (define-public go-sctp
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "1ba90fmpdwxa1ba4hrsjhi3gfy3pwmz7x8amw1p5dc9p5a7nnqrb"))))
+                  "04463rnn9y9psp11ac5di6wrwxlhymw5h9hfhhhnxqwla90ikp0g"))))
       (build-system go-build-system)
       (arguments
        `(#:tests? #f    ; Test suite is flakey.
diff --git a/gnu/packages/patches/docker-fix-tests.patch b/gnu/packages/patches/docker-fix-tests.patch
deleted file mode 100644
index 3e3e318e25..0000000000
--- a/gnu/packages/patches/docker-fix-tests.patch
+++ /dev/null
@@ -1,28 +0,0 @@
-Author: Danny Milosavljevic <dannym@scratchpost.org>
-The socket name ended up too long inside the container.
-Use a shorter one.
---- a/pkg/authorization/authz_unix_test.go	2019-01-10 01:55:02.997985947 +0100
-+++ b/pkg/authorization/authz_unix_test.go	2019-01-10 02:03:21.177439757 +0100
-@@ -24,7 +24,7 @@
- )
-
- const (
--	pluginAddress = "authz-test-plugin.sock"
-+	pluginAddress = "/tmp/authz-test-plugin.sock"
- )
-
- func TestAuthZRequestPluginError(t *testing.T) {
-@@ -263,12 +263,7 @@
-
- // createTestPlugin creates a new sample authorization plugin
- func createTestPlugin(t *testing.T) *authorizationPlugin {
--	pwd, err := os.Getwd()
--	if err != nil {
--		t.Fatal(err)
--	}
--
--	client, err := plugins.NewClient("unix:///"+path.Join(pwd, pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
-+	client, err := plugins.NewClient("unix:///"+path.Join("/", pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
- 	if err != nil {
- 		t.Fatalf("Failed to create client %v", err)
- 	}
--
2.34.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0007-gnu-docker-Switch-to-gexp-and-new-input-style.patch --]
[-- Type: text/x-patch, Size: 27649 bytes --]

From 4089db85b366e3f8fd394d254807ddd4b4631c3c Mon Sep 17 00:00:00 2001
From: Pierre Langlois <pierre.langlois@gmx.com>
Date: Fri, 1 Apr 2022 01:34:52 +0100
Subject: [PATCH v2.5 7/7] gnu: docker: Switch to gexp and new input style.

* gnu/packages/docker.scm (docker)[arguments]: Rewrite as gexps.  Switch
to using search-input-file.
[inputs]: Use new style inputs.
---
 gnu/packages/docker.scm | 483 ++++++++++++++++++++--------------------
 1 file changed, 241 insertions(+), 242 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 82c017157d..edec4d3b27 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -326,260 +326,259 @@ (define-public docker
         (base32 "18nid42p1n20mg7spz0knh4izkk8qgjz9xi6v54czvy7aaj336i3"))))
     (build-system gnu-build-system)
     (arguments
-     `(#:modules
-       ((guix build gnu-build-system)
+     (list
+      #:modules
+      '((guix build gnu-build-system)
         ((guix build go-build-system) #:prefix go:)
         (guix build union)
         (guix build utils))
-       #:imported-modules
-       (,@%gnu-build-system-modules
+      #:imported-modules
+      `(,@%gnu-build-system-modules
         (guix build union)
         (guix build go-build-system))
-       #:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'patch-paths
-           (lambda* (#:key inputs #:allow-other-keys)
-             (substitute* "builder/builder-next/executor_unix.go"
-               (("CommandCandidates:.*runc.*")
-                (string-append "CommandCandidates: []string{\""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"},\n")))
-             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-               (("DefaultCommand = .*")
-                (string-append "DefaultCommand = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
-               (("defaultRuntime[ \t]*=.*")
-                (string-append "defaultRuntime = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("defaultShim[ \t]*=.*")
-                (string-append "defaultShim = \""
-                               (assoc-ref inputs "containerd")
-                               "/bin/containerd-shim\"\n")))
-             (substitute* "daemon/daemon_unix.go"
-               (("DefaultShimBinary = .*")
-                (string-append "DefaultShimBinary = \""
-                               (assoc-ref inputs "containerd")
-                               "/bin/containerd-shim\"\n"))
-               (("DefaultRuntimeBinary = .*")
-                (string-append "DefaultRuntimeBinary = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "daemon/runtime_unix.go"
-               (("defaultRuntimeName = .*")
-                (string-append "defaultRuntimeName = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "daemon/config/config.go"
-               (("StockRuntimeName = .*")
-                (string-append "StockRuntimeName = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultInitBinary = .*")
-                (string-append "DefaultInitBinary = \""
-                               (assoc-ref inputs "tini")
-                               "/bin/tini-static\"\n")))
-             (substitute* "daemon/config/config_common_unix_test.go"
-               (("expectedInitPath: \"docker-init\"")
-                (string-append "expectedInitPath: \""
-                               (assoc-ref inputs "tini")
-                               "/bin/tini-static\"")))
-             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
-               (("var defaultCommandCandidates = .*")
-                (string-append "var defaultCommandCandidates = []string{\""
-                               (assoc-ref inputs "runc") "/sbin/runc\"}")))
-             (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
-               (("var userlandProxyCommandName = .*")
-                (string-append "var userlandProxyCommandName = \""
-                               (assoc-ref inputs "docker-proxy")
-                               "/bin/proxy\"\n")))
-             (substitute* "pkg/archive/archive.go"
-               (("string\\{\"xz")
-                (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'patch-paths
+            (lambda* (#:key inputs #:allow-other-keys)
+              (substitute* "builder/builder-next/executor_unix.go"
+                (("CommandCandidates:.*runc.*")
+                 (string-append "CommandCandidates: []string{\""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"},\n")))
+              (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+                (("DefaultCommand = .*")
+                 (string-append "DefaultCommand = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
+                (("defaultRuntime[ \t]*=.*")
+                 (string-append "defaultRuntime = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n"))
+                (("defaultShim[ \t]*=.*")
+                 (string-append "defaultShim = \""
+                                (search-input-file inputs "/bin/containerd-shim")
+                                "\"\n")))
+              (substitute* "daemon/daemon_unix.go"
+                (("DefaultShimBinary = .*")
+                 (string-append "DefaultShimBinary = \""
+                                (search-input-file inputs "/bin/containerd-shim")
+                                "\"\n"))
+                (("DefaultRuntimeBinary = .*")
+                 (string-append "DefaultRuntimeBinary = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "daemon/runtime_unix.go"
+                (("defaultRuntimeName = .*")
+                 (string-append "defaultRuntimeName = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "daemon/config/config.go"
+                (("StockRuntimeName = .*")
+                 (string-append "StockRuntimeName = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n"))
+                (("DefaultInitBinary = .*")
+                 (string-append "DefaultInitBinary = \""
+                                (search-input-file inputs "/bin/tini-static")
+                                "\"\n")))
+              (substitute* "daemon/config/config_common_unix_test.go"
+                (("expectedInitPath: \"docker-init\"")
+                 (string-append "expectedInitPath: \""
+                                (search-input-file inputs "/bin/tini-static")
+                                "\"")))
+              (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+                (("var defaultCommandCandidates = .*")
+                 (string-append "var defaultCommandCandidates = []string{\""
+                                (search-input-file inputs "/sbin/runc") "\"}")))
+              (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
+                (("var userlandProxyCommandName = .*")
+                 (string-append "var userlandProxyCommandName = \""
+                                (search-input-file inputs "/bin/proxy")
+                                "\"\n")))
+              (substitute* "pkg/archive/archive.go"
+                (("string\\{\"xz")
+                 (string-append "string{\"" (search-input-file inputs "/bin/xz"))))

-             (let ((source-files (filter (lambda (name)
-                                           (not (string-contains name "test")))
-                                         (find-files "." "\\.go$"))))
-               (let-syntax ((substitute-LookPath*
-                             (syntax-rules ()
-                               ((_ (source-text package relative-path) ...)
-                                (substitute* source-files
-                                  (((string-append "\\<exec\\.LookPath\\(\""
-                                                   source-text
-                                                   "\")"))
-                                   (string-append "\""
-                                                  (assoc-ref inputs package)
-                                                  "/" relative-path
-                                                  "\", error(nil)")) ...))))
-                            (substitute-Command*
-                             (syntax-rules ()
-                               ((_ (source-text package relative-path) ...)
-                                (substitute* source-files
-                                  (((string-append "\\<(re)?exec\\.Command\\(\""
-                                                   source-text
-                                                   "\"") _ re?)
-                                   (string-append (if re? re? "")
-                                                  "exec.Command(\""
-                                                  (assoc-ref inputs package)
-                                                  "/" relative-path
-                                                  "\"")) ...)))))
-                 (substitute-LookPath*
-                  ("containerd" "containerd" "bin/containerd")
-                  ("ps" "procps" "bin/ps")
-                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                  ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
-                  ("pvdisplay" "lvm2" "sbin/pvdisplay")
-                  ("blkid" "util-linux" "sbin/blkid")
-                  ("unpigz" "pigz" "bin/unpigz")
-                  ("iptables" "iptables" "sbin/iptables")
-                  ("ip6tables" "iptables" "sbin/ip6tables")
-                  ("iptables-legacy" "iptables" "sbin/iptables")
-                  ("ip" "iproute2" "sbin/ip"))
+              (let ((source-files (filter (lambda (name)
+                                            (not (string-contains name "test")))
+                                          (find-files "." "\\.go$"))))
+                (let-syntax ((substitute-LookPath*
+                              (syntax-rules ()
+                                ((_ (source-text path) ...)
+                                 (substitute* source-files
+                                   (((string-append "\\<exec\\.LookPath\\(\""
+                                                    source-text
+                                                    "\")"))
+                                    (string-append "\""
+                                                   (search-input-file inputs path)
+                                                   "\", error(nil)")) ...))))
+                             (substitute-Command*
+                              (syntax-rules ()
+                                ((_ (source-text path) ...)
+                                 (substitute* source-files
+                                   (((string-append "\\<(re)?exec\\.Command\\(\""
+                                                    source-text
+                                                    "\"") _ re?)
+                                    (string-append (if re? re? "")
+                                                   "exec.Command(\""
+                                                   (search-input-file inputs path)
+                                                   "\"")) ...)))))
+                  (substitute-LookPath*
+                   ("containerd" "/bin/containerd")
+                   ("ps" "/bin/ps")
+                   ("mkfs.xfs" "/sbin/mkfs.xfs")
+                   ("lvmdiskscan" "/sbin/lvmdiskscan")
+                   ("pvdisplay" "/sbin/pvdisplay")
+                   ("blkid" "/sbin/blkid")
+                   ("unpigz" "/bin/unpigz")
+                   ("iptables" "/sbin/iptables")
+                   ("ip6tables" "/sbin/ip6tables")
+                   ("iptables-legacy" "/sbin/iptables")
+                   ("ip" "/sbin/ip"))

-                 (substitute-Command*
-                  ("modprobe" "kmod" "bin/modprobe")
-                  ("pvcreate" "lvm2" "sbin/pvcreate")
-                  ("vgcreate" "lvm2" "sbin/vgcreate")
-                  ("lvcreate" "lvm2" "sbin/lvcreate")
-                  ("lvconvert" "lvm2" "sbin/lvconvert")
-                  ("lvchange" "lvm2" "sbin/lvchange")
-                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                  ("xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
-                  ("mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
-                  ("tune2fs" "e2fsprogs" "sbin/tune2fs")
-                  ("blkid" "util-linux" "sbin/blkid")
-                  ("resize2fs" "e2fsprogs" "sbin/resize2fs")
-                  ("ps" "procps" "bin/ps")
-                  ("losetup" "util-linux" "sbin/losetup")
-                  ("uname" "coreutils" "bin/uname")
-                  ("dbus-launch" "dbus" "bin/dbus-launch")
-                  ("git" "git" "bin/git")))
-               ;; docker-mountfrom ??
-               ;; docker
-               ;; docker-untar ??
-               ;; docker-applyLayer ??
-               ;; /usr/bin/uname
-               ;; grep
-               ;; apparmor_parser
+                  (substitute-Command*
+                   ("modprobe" "/bin/modprobe")
+                   ("pvcreate" "/sbin/pvcreate")
+                   ("vgcreate" "/sbin/vgcreate")
+                   ("lvcreate" "/sbin/lvcreate")
+                   ("lvconvert" "/sbin/lvconvert")
+                   ("lvchange" "/sbin/lvchange")
+                   ("mkfs.xfs" "/sbin/mkfs.xfs")
+                   ("xfs_growfs" "/sbin/xfs_growfs")
+                   ("mkfs.ext4" "/sbin/mkfs.ext4")
+                   ("tune2fs" "/sbin/tune2fs")
+                   ("blkid" "/sbin/blkid")
+                   ("resize2fs" "/sbin/resize2fs")
+                   ("ps" "/bin/ps")
+                   ("losetup" "/sbin/losetup")
+                   ("uname" "/bin/uname")
+                   ("dbus-launch" "/bin/dbus-launch")
+                   ("git" "/bin/git")))
+                ;; docker-mountfrom ??
+                ;; docker
+                ;; docker-untar ??
+                ;; docker-applyLayer ??
+                ;; /usr/bin/uname
+                ;; grep
+                ;; apparmor_parser

-               ;; Make compilation fail when, in future versions, Docker
-               ;; invokes other programs we don't know about and thus don't
-               ;; substitute.
-               (substitute* source-files
-                 ;; Search for Java in PATH.
-                 (("\\<exec\\.Command\\(\"java\"")
-                  "xxec.Command(\"java\"")
-                 ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                 (("\\<exec\\.Command\\(\"auplink\"")
-                  "xxec.Command(\"auplink\"")
-                 ;; Fail on other unsubstituted commands.
-                 (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                   _ executable)
-                  (string-append "exec.Guix_doesnt_want_Command(\""
-                                 executable "\""))
-                 (("\\<xxec\\.Command")
-                  "exec.Command")
-                 ;; Search for ZFS in PATH.
-                 (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                ;; Make compilation fail when, in future versions, Docker
+                ;; invokes other programs we don't know about and thus don't
+                ;; substitute.
+                (substitute* source-files
+                  ;; Search for Java in PATH.
+                  (("\\<exec\\.Command\\(\"java\"")
+                   "xxec.Command(\"java\"")
+                  ;; Search for AUFS in PATH (mainline Linux doesn't support it).
+                  (("\\<exec\\.Command\\(\"auplink\"")
+                   "xxec.Command(\"auplink\"")
+                  ;; Fail on other unsubstituted commands.
+                  (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
+                    _ executable)
+                   (string-append "exec.Guix_doesnt_want_Command(\""
+                                  executable "\""))
+                  (("\\<xxec\\.Command")
+                   "exec.Command")
+                  ;; Search for ZFS in PATH.
+                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
                  ;; Do not fail when buildkit-qemu-<target> isn't found.
                  ;; FIXME: We might need to package buildkit and docker's
                  ;; buildx plugin, to support qemu-based docker containers.
-                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
-                 ;; Fail on other unsubstituted LookPaths.
-                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))))
-         (add-after 'patch-paths 'delete-failing-tests
-           (lambda _
-             ;; Needs internet access.
-             (delete-file "builder/remotecontext/git/gitutils_test.go")
-             ;; Permission denied.
-             (delete-file "daemon/graphdriver/devmapper/devmapper_test.go")
-             ;; Operation not permitted (idtools.MkdirAllAndChown).
-             (delete-file "daemon/graphdriver/vfs/vfs_test.go")
-             ;; Timeouts after 5 min.
-             (delete-file "plugin/manager_linux_test.go")
-             ;; Operation not permitted.
-             (delete-file "daemon/graphdriver/aufs/aufs_test.go")
-             (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
-             (delete-file "daemon/graphdriver/overlay/overlay_test.go")
-             (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
-             (delete-file "pkg/chrootarchive/archive_unix_test.go")
-             (delete-file "daemon/container_unix_test.go")
-             ;; This file uses cgroups and /proc.
-             (delete-file "pkg/sysinfo/sysinfo_linux_test.go")
-             ;; This file uses cgroups.
-             (delete-file "runconfig/config_test.go")
-             ;; This file uses /var.
-             (delete-file "daemon/oci_linux_test.go")
-             ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")))
-         (replace 'configure
-           (lambda _
-             (setenv "DOCKER_BUILDTAGS" "seccomp")
-             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
-             (setenv "VERSION" (string-append ,%docker-version "-ce"))
-             ;; Automatically use bundled dependencies.
-             ;; TODO: Unbundle - see file "vendor.conf".
-             (setenv "AUTO_GOPATH" "1")
-             ;; Respectively, strip the symbol table and debug
-             ;; information, and the DWARF symbol table.
-             (setenv "LDFLAGS" "-s -w")
-             ;; Make build faster
-             (setenv "GOCACHE" "/tmp")))
-         (add-before 'build 'setup-go-environment
-           (assoc-ref go:%standard-phases 'setup-go-environment))
-         (replace 'build
-           (lambda _
-             ;; Our LD doesn't like the statically linked relocatable things
-             ;; that go produces, so install the dynamic version of
-             ;; dockerd instead.
-             (invoke "hack/make.sh" "dynbinary")))
-         (replace 'check
-           (lambda _
-             ;; The build process generated a file because the environment
-             ;; variable "AUTO_GOPATH" was set.  Use it.
-             (setenv "GOPATH" (string-append (getcwd) "/.gopath"))
-             ;; ".gopath/src/github.com/docker/docker" is a link to the current
-             ;; directory and chdir would canonicalize to that.
-             ;; But go needs to have the uncanonicalized directory name, so
-             ;; store that.
-             (setenv "PWD" (string-append (getcwd)
-                                          "/.gopath/src/github.com/docker/docker"))
-             (with-directory-excursion ".gopath/src/github.com/docker/docker"
-               (invoke "hack/test/unit"))
-             (setenv "PWD" #f)))
-         (replace 'install
-           (lambda* (#:key outputs #:allow-other-keys)
-             (let* ((out (assoc-ref outputs "out"))
-                    (out-bin (string-append out "/bin")))
-               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
-               (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
-                                            (getenv "VERSION"))
-                             out-bin))))
-         (add-after 'install 'remove-go-references
-           (assoc-ref go:%standard-phases 'remove-go-references)))))
+                  (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
+                  ;; Fail on other unsubstituted LookPaths.
+                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
+                  (("\\<LooxPath") "LookPath")))))
+          (add-after 'patch-paths 'delete-failing-tests
+            (lambda _
+              ;; Needs internet access.
+              (delete-file "builder/remotecontext/git/gitutils_test.go")
+              ;; Permission denied.
+              (delete-file "daemon/graphdriver/devmapper/devmapper_test.go")
+              ;; Operation not permitted (idtools.MkdirAllAndChown).
+              (delete-file "daemon/graphdriver/vfs/vfs_test.go")
+              ;; Timeouts after 5 min.
+              (delete-file "plugin/manager_linux_test.go")
+              ;; Operation not permitted.
+              (delete-file "daemon/graphdriver/aufs/aufs_test.go")
+              (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
+              (delete-file "daemon/graphdriver/overlay/overlay_test.go")
+              (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
+              (delete-file "pkg/chrootarchive/archive_unix_test.go")
+              (delete-file "daemon/container_unix_test.go")
+              ;; This file uses cgroups and /proc.
+              (delete-file "pkg/sysinfo/sysinfo_linux_test.go")
+              ;; This file uses cgroups.
+              (delete-file "runconfig/config_test.go")
+              ;; This file uses /var.
+              (delete-file "daemon/oci_linux_test.go")
+              ;; Signal tests fail in bizarre ways
+              (delete-file "pkg/signal/signal_linux_test.go")))
+          (replace 'configure
+            (lambda _
+              (setenv "DOCKER_BUILDTAGS" "seccomp")
+              (setenv "DOCKER_GITCOMMIT" (string-append "v" #$%docker-version))
+              (setenv "VERSION" (string-append #$%docker-version "-ce"))
+              ;; Automatically use bundled dependencies.
+              ;; TODO: Unbundle - see file "vendor.conf".
+              (setenv "AUTO_GOPATH" "1")
+              ;; Respectively, strip the symbol table and debug
+              ;; information, and the DWARF symbol table.
+              (setenv "LDFLAGS" "-s -w")
+              ;; Make build faster
+              (setenv "GOCACHE" "/tmp")))
+          (add-before 'build 'setup-go-environment
+            (assoc-ref go:%standard-phases 'setup-go-environment))
+          (replace 'build
+            (lambda _
+              ;; Our LD doesn't like the statically linked relocatable things
+              ;; that go produces, so install the dynamic version of
+              ;; dockerd instead.
+              (invoke "hack/make.sh" "dynbinary")))
+          (replace 'check
+            (lambda _
+              ;; The build process generated a file because the environment
+              ;; variable "AUTO_GOPATH" was set.  Use it.
+              (setenv "GOPATH" (string-append (getcwd) "/.gopath"))
+              ;; ".gopath/src/github.com/docker/docker" is a link to the current
+              ;; directory and chdir would canonicalize to that.
+              ;; But go needs to have the uncanonicalized directory name, so
+              ;; store that.
+              (setenv "PWD" (string-append (getcwd)
+                                           "/.gopath/src/github.com/docker/docker"))
+              (with-directory-excursion ".gopath/src/github.com/docker/docker"
+                (invoke "hack/test/unit"))
+              (setenv "PWD" #f)))
+          (replace 'install
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((out (assoc-ref outputs "out"))
+                     (out-bin (string-append out "/bin")))
+                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
+                                             (getenv "VERSION"))
+                              out-bin))))
+          (add-after 'install 'remove-go-references
+            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
-     `(("btrfs-progs" ,btrfs-progs)
-       ("containerd" ,containerd)       ; for containerd-shim
-       ("coreutils" ,coreutils)
-       ("dbus" ,dbus)
-       ("docker-proxy" ,docker-libnetwork-cmd-proxy)
-       ("e2fsprogs" ,e2fsprogs)
-       ("git" ,git)
-       ("iproute2" ,iproute)
-       ("iptables" ,iptables)
-       ("kmod" ,kmod)
-       ("libseccomp" ,libseccomp)
-       ("pigz" ,pigz)
-       ("procps" ,procps)
-       ("runc" ,runc)
-       ("util-linux" ,util-linux)
-       ("lvm2" ,lvm2)
-       ("tini" ,tini)
-       ("xfsprogs" ,xfsprogs)
-       ("xz" ,xz)))
+     (list btrfs-progs
+           containerd       ; for containerd-shim
+           coreutils
+           dbus
+           docker-libnetwork-cmd-proxy
+           e2fsprogs
+           git
+           iproute
+           iptables
+           kmod
+           libseccomp
+           pigz
+           procps
+           runc
+           util-linux
+           lvm2
+           tini
+           xfsprogs
+           xz))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
            go gotestsum pkg-config))
--
2.34.0


^ permalink raw reply related	[relevance 70%]

* [bug#52790] [PATCH v2 4/7] gnu: containerd: Switch to gexp arguments.
    2022-04-01  0:46 92% ` [bug#52790] [PATCH v2 2/7] gnu: containerd: Fix patch-paths build phase Pierre Langlois
  2022-04-01  0:46 90% ` [bug#52790] [PATCH v2 3/7] gnu: containerd: Update to 1.6.2 Pierre Langlois
@ 2022-04-01  0:46 80% ` Pierre Langlois
  2022-04-01  0:46 92% ` [bug#52790] [PATCH v2 5/7] gnu: docker: Fix mkfs.xfs reference Pierre Langlois
                   ` (2 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-04-01  0:46 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd)[arguments]: Rewrite as gexps.
Pass all flags via make-flags variable.  Switch to using
search-input-file.
---
 gnu/packages/docker.scm | 95 +++++++++++++++++++++--------------------
 1 file changed, 49 insertions(+), 46 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 7a7594f2b1..d2c022f552 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -29,6 +29,7 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages)
   #:use-module (guix packages)
   #:use-module (guix download)
+  #:use-module (guix gexp)
   #:use-module (guix git-download)
   #:use-module (guix build-system cmake)
   #:use-module (guix build-system gnu)
@@ -186,53 +187,55 @@ (define-public containerd
         (base32 "0fw62aya0gwxaa2kkcjkbifp8n0xmk1x0qzjahlsls6g0pmh5pkq"))))
     (build-system go-build-system)
     (arguments
-     (let ((make-flags (list (string-append "VERSION=" version)
-                             "REVISION=0")))
-       `(#:import-path "github.com/containerd/containerd"
-         #:phases
-         (modify-phases %standard-phases
-           (add-after 'unpack 'patch-paths
-             (lambda* (#:key inputs import-path outputs #:allow-other-keys)
-               (with-directory-excursion (string-append "src/" import-path)
-                 (substitute* "runtime/v1/linux/runtime.go"
-                   (("defaultRuntime[ \t]*=.*")
-                    (string-append "defaultRuntime = \""
-                                   (assoc-ref inputs "runc")
-                                   "/sbin/runc\"\n"))
-                   (("defaultShim[ \t]*=.*")
-                    (string-append "defaultShim = \""
-                                   (assoc-ref outputs "out")
-                                   "/bin/containerd-shim\"\n")))
-                 (substitute* "pkg/cri/config/config_unix.go"
-                   (("DefaultRuntimeName: \"runc\"")
-                    (string-append "DefaultRuntimeName: \""
-                                   (assoc-ref inputs "runc")
-                                   "/sbin/runc\"")))
-                 (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-                   (("DefaultCommand[ \t]*=.*")
-                    (string-append "DefaultCommand = \""
-                                   (assoc-ref inputs "runc")
-                                   "/sbin/runc\"\n")))
-                 (substitute* "vendor/github.com/containerd/continuity/testutil\
+     (let ((make-flags #~(list (string-append "VERSION=" #$version)
+                               (string-append "DESTDIR=" #$output)
+                               "PREFIX="
+                               "REVISION=0")))
+       (list
+        #:import-path "github.com/containerd/containerd"
+        #:phases
+        #~(modify-phases %standard-phases
+            (add-after 'unpack 'patch-paths
+              (lambda* (#:key inputs import-path outputs #:allow-other-keys)
+                (with-directory-excursion (string-append "src/" import-path)
+                  (substitute* "runtime/v1/linux/runtime.go"
+                    (("defaultRuntime[ \t]*=.*")
+                     (string-append "defaultRuntime = \""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\"\n"))
+                    (("defaultShim[ \t]*=.*")
+                     (string-append "defaultShim = \""
+                                    (assoc-ref outputs "out")
+                                    "/bin/containerd-shim\"\n")))
+                  (substitute* "pkg/cri/config/config_unix.go"
+                    (("DefaultRuntimeName: \"runc\"")
+                     (string-append "DefaultRuntimeName: \""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\"")))
+                  (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+                    (("DefaultCommand[ \t]*=.*")
+                     (string-append "DefaultCommand = \""
+                                    (search-input-file inputs "/sbin/runc")
+                                    "\"\n")))
+                  (substitute* "vendor/github.com/containerd/continuity/testutil\
 /loopback/loopback_linux.go"
-                   (("exec\\.Command\\(\"losetup\"")
-                    (string-append "exec.Command(\""
-                                   (assoc-ref inputs "util-linux")
-                                   "/sbin/losetup\"")))
-                 (substitute* "archive/compression/compression.go"
-                   (("exec\\.LookPath\\(\"unpigz\"\\)")
-                    (string-append "\"" (assoc-ref inputs "pigz")
-                                   "/bin/unpigz\", error(nil)"))))))
-           (replace 'build
-             (lambda* (#:key import-path #:allow-other-keys)
-               (with-directory-excursion (string-append "src/" import-path)
-                 (apply invoke "make" ',make-flags))))
-           (replace 'install
-             (lambda* (#:key import-path outputs #:allow-other-keys)
-               (with-directory-excursion (string-append "src/" import-path)
-                 (let* ((out (assoc-ref outputs "out")))
-                   (apply invoke "make" (string-append "DESTDIR=" out)
-                          "PREFIX=" "install" ',make-flags)))))))))
+                    (("exec\\.Command\\(\"losetup\"")
+                     (string-append "exec.Command(\""
+                                    (search-input-file inputs "/sbin/losetup")
+                                    "\"")))
+                  (substitute* "archive/compression/compression.go"
+                    (("exec\\.LookPath\\(\"unpigz\"\\)")
+                     (string-append "\""
+                                    (search-input-file inputs "/bin/unpigz")
+                                    "\", error(nil)"))))))
+            (replace 'build
+              (lambda* (#:key import-path #:allow-other-keys)
+                (with-directory-excursion (string-append "src/" import-path)
+                  (apply invoke "make" #$make-flags))))
+            (replace 'install
+              (lambda* (#:key import-path #:allow-other-keys)
+                (with-directory-excursion (string-append "src/" import-path)
+                  (apply invoke "make" "install" #$make-flags))))))))
     (inputs
      (list btrfs-progs libseccomp pigz runc util-linux))
     (native-inputs
--
2.34.0





^ permalink raw reply related	[relevance 80%]

* [bug#52790] [PATCH v2 6/7] gnu: docker: Update to 20.10.14.
                     ` (3 preceding siblings ...)
  2022-04-01  0:46 92% ` [bug#52790] [PATCH v2 5/7] gnu: docker: Fix mkfs.xfs reference Pierre Langlois
@ 2022-04-01  0:46 83% ` Pierre Langlois
  2022-04-01  1:11 70%   ` Pierre Langlois
  2022-04-01  0:46 51% ` [bug#52790] [PATCH v2 7/7] gnu: docker: Switch to gexp and new input style Pierre Langlois
  5 siblings, 1 reply; 149+ results
From: Pierre Langlois @ 2022-04-01  0:46 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (%docker-version): Update to 20.10.14.
(docker-libnetwork): Update commit according to vendor.conf.
(docker)[origin]: Remove docker-fix-tests.patch.
[arguments]: Adapt 'patch-paths phase, substitute "ip6tables" and
buildkit-qemu.  Remove trailing #t.
[native-inputs]: Replace go-1.14 by go.
(docker-cli)[arguments]: Set GO_LINKMODE to "dynamic".  Remove trailing #t.
* gnu/packages/networking.scm (go-sctp): Update commit according to
docker-libnetwork's vendor.conf.
* gnu/packages/patches/docker-fix-tests.patch: Delete.
* gnu/local.mk (dist_patch_DATA): Remove patch.
---
 gnu/local.mk                                |  1 -
 gnu/packages/docker.scm                     | 69 ++++++++-------------
 gnu/packages/networking.scm                 |  6 +-
 gnu/packages/patches/docker-fix-tests.patch | 28 ---------
 4 files changed, 29 insertions(+), 75 deletions(-)
 delete mode 100644 gnu/packages/patches/docker-fix-tests.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index a704161abc..d5b3d4bba3 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1007,7 +1007,6 @@ dist_patch_DATA =						\
   %D%/packages/patches/docbook-xsl-support-old-url.patch	\
   %D%/packages/patches/doc++-include-directives.patch		\
   %D%/packages/patches/doc++-segfault-fix.patch			\
-  %D%/packages/patches/docker-fix-tests.patch			\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/dstat-fix-crash-when-specifying-delay.patch	\
   %D%/packages/patches/dstat-skip-devices-without-io.patch	\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 0d721ead38..020c89bb11 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -54,7 +54,7 @@ (define-module (gnu packages docker)

 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "19.03.15")
+(define %docker-version "20.10.14")

 (define-public python-docker
   (package
@@ -252,13 +252,12 @@ (define-public containerd
 ;;; anyway, as it needs many dependencies that aren't being satisfied.
 (define docker-libnetwork
   ;; There are no recent release for libnetwork, so choose the last commit of
-  ;; the branch that Docker uses, as can be seen in the Docker source file
-  ;; 'hack/dockerfile/install/proxy.installer'. NOTE - It is important that
-  ;; this version is kept in sync with the version of Docker being used.
-  ;; This commit is the "bump_19.03" branch, as mentioned in Docker's vendor.conf.
-  (let ((commit "55e924b8a84231a065879156c0de95aefc5f5435")
+  ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
+  ;; source file.  NOTE - It is important that this version is kept in sync
+  ;; with the version of Docker being used.
+  (let ((commit "339b972b464ee3d401b5788b2af9e31d09d6b7da")
         (version (version-major+minor %docker-version))
-        (revision "1"))
+        (revision "2"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -271,7 +270,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "19syb3scwiykn44gqfaqrgqv8a0df4ps0ykf3za9xkjc5cyi99mp"))
+                  "0wx2hdwx56cbxiaky9kw2bi1prdfgzwr776lq1k0slw8kvn0cn32"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(begin
@@ -324,9 +323,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0419iha9zmwlhzhnbfxlsa13vgd04yifnsr8qqnj2ks5dxrcajl8"))
-       (patches
-        (search-patches "docker-fix-tests.patch"))))
+        (base32 "18nid42p1n20mg7spz0knh4izkk8qgjz9xi6v54czvy7aaj336i3"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -369,9 +366,10 @@ (define-public docker
                (("DefaultRuntimeBinary = .*")
                 (string-append "DefaultRuntimeBinary = \""
                                (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultRuntimeName = .*")
-                (string-append "DefaultRuntimeName = \""
+                               "/sbin/runc\"\n")))
+             (substitute* "daemon/runtime_unix.go"
+               (("defaultRuntimeName = .*")
+                (string-append "defaultRuntimeName = \""
                                (assoc-ref inputs "runc")
                                "/sbin/runc\"\n")))
              (substitute* "daemon/config/config.go"
@@ -400,16 +398,6 @@ (define-public docker
              (substitute* "pkg/archive/archive.go"
                (("string\\{\"xz")
                 (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "registry/resumable/resumablerequestreader_test.go"
-               (("I%27m%20not%20an%20url" all)
-                (string-append "\"" all "\"")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "vendor/gotest.tools/x/subtest/context.go"
-               (("func \\(tc \\*testcase\\) Cleanup\\(" all)
-                (string-append all "func()"))
-               (("tc\\.Cleanup\\(" all)
-                (string-append all "nil")))

              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
@@ -446,6 +434,7 @@ (define-public docker
                   ("blkid" "util-linux" "sbin/blkid")
                   ("unpigz" "pigz" "bin/unpigz")
                   ("iptables" "iptables" "sbin/iptables")
+                  ("ip6tables" "iptables" "sbin/ip6tables")
                   ("iptables-legacy" "iptables" "sbin/iptables")
                   ("ip" "iproute2" "sbin/ip"))

@@ -494,10 +483,10 @@ (define-public docker
                   "exec.Command")
                  ;; Search for ZFS in PATH.
                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
                  ;; Fail on other unsubstituted LookPaths.
                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))
-             #t))
+                 (("\\<LooxPath") "LookPath")))))
          (add-after 'patch-paths 'delete-failing-tests
            (lambda _
              ;; Needs internet access.
@@ -522,8 +511,7 @@ (define-public docker
              ;; This file uses /var.
              (delete-file "daemon/oci_linux_test.go")
              ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")
-             #t))
+             (delete-file "pkg/signal/signal_linux_test.go")))
          (replace 'configure
            (lambda _
              (setenv "DOCKER_BUILDTAGS" "seccomp")
@@ -536,8 +524,7 @@ (define-public docker
              ;; information, and the DWARF symbol table.
              (setenv "LDFLAGS" "-s -w")
              ;; Make build faster
-             (setenv "GOCACHE" "/tmp")
-             #t))
+             (setenv "GOCACHE" "/tmp")))
          (add-before 'build 'setup-go-environment
            (assoc-ref go:%standard-phases 'setup-go-environment))
          (replace 'build
@@ -559,8 +546,7 @@ (define-public docker
                                           "/.gopath/src/github.com/docker/docker"))
              (with-directory-excursion ".gopath/src/github.com/docker/docker"
                (invoke "hack/test/unit"))
-             (setenv "PWD" #f)
-             #t))
+             (setenv "PWD" #f)))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -568,8 +554,7 @@ (define-public docker
                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
                                             (getenv "VERSION"))
-                             out-bin)
-               #t)))
+                             out-bin))))
          (add-after 'install 'remove-go-references
            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
@@ -594,7 +579,7 @@ (define-public docker
        ("xz" ,xz)))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
-           go-1.14 gotestsum pkg-config))
+           go gotestsum pkg-config))
     (synopsis "Docker container component library, and daemon")
     (description "This package provides a framework to assemble specialized
 container systems.  It includes components for orchestration, image
@@ -615,7 +600,7 @@ (define-public docker-cli
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "1asapjj8brvbkd5irgdq82fx1ihrc14qaq30jxvjwflfm5yb7lv0"))))
+       (base32 "1nv6mzq9i9psgfbzx7hfx1qb6fjp649qg8y392z8z2kqbjl20g3q"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
@@ -635,11 +620,11 @@ (define-public docker-cli
              ;; Make build reproducible.
              (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
              (symlink "src/github.com/docker/cli/scripts" "./scripts")
-             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
-             #t))
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")))
          (replace 'build
            (lambda _
-             (invoke "./scripts/build/dynbinary")))
+             (setenv "GO_LINKMODE" "dynamic")
+             (invoke "./scripts/build/binary")))
          (replace 'check
            (lambda* (#:key make-flags tests? #:allow-other-keys)
              (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
@@ -648,8 +633,7 @@ (define-public docker-cli
                  (with-directory-excursion "src/github.com/docker/cli"
                    ;; TODO: Run test-e2e as well?
                    (apply invoke "make" "-f" "docker.Makefile" "test-unit"
-                          (or make-flags '())))
-                 #t)))
+                          (or make-flags '()))))))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -662,8 +646,7 @@ (define-public docker-cli
                                (string-append etc "/fish/completions"))
                  (install-file "zsh/_docker"
                                (string-append etc "/zsh/site-functions")))
-               (install-file "build/docker" out-bin)
-               #t))))))
+               (install-file "build/docker" out-bin)))))))
     (native-inputs
      (list go libltdl pkg-config))
     (synopsis "Command line interface to Docker")
diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index b45f2f79f2..54116e4f4c 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -1691,8 +1691,8 @@ (define-public go-netns
 (define-public go-sctp
   ;; docker-libnetwork-cmd-proxy requires this exact commit.
   ;; This commit is mentioned in docker-libnetwork-cmd-proxy's vendor.conf.
-  (let ((commit "6e2cb1366111dcf547c13531e3a263a067715847")
-        (revision "2"))
+  (let ((commit "f2269e66cdee387bd321445d5d300893449805be")
+        (revision "3"))
     (package
       (name "go-sctp")
       (version (git-version "0.0.0" revision commit))
@@ -1704,7 +1704,7 @@ (define-public go-sctp
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "1ba90fmpdwxa1ba4hrsjhi3gfy3pwmz7x8amw1p5dc9p5a7nnqrb"))))
+                  "04463rnn9y9psp11ac5di6wrwxlhymw5h9hfhhhnxqwla90ikp0g"))))
       (build-system go-build-system)
       (arguments
        `(#:tests? #f    ; Test suite is flakey.
diff --git a/gnu/packages/patches/docker-fix-tests.patch b/gnu/packages/patches/docker-fix-tests.patch
deleted file mode 100644
index 3e3e318e25..0000000000
--- a/gnu/packages/patches/docker-fix-tests.patch
+++ /dev/null
@@ -1,28 +0,0 @@
-Author: Danny Milosavljevic <dannym@scratchpost.org>
-The socket name ended up too long inside the container.
-Use a shorter one.
---- a/pkg/authorization/authz_unix_test.go	2019-01-10 01:55:02.997985947 +0100
-+++ b/pkg/authorization/authz_unix_test.go	2019-01-10 02:03:21.177439757 +0100
-@@ -24,7 +24,7 @@
- )
-
- const (
--	pluginAddress = "authz-test-plugin.sock"
-+	pluginAddress = "/tmp/authz-test-plugin.sock"
- )
-
- func TestAuthZRequestPluginError(t *testing.T) {
-@@ -263,12 +263,7 @@
-
- // createTestPlugin creates a new sample authorization plugin
- func createTestPlugin(t *testing.T) *authorizationPlugin {
--	pwd, err := os.Getwd()
--	if err != nil {
--		t.Fatal(err)
--	}
--
--	client, err := plugins.NewClient("unix:///"+path.Join(pwd, pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
-+	client, err := plugins.NewClient("unix:///"+path.Join("/", pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
- 	if err != nil {
- 		t.Fatalf("Failed to create client %v", err)
- 	}
--
2.34.0





^ permalink raw reply related	[relevance 83%]

* [bug#52790] [PATCH v2 7/7] gnu: docker: Switch to gexp and new input style.
                     ` (4 preceding siblings ...)
  2022-04-01  0:46 83% ` [bug#52790] [PATCH v2 6/7] gnu: docker: Update to 20.10.14 Pierre Langlois
@ 2022-04-01  0:46 51% ` Pierre Langlois
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-04-01  0:46 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (docker)[arguments]: Rewrite as gexps.  Switch
to using search-input-file.
[inputs]: Use new style inputs.
---
 gnu/packages/docker.scm | 483 ++++++++++++++++++++--------------------
 1 file changed, 241 insertions(+), 242 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 020c89bb11..b4095eb00f 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -326,257 +326,256 @@ (define-public docker
         (base32 "18nid42p1n20mg7spz0knh4izkk8qgjz9xi6v54czvy7aaj336i3"))))
     (build-system gnu-build-system)
     (arguments
-     `(#:modules
-       ((guix build gnu-build-system)
+     (list
+      #:modules
+      '((guix build gnu-build-system)
         ((guix build go-build-system) #:prefix go:)
         (guix build union)
         (guix build utils))
-       #:imported-modules
-       (,@%gnu-build-system-modules
+      #:imported-modules
+      `(,@%gnu-build-system-modules
         (guix build union)
         (guix build go-build-system))
-       #:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'patch-paths
-           (lambda* (#:key inputs #:allow-other-keys)
-             (substitute* "builder/builder-next/executor_unix.go"
-               (("CommandCandidates:.*runc.*")
-                (string-append "CommandCandidates: []string{\""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"},\n")))
-             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-               (("DefaultCommand = .*")
-                (string-append "DefaultCommand = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
-               (("defaultRuntime[ \t]*=.*")
-                (string-append "defaultRuntime = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("defaultShim[ \t]*=.*")
-                (string-append "defaultShim = \""
-                               (assoc-ref inputs "containerd")
-                               "/bin/containerd-shim\"\n")))
-             (substitute* "daemon/daemon_unix.go"
-               (("DefaultShimBinary = .*")
-                (string-append "DefaultShimBinary = \""
-                               (assoc-ref inputs "containerd")
-                               "/bin/containerd-shim\"\n"))
-               (("DefaultRuntimeBinary = .*")
-                (string-append "DefaultRuntimeBinary = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "daemon/runtime_unix.go"
-               (("defaultRuntimeName = .*")
-                (string-append "defaultRuntimeName = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
-             (substitute* "daemon/config/config.go"
-               (("StockRuntimeName = .*")
-                (string-append "StockRuntimeName = \""
-                               (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultInitBinary = .*")
-                (string-append "DefaultInitBinary = \""
-                               (assoc-ref inputs "tini")
-                               "/bin/tini-static\"\n")))
-             (substitute* "daemon/config/config_common_unix_test.go"
-               (("expectedInitPath: \"docker-init\"")
-                (string-append "expectedInitPath: \""
-                               (assoc-ref inputs "tini")
-                               "/bin/tini-static\"")))
-             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
-               (("var defaultCommandCandidates = .*")
-                (string-append "var defaultCommandCandidates = []string{\""
-                               (assoc-ref inputs "runc") "/sbin/runc\"}")))
-             (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
-               (("var userlandProxyCommandName = .*")
-                (string-append "var userlandProxyCommandName = \""
-                               (assoc-ref inputs "docker-proxy")
-                               "/bin/proxy\"\n")))
-             (substitute* "pkg/archive/archive.go"
-               (("string\\{\"xz")
-                (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'patch-paths
+            (lambda* (#:key inputs #:allow-other-keys)
+              (substitute* "builder/builder-next/executor_unix.go"
+                (("CommandCandidates:.*runc.*")
+                 (string-append "CommandCandidates: []string{\""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"},\n")))
+              (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+                (("DefaultCommand = .*")
+                 (string-append "DefaultCommand = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
+                (("defaultRuntime[ \t]*=.*")
+                 (string-append "defaultRuntime = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n"))
+                (("defaultShim[ \t]*=.*")
+                 (string-append "defaultShim = \""
+                                (search-input-file inputs "/bin/containerd-shim")
+                                "\"\n")))
+              (substitute* "daemon/daemon_unix.go"
+                (("DefaultShimBinary = .*")
+                 (string-append "DefaultShimBinary = \""
+                                (search-input-file inputs "/bin/containerd-shim")
+                                "\"\n"))
+                (("DefaultRuntimeBinary = .*")
+                 (string-append "DefaultRuntimeBinary = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "daemon/runtime_unix.go"
+                (("defaultRuntimeName = .*")
+                 (string-append "defaultRuntimeName = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n")))
+              (substitute* "daemon/config/config.go"
+                (("StockRuntimeName = .*")
+                 (string-append "StockRuntimeName = \""
+                                (search-input-file inputs "/sbin/runc")
+                                "\"\n"))
+                (("DefaultInitBinary = .*")
+                 (string-append "DefaultInitBinary = \""
+                                (search-input-file inputs "/bin/tini-static")
+                                "\"\n")))
+              (substitute* "daemon/config/config_common_unix_test.go"
+                (("expectedInitPath: \"docker-init\"")
+                 (string-append "expectedInitPath: \""
+                                (search-input-file inputs "/bin/tini-static")
+                                "\"")))
+              (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+                (("var defaultCommandCandidates = .*")
+                 (string-append "var defaultCommandCandidates = []string{\""
+                                (search-input-file inputs "/sbin/runc") "\"}")))
+              (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
+                (("var userlandProxyCommandName = .*")
+                 (string-append "var userlandProxyCommandName = \""
+                                (search-input-file inputs "/bin/proxy")
+                                "\"\n")))
+              (substitute* "pkg/archive/archive.go"
+                (("string\\{\"xz")
+                 (string-append "string{\"" (search-input-file inputs "/bin/xz"))))

-             (let ((source-files (filter (lambda (name)
-                                           (not (string-contains name "test")))
-                                         (find-files "." "\\.go$"))))
-               (let-syntax ((substitute-LookPath*
-                             (syntax-rules ()
-                               ((_ (source-text package relative-path) ...)
-                                (substitute* source-files
-                                  (((string-append "\\<exec\\.LookPath\\(\""
-                                                   source-text
-                                                   "\")"))
-                                   (string-append "\""
-                                                  (assoc-ref inputs package)
-                                                  "/" relative-path
-                                                  "\", error(nil)")) ...))))
-                            (substitute-Command*
-                             (syntax-rules ()
-                               ((_ (source-text package relative-path) ...)
-                                (substitute* source-files
-                                  (((string-append "\\<(re)?exec\\.Command\\(\""
-                                                   source-text
-                                                   "\"") _ re?)
-                                   (string-append (if re? re? "")
-                                                  "exec.Command(\""
-                                                  (assoc-ref inputs package)
-                                                  "/" relative-path
-                                                  "\"")) ...)))))
-                 (substitute-LookPath*
-                  ("containerd" "containerd" "bin/containerd")
-                  ("ps" "procps" "bin/ps")
-                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                  ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
-                  ("pvdisplay" "lvm2" "sbin/pvdisplay")
-                  ("blkid" "util-linux" "sbin/blkid")
-                  ("unpigz" "pigz" "bin/unpigz")
-                  ("iptables" "iptables" "sbin/iptables")
-                  ("ip6tables" "iptables" "sbin/ip6tables")
-                  ("iptables-legacy" "iptables" "sbin/iptables")
-                  ("ip" "iproute2" "sbin/ip"))
+              (let ((source-files (filter (lambda (name)
+                                            (not (string-contains name "test")))
+                                          (find-files "." "\\.go$"))))
+                (let-syntax ((substitute-LookPath*
+                              (syntax-rules ()
+                                ((_ (source-text path) ...)
+                                 (substitute* source-files
+                                   (((string-append "\\<exec\\.LookPath\\(\""
+                                                    source-text
+                                                    "\")"))
+                                    (string-append "\""
+                                                   (search-input-file inputs path)
+                                                   "\", error(nil)")) ...))))
+                             (substitute-Command*
+                              (syntax-rules ()
+                                ((_ (source-text path) ...)
+                                 (substitute* source-files
+                                   (((string-append "\\<(re)?exec\\.Command\\(\""
+                                                    source-text
+                                                    "\"") _ re?)
+                                    (string-append (if re? re? "")
+                                                   "exec.Command(\""
+                                                   (search-input-file inputs path)
+                                                   "\"")) ...)))))
+                  (substitute-LookPath*
+                   ("containerd" "/bin/containerd")
+                   ("ps" "/bin/ps")
+                   ("mkfs.xfs" "/sbin/mkfs.xfs")
+                   ("lvmdiskscan" "/sbin/lvmdiskscan")
+                   ("pvdisplay" "/sbin/pvdisplay")
+                   ("blkid" "/sbin/blkid")
+                   ("unpigz" "/bin/unpigz")
+                   ("iptables" "/sbin/iptables")
+                   ("ip6tables" "/sbin/ip6tables")
+                   ("iptables-legacy" "/sbin/iptables")
+                   ("ip" "/sbin/ip"))

-                 (substitute-Command*
-                  ("modprobe" "kmod" "bin/modprobe")
-                  ("pvcreate" "lvm2" "sbin/pvcreate")
-                  ("vgcreate" "lvm2" "sbin/vgcreate")
-                  ("lvcreate" "lvm2" "sbin/lvcreate")
-                  ("lvconvert" "lvm2" "sbin/lvconvert")
-                  ("lvchange" "lvm2" "sbin/lvchange")
-                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                  ("xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
-                  ("mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
-                  ("tune2fs" "e2fsprogs" "sbin/tune2fs")
-                  ("blkid" "util-linux" "sbin/blkid")
-                  ("resize2fs" "e2fsprogs" "sbin/resize2fs")
-                  ("ps" "procps" "bin/ps")
-                  ("losetup" "util-linux" "sbin/losetup")
-                  ("uname" "coreutils" "bin/uname")
-                  ("dbus-launch" "dbus" "bin/dbus-launch")
-                  ("git" "git" "bin/git")))
-               ;; docker-mountfrom ??
-               ;; docker
-               ;; docker-untar ??
-               ;; docker-applyLayer ??
-               ;; /usr/bin/uname
-               ;; grep
-               ;; apparmor_parser
+                  (substitute-Command*
+                   ("modprobe" "/bin/modprobe")
+                   ("pvcreate" "/sbin/pvcreate")
+                   ("vgcreate" "/sbin/vgcreate")
+                   ("lvcreate" "/sbin/lvcreate")
+                   ("lvconvert" "/sbin/lvconvert")
+                   ("lvchange" "/sbin/lvchange")
+                   ("mkfs.xfs" "/sbin/mkfs.xfs")
+                   ("xfs_growfs" "/sbin/xfs_growfs")
+                   ("mkfs.ext4" "/sbin/mkfs.ext4")
+                   ("tune2fs" "/sbin/tune2fs")
+                   ("blkid" "/sbin/blkid")
+                   ("resize2fs" "/sbin/resize2fs")
+                   ("ps" "/bin/ps")
+                   ("losetup" "/sbin/losetup")
+                   ("uname" "/bin/uname")
+                   ("dbus-launch" "/bin/dbus-launch")
+                   ("git" "/bin/git")))
+                ;; docker-mountfrom ??
+                ;; docker
+                ;; docker-untar ??
+                ;; docker-applyLayer ??
+                ;; /usr/bin/uname
+                ;; grep
+                ;; apparmor_parser

-               ;; Make compilation fail when, in future versions, Docker
-               ;; invokes other programs we don't know about and thus don't
-               ;; substitute.
-               (substitute* source-files
-                 ;; Search for Java in PATH.
-                 (("\\<exec\\.Command\\(\"java\"")
-                  "xxec.Command(\"java\"")
-                 ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                 (("\\<exec\\.Command\\(\"auplink\"")
-                  "xxec.Command(\"auplink\"")
-                 ;; Fail on other unsubstituted commands.
-                 (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                   _ executable)
-                  (string-append "exec.Guix_doesnt_want_Command(\""
-                                 executable "\""))
-                 (("\\<xxec\\.Command")
-                  "exec.Command")
-                 ;; Search for ZFS in PATH.
-                 (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
-                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
-                 ;; Fail on other unsubstituted LookPaths.
-                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))))
-         (add-after 'patch-paths 'delete-failing-tests
-           (lambda _
-             ;; Needs internet access.
-             (delete-file "builder/remotecontext/git/gitutils_test.go")
-             ;; Permission denied.
-             (delete-file "daemon/graphdriver/devmapper/devmapper_test.go")
-             ;; Operation not permitted (idtools.MkdirAllAndChown).
-             (delete-file "daemon/graphdriver/vfs/vfs_test.go")
-             ;; Timeouts after 5 min.
-             (delete-file "plugin/manager_linux_test.go")
-             ;; Operation not permitted.
-             (delete-file "daemon/graphdriver/aufs/aufs_test.go")
-             (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
-             (delete-file "daemon/graphdriver/overlay/overlay_test.go")
-             (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
-             (delete-file "pkg/chrootarchive/archive_unix_test.go")
-             (delete-file "daemon/container_unix_test.go")
-             ;; This file uses cgroups and /proc.
-             (delete-file "pkg/sysinfo/sysinfo_linux_test.go")
-             ;; This file uses cgroups.
-             (delete-file "runconfig/config_test.go")
-             ;; This file uses /var.
-             (delete-file "daemon/oci_linux_test.go")
-             ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")))
-         (replace 'configure
-           (lambda _
-             (setenv "DOCKER_BUILDTAGS" "seccomp")
-             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
-             (setenv "VERSION" (string-append ,%docker-version "-ce"))
-             ;; Automatically use bundled dependencies.
-             ;; TODO: Unbundle - see file "vendor.conf".
-             (setenv "AUTO_GOPATH" "1")
-             ;; Respectively, strip the symbol table and debug
-             ;; information, and the DWARF symbol table.
-             (setenv "LDFLAGS" "-s -w")
-             ;; Make build faster
-             (setenv "GOCACHE" "/tmp")))
-         (add-before 'build 'setup-go-environment
-           (assoc-ref go:%standard-phases 'setup-go-environment))
-         (replace 'build
-           (lambda _
-             ;; Our LD doesn't like the statically linked relocatable things
-             ;; that go produces, so install the dynamic version of
-             ;; dockerd instead.
-             (invoke "hack/make.sh" "dynbinary")))
-         (replace 'check
-           (lambda _
-             ;; The build process generated a file because the environment
-             ;; variable "AUTO_GOPATH" was set.  Use it.
-             (setenv "GOPATH" (string-append (getcwd) "/.gopath"))
-             ;; ".gopath/src/github.com/docker/docker" is a link to the current
-             ;; directory and chdir would canonicalize to that.
-             ;; But go needs to have the uncanonicalized directory name, so
-             ;; store that.
-             (setenv "PWD" (string-append (getcwd)
-                                          "/.gopath/src/github.com/docker/docker"))
-             (with-directory-excursion ".gopath/src/github.com/docker/docker"
-               (invoke "hack/test/unit"))
-             (setenv "PWD" #f)))
-         (replace 'install
-           (lambda* (#:key outputs #:allow-other-keys)
-             (let* ((out (assoc-ref outputs "out"))
-                    (out-bin (string-append out "/bin")))
-               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
-               (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
-                                            (getenv "VERSION"))
-                             out-bin))))
-         (add-after 'install 'remove-go-references
-           (assoc-ref go:%standard-phases 'remove-go-references)))))
+                ;; Make compilation fail when, in future versions, Docker
+                ;; invokes other programs we don't know about and thus don't
+                ;; substitute.
+                (substitute* source-files
+                  ;; Search for Java in PATH.
+                  (("\\<exec\\.Command\\(\"java\"")
+                   "xxec.Command(\"java\"")
+                  ;; Search for AUFS in PATH (mainline Linux doesn't support it).
+                  (("\\<exec\\.Command\\(\"auplink\"")
+                   "xxec.Command(\"auplink\"")
+                  ;; Fail on other unsubstituted commands.
+                  (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
+                    _ executable)
+                   (string-append "exec.Guix_doesnt_want_Command(\""
+                                  executable "\""))
+                  (("\\<xxec\\.Command")
+                   "exec.Command")
+                  ;; Search for ZFS in PATH.
+                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                  (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
+                  ;; Fail on other unsubstituted LookPaths.
+                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
+                  (("\\<LooxPath") "LookPath")))))
+          (add-after 'patch-paths 'delete-failing-tests
+            (lambda _
+              ;; Needs internet access.
+              (delete-file "builder/remotecontext/git/gitutils_test.go")
+              ;; Permission denied.
+              (delete-file "daemon/graphdriver/devmapper/devmapper_test.go")
+              ;; Operation not permitted (idtools.MkdirAllAndChown).
+              (delete-file "daemon/graphdriver/vfs/vfs_test.go")
+              ;; Timeouts after 5 min.
+              (delete-file "plugin/manager_linux_test.go")
+              ;; Operation not permitted.
+              (delete-file "daemon/graphdriver/aufs/aufs_test.go")
+              (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
+              (delete-file "daemon/graphdriver/overlay/overlay_test.go")
+              (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
+              (delete-file "pkg/chrootarchive/archive_unix_test.go")
+              (delete-file "daemon/container_unix_test.go")
+              ;; This file uses cgroups and /proc.
+              (delete-file "pkg/sysinfo/sysinfo_linux_test.go")
+              ;; This file uses cgroups.
+              (delete-file "runconfig/config_test.go")
+              ;; This file uses /var.
+              (delete-file "daemon/oci_linux_test.go")
+              ;; Signal tests fail in bizarre ways
+              (delete-file "pkg/signal/signal_linux_test.go")))
+          (replace 'configure
+            (lambda _
+              (setenv "DOCKER_BUILDTAGS" "seccomp")
+              (setenv "DOCKER_GITCOMMIT" (string-append "v" #$%docker-version))
+              (setenv "VERSION" (string-append #$%docker-version "-ce"))
+              ;; Automatically use bundled dependencies.
+              ;; TODO: Unbundle - see file "vendor.conf".
+              (setenv "AUTO_GOPATH" "1")
+              ;; Respectively, strip the symbol table and debug
+              ;; information, and the DWARF symbol table.
+              (setenv "LDFLAGS" "-s -w")
+              ;; Make build faster
+              (setenv "GOCACHE" "/tmp")))
+          (add-before 'build 'setup-go-environment
+            (assoc-ref go:%standard-phases 'setup-go-environment))
+          (replace 'build
+            (lambda _
+              ;; Our LD doesn't like the statically linked relocatable things
+              ;; that go produces, so install the dynamic version of
+              ;; dockerd instead.
+              (invoke "hack/make.sh" "dynbinary")))
+          (replace 'check
+            (lambda _
+              ;; The build process generated a file because the environment
+              ;; variable "AUTO_GOPATH" was set.  Use it.
+              (setenv "GOPATH" (string-append (getcwd) "/.gopath"))
+              ;; ".gopath/src/github.com/docker/docker" is a link to the current
+              ;; directory and chdir would canonicalize to that.
+              ;; But go needs to have the uncanonicalized directory name, so
+              ;; store that.
+              (setenv "PWD" (string-append (getcwd)
+                                           "/.gopath/src/github.com/docker/docker"))
+              (with-directory-excursion ".gopath/src/github.com/docker/docker"
+                (invoke "hack/test/unit"))
+              (setenv "PWD" #f)))
+          (replace 'install
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((out (assoc-ref outputs "out"))
+                     (out-bin (string-append out "/bin")))
+                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
+                                             (getenv "VERSION"))
+                              out-bin))))
+          (add-after 'install 'remove-go-references
+            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
-     `(("btrfs-progs" ,btrfs-progs)
-       ("containerd" ,containerd)       ; for containerd-shim
-       ("coreutils" ,coreutils)
-       ("dbus" ,dbus)
-       ("docker-proxy" ,docker-libnetwork-cmd-proxy)
-       ("e2fsprogs" ,e2fsprogs)
-       ("git" ,git)
-       ("iproute2" ,iproute)
-       ("iptables" ,iptables)
-       ("kmod" ,kmod)
-       ("libseccomp" ,libseccomp)
-       ("pigz" ,pigz)
-       ("procps" ,procps)
-       ("runc" ,runc)
-       ("util-linux" ,util-linux)
-       ("lvm2" ,lvm2)
-       ("tini" ,tini)
-       ("xfsprogs" ,xfsprogs)
-       ("xz" ,xz)))
+     (list btrfs-progs
+           containerd       ; for containerd-shim
+           coreutils
+           dbus
+           docker-libnetwork-cmd-proxy
+           e2fsprogs
+           git
+           iproute
+           iptables
+           kmod
+           libseccomp
+           pigz
+           procps
+           runc
+           util-linux
+           lvm2
+           tini
+           xfsprogs
+           xz))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
            go gotestsum pkg-config))
--
2.34.0





^ permalink raw reply related	[relevance 51%]

* [bug#52790] [PATCH v2 5/7] gnu: docker: Fix mkfs.xfs reference.
                     ` (2 preceding siblings ...)
  2022-04-01  0:46 80% ` [bug#52790] [PATCH v2 4/7] gnu: containerd: Switch to gexp arguments Pierre Langlois
@ 2022-04-01  0:46 92% ` Pierre Langlois
  2022-04-01  0:46 83% ` [bug#52790] [PATCH v2 6/7] gnu: docker: Update to 20.10.14 Pierre Langlois
  2022-04-01  0:46 51% ` [bug#52790] [PATCH v2 7/7] gnu: docker: Switch to gexp and new input style Pierre Langlois
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-04-01  0:46 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (docker)[arguments]: Refer to sbin/mkfs.xfs
instead of bin/mkfs.xfs.
---
 gnu/packages/docker.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index d2c022f552..0d721ead38 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -440,7 +440,7 @@ (define-public docker
                  (substitute-LookPath*
                   ("containerd" "containerd" "bin/containerd")
                   ("ps" "procps" "bin/ps")
-                  ("mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
+                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
                   ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
                   ("pvdisplay" "lvm2" "sbin/pvdisplay")
                   ("blkid" "util-linux" "sbin/blkid")
--
2.34.0





^ permalink raw reply related	[relevance 92%]

* [bug#52790] [PATCH v2 2/7] gnu: containerd: Fix patch-paths build phase.
  @ 2022-04-01  0:46 92% ` Pierre Langlois
  2022-04-01  0:46 90% ` [bug#52790] [PATCH v2 3/7] gnu: containerd: Update to 1.6.2 Pierre Langlois
                   ` (4 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-04-01  0:46 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd)[arguments]: Add 'patch-paths
phases after 'unpack because 'chdir doesn't exist.
---
 gnu/packages/docker.scm | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3f52f4f8db..b76db22d58 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -190,7 +191,7 @@ (define-public containerd
        `(#:import-path "github.com/containerd/containerd"
          #:phases
          (modify-phases %standard-phases
-           (add-after 'chdir 'patch-paths
+           (add-after 'unpack 'patch-paths
              (lambda* (#:key inputs import-path outputs #:allow-other-keys)
                (with-directory-excursion (string-append "src/" import-path)
                  (substitute* "runtime/v1/linux/runtime.go"
--
2.34.0





^ permalink raw reply related	[relevance 92%]

* [bug#52790] [PATCH v2 3/7] gnu: containerd: Update to 1.6.2.
    2022-04-01  0:46 92% ` [bug#52790] [PATCH v2 2/7] gnu: containerd: Fix patch-paths build phase Pierre Langlois
@ 2022-04-01  0:46 90% ` Pierre Langlois
  2022-04-01  0:46 80% ` [bug#52790] [PATCH v2 4/7] gnu: containerd: Switch to gexp arguments Pierre Langlois
                   ` (3 subsequent siblings)
  5 siblings, 0 replies; 149+ results
From: Pierre Langlois @ 2022-04-01  0:46 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd): Update to 1.6.2.
[arguments]: Substitute runc binary for "pkg/cri/config/config_unix.go".  Set
PREFIX to empty string, as the install directory is $DESTDIR/$PREFIX.
---
 gnu/packages/docker.scm | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index b76db22d58..7a7594f2b1 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -174,7 +174,7 @@ (define-public python-docker-pycreds
 (define-public containerd
   (package
     (name "containerd")
-    (version "1.4.4")
+    (version "1.6.2")
     (source
      (origin
        (method git-fetch)
@@ -183,7 +183,7 @@ (define-public containerd
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0qjbfj1dw6pykxhh8zahcxlgpyjzgnrngk5vjaf34akwyan8nrxb"))))
+        (base32 "0fw62aya0gwxaa2kkcjkbifp8n0xmk1x0qzjahlsls6g0pmh5pkq"))))
     (build-system go-build-system)
     (arguments
      (let ((make-flags (list (string-append "VERSION=" version)
@@ -203,6 +203,11 @@ (define-public containerd
                     (string-append "defaultShim = \""
                                    (assoc-ref outputs "out")
                                    "/bin/containerd-shim\"\n")))
+                 (substitute* "pkg/cri/config/config_unix.go"
+                   (("DefaultRuntimeName: \"runc\"")
+                    (string-append "DefaultRuntimeName: \""
+                                   (assoc-ref inputs "runc")
+                                   "/sbin/runc\"")))
                  (substitute* "vendor/github.com/containerd/go-runc/runc.go"
                    (("DefaultCommand[ \t]*=.*")
                     (string-append "DefaultCommand = \""
@@ -226,8 +231,8 @@ (define-public containerd
              (lambda* (#:key import-path outputs #:allow-other-keys)
                (with-directory-excursion (string-append "src/" import-path)
                  (let* ((out (assoc-ref outputs "out")))
-                   (apply invoke "make" (string-append "DESTDIR=" out) "install"
-                          ',make-flags)))))))))
+                   (apply invoke "make" (string-append "DESTDIR=" out)
+                          "PREFIX=" "install" ',make-flags)))))))))
     (inputs
      (list btrfs-progs libseccomp pigz runc util-linux))
     (native-inputs
--
2.34.0





^ permalink raw reply related	[relevance 90%]

* [bug#52790] [PATCH 2/4] gnu: containerd: Update to 1.5.8.
  2021-12-25 14:40 92% ` [bug#52790] [PATCH 1/4] gnu: containerd: Fix patch-paths build phase Pierre Langlois
@ 2021-12-25 14:40 92%   ` Pierre Langlois
  2021-12-25 14:40 83%   ` [bug#52790] [PATCH 4/4] gnu: docker: Update to 20.10.11 Pierre Langlois
  1 sibling, 0 replies; 149+ results
From: Pierre Langlois @ 2021-12-25 14:40 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd): Update to 1.5.8.
[arguments]: Substitute runc binary for "pkg/cri/config/config_unix.go".
---
 gnu/packages/docker.scm | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 47e4fcd2dc..062229b3b4 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -173,7 +173,7 @@ (define-public python-docker-pycreds
 (define-public containerd
   (package
     (name "containerd")
-    (version "1.4.4")
+    (version "1.5.8")
     (source
      (origin
        (method git-fetch)
@@ -182,7 +182,7 @@ (define-public containerd
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0qjbfj1dw6pykxhh8zahcxlgpyjzgnrngk5vjaf34akwyan8nrxb"))))
+        (base32 "18lzmpbhbk1kq1nwdp6zcxb577kp425l2ikcmb45jcwgqdwzla6l"))))
     (build-system go-build-system)
     (arguments
      (let ((make-flags (list (string-append "VERSION=" version)
@@ -202,6 +202,11 @@ (define-public containerd
                     (string-append "defaultShim = \""
                                    (assoc-ref outputs "out")
                                    "/bin/containerd-shim\"\n")))
+                 (substitute* "pkg/cri/config/config_unix.go"
+                   (("DefaultRuntimeName: \"runc\"")
+                    (string-append "DefaultRuntimeName: \""
+                                   (assoc-ref inputs "runc")
+                                   "/sbin/runc\"")))
                  (substitute* "vendor/github.com/containerd/go-runc/runc.go"
                    (("DefaultCommand[ \t]*=.*")
                     (string-append "DefaultCommand = \""
--
2.34.0





^ permalink raw reply related	[relevance 92%]

* [bug#52790] [PATCH 4/4] gnu: docker: Update to 20.10.11.
  2021-12-25 14:40 92% ` [bug#52790] [PATCH 1/4] gnu: containerd: Fix patch-paths build phase Pierre Langlois
  2021-12-25 14:40 92%   ` [bug#52790] [PATCH 2/4] gnu: containerd: Update to 1.5.8 Pierre Langlois
@ 2021-12-25 14:40 83%   ` Pierre Langlois
  1 sibling, 0 replies; 149+ results
From: Pierre Langlois @ 2021-12-25 14:40 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (%docker-version): Update to 20.10.11.
(docker-libnetwork): Update commit according to vendor.conf.
(docker)[origin]: Remove docker-fix-tests.patch.
[arguments]: Adapt 'patch-paths phase, substitute "ip6tables" and
buildkit-qemu.  Remove trailing #t.
[native-inputs]: Replace go-1.14 by go.
(docker-cli)[arguments]: Set GO_LINKMODE to "dynamic".  Remove trailing #t.
* gnu/packages/networking.scm (go-sctp): Update commit according to
docker-libnetwork's vendor.conf.
* gnu/packages/patches/docker-fix-tests.patch: Delete.
* gnu/local.mk (dist_patch_DATA): Remove patch.
---
 gnu/local.mk                                |  1 -
 gnu/packages/docker.scm                     | 69 ++++++++-------------
 gnu/packages/networking.scm                 |  6 +-
 gnu/packages/patches/docker-fix-tests.patch | 28 ---------
 4 files changed, 29 insertions(+), 75 deletions(-)
 delete mode 100644 gnu/packages/patches/docker-fix-tests.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index aa0117a3f5..f2dbd2330a 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -996,7 +996,6 @@ dist_patch_DATA =						\
   %D%/packages/patches/docbook-xsl-support-old-url.patch	\
   %D%/packages/patches/doc++-include-directives.patch		\
   %D%/packages/patches/doc++-segfault-fix.patch			\
-  %D%/packages/patches/docker-fix-tests.patch			\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/dstat-fix-crash-when-specifying-delay.patch	\
   %D%/packages/patches/dstat-skip-devices-without-io.patch	\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 062229b3b4..1d09184e4d 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -52,7 +52,7 @@ (define-module (gnu packages docker)

 ;; Note - when changing Docker versions it is important to update the versions
 ;; of several associated packages (docker-libnetwork and go-sctp).
-(define %docker-version "19.03.15")
+(define %docker-version "20.10.11")

 (define-public python-docker
   (package
@@ -248,13 +248,12 @@ (define-public containerd
 ;;; anyway, as it needs many dependencies that aren't being satisfied.
 (define docker-libnetwork
   ;; There are no recent release for libnetwork, so choose the last commit of
-  ;; the branch that Docker uses, as can be seen in the Docker source file
-  ;; 'hack/dockerfile/install/proxy.installer'. NOTE - It is important that
-  ;; this version is kept in sync with the version of Docker being used.
-  ;; This commit is the "bump_19.03" branch, as mentioned in Docker's vendor.conf.
-  (let ((commit "55e924b8a84231a065879156c0de95aefc5f5435")
+  ;; the branch that Docker uses, as can be seen in the 'vendor.conf' Docker
+  ;; source file.  NOTE - It is important that this version is kept in sync
+  ;; with the version of Docker being used.
+  (let ((commit "64b7a4574d1426139437d20e81c0b6d391130ec8")
         (version (version-major+minor %docker-version))
-        (revision "1"))
+        (revision "2"))
     (package
       (name "docker-libnetwork")
       (version (git-version version revision commit))
@@ -267,7 +266,7 @@ (define docker-libnetwork
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "19syb3scwiykn44gqfaqrgqv8a0df4ps0ykf3za9xkjc5cyi99mp"))
+                  "1sxn10kn5b6wv06im3y2as7pjsz51zyv3cd007blxjl9wivxzzxs"))
                 ;; Delete bundled ("vendored") free software source code.
                 (modules '((guix build utils)))
                 (snippet '(begin
@@ -320,9 +319,7 @@ (define-public docker
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0419iha9zmwlhzhnbfxlsa13vgd04yifnsr8qqnj2ks5dxrcajl8"))
-       (patches
-        (search-patches "docker-fix-tests.patch"))))
+        (base32 "1h1r66j57l073iba6hwrhcz779vaym68l1gfycdiw2d2gglfrdgr"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -365,9 +362,10 @@ (define-public docker
                (("DefaultRuntimeBinary = .*")
                 (string-append "DefaultRuntimeBinary = \""
                                (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n"))
-               (("DefaultRuntimeName = .*")
-                (string-append "DefaultRuntimeName = \""
+                               "/sbin/runc\"\n")))
+             (substitute* "daemon/runtime_unix.go"
+               (("defaultRuntimeName = .*")
+                (string-append "defaultRuntimeName = \""
                                (assoc-ref inputs "runc")
                                "/sbin/runc\"\n")))
              (substitute* "daemon/config/config.go"
@@ -396,16 +394,6 @@ (define-public docker
              (substitute* "pkg/archive/archive.go"
                (("string\\{\"xz")
                 (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "registry/resumable/resumablerequestreader_test.go"
-               (("I%27m%20not%20an%20url" all)
-                (string-append "\"" all "\"")))
-             ;; TODO: Remove when Docker proper uses v1.14.x to build
-             (substitute* "vendor/gotest.tools/x/subtest/context.go"
-               (("func \\(tc \\*testcase\\) Cleanup\\(" all)
-                (string-append all "func()"))
-               (("tc\\.Cleanup\\(" all)
-                (string-append all "nil")))

              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
@@ -442,6 +430,7 @@ (define-public docker
                   ("blkid" "util-linux" "sbin/blkid")
                   ("unpigz" "pigz" "bin/unpigz")
                   ("iptables" "iptables" "sbin/iptables")
+                  ("ip6tables" "iptables" "sbin/ip6tables")
                   ("iptables-legacy" "iptables" "sbin/iptables")
                   ("ip" "iproute2" "sbin/ip"))

@@ -490,10 +479,10 @@ (define-public docker
                   "exec.Command")
                  ;; Search for ZFS in PATH.
                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                 (("\\<LookPath\\(\"buildkit-qemu-\"") "LooxPath(\"buildkit-qemu-\"")
                  ;; Fail on other unsubstituted LookPaths.
                  (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
-                 (("\\<LooxPath") "LookPath")))
-             #t))
+                 (("\\<LooxPath") "LookPath")))))
          (add-after 'patch-paths 'delete-failing-tests
            (lambda _
              ;; Needs internet access.
@@ -518,8 +507,7 @@ (define-public docker
              ;; This file uses /var.
              (delete-file "daemon/oci_linux_test.go")
              ;; Signal tests fail in bizarre ways
-             (delete-file "pkg/signal/signal_linux_test.go")
-             #t))
+             (delete-file "pkg/signal/signal_linux_test.go")))
          (replace 'configure
            (lambda _
              (setenv "DOCKER_BUILDTAGS" "seccomp")
@@ -532,8 +520,7 @@ (define-public docker
              ;; information, and the DWARF symbol table.
              (setenv "LDFLAGS" "-s -w")
              ;; Make build faster
-             (setenv "GOCACHE" "/tmp")
-             #t))
+             (setenv "GOCACHE" "/tmp")))
          (add-before 'build 'setup-go-environment
            (assoc-ref go:%standard-phases 'setup-go-environment))
          (replace 'build
@@ -555,8 +542,7 @@ (define-public docker
                                           "/.gopath/src/github.com/docker/docker"))
              (with-directory-excursion ".gopath/src/github.com/docker/docker"
                (invoke "hack/test/unit"))
-             (setenv "PWD" #f)
-             #t))
+             (setenv "PWD" #f)))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -564,8 +550,7 @@ (define-public docker
                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
                                             (getenv "VERSION"))
-                             out-bin)
-               #t)))
+                             out-bin))))
          (add-after 'install 'remove-go-references
            (assoc-ref go:%standard-phases 'remove-go-references)))))
     (inputs
@@ -590,7 +575,7 @@ (define-public docker
        ("xz" ,xz)))
     (native-inputs
      (list eudev ; TODO: Should be propagated by lvm2 (.pc -> .pc)
-           go-1.14 gotestsum pkg-config))
+           go gotestsum pkg-config))
     (synopsis "Docker container component library, and daemon")
     (description "This package provides a framework to assemble specialized
 container systems.  It includes components for orchestration, image
@@ -611,7 +596,7 @@ (define-public docker-cli
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "1asapjj8brvbkd5irgdq82fx1ihrc14qaq30jxvjwflfm5yb7lv0"))))
+       (base32 "0dmmxn9ahyq2yq935fvp1b6ka6s43ih9nh6wwx8v6rjg7y35rb1n"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
@@ -631,11 +616,11 @@ (define-public docker-cli
              ;; Make build reproducible.
              (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
              (symlink "src/github.com/docker/cli/scripts" "./scripts")
-             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
-             #t))
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")))
          (replace 'build
            (lambda _
-             (invoke "./scripts/build/dynbinary")))
+             (setenv "GO_LINKMODE" "dynamic")
+             (invoke "./scripts/build/binary")))
          (replace 'check
            (lambda* (#:key make-flags tests? #:allow-other-keys)
              (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
@@ -644,8 +629,7 @@ (define-public docker-cli
                  (with-directory-excursion "src/github.com/docker/cli"
                    ;; TODO: Run test-e2e as well?
                    (apply invoke "make" "-f" "docker.Makefile" "test-unit"
-                          (or make-flags '())))
-                 #t)))
+                          (or make-flags '()))))))
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let* ((out (assoc-ref outputs "out"))
@@ -658,8 +642,7 @@ (define-public docker-cli
                                (string-append etc "/fish/completions"))
                  (install-file "zsh/_docker"
                                (string-append etc "/zsh/site-functions")))
-               (install-file "build/docker" out-bin)
-               #t))))))
+               (install-file "build/docker" out-bin)))))))
     (native-inputs
      (list go libltdl pkg-config))
     (synopsis "Command line interface to Docker")
diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 4923ec91e9..cc9864ef19 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -1655,8 +1655,8 @@ (define-public go-netns
 (define-public go-sctp
   ;; docker-libnetwork-cmd-proxy requires this exact commit.
   ;; This commit is mentioned in docker-libnetwork-cmd-proxy's vendor.conf.
-  (let ((commit "6e2cb1366111dcf547c13531e3a263a067715847")
-        (revision "2"))
+  (let ((commit "f2269e66cdee387bd321445d5d300893449805be")
+        (revision "3"))
     (package
       (name "go-sctp")
       (version (git-version "0.0.0" revision commit))
@@ -1668,7 +1668,7 @@ (define-public go-sctp
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "1ba90fmpdwxa1ba4hrsjhi3gfy3pwmz7x8amw1p5dc9p5a7nnqrb"))))
+                  "04463rnn9y9psp11ac5di6wrwxlhymw5h9hfhhhnxqwla90ikp0g"))))
       (build-system go-build-system)
       (arguments
        `(#:tests? #f    ; Test suite is flakey.
diff --git a/gnu/packages/patches/docker-fix-tests.patch b/gnu/packages/patches/docker-fix-tests.patch
deleted file mode 100644
index 3e3e318e25..0000000000
--- a/gnu/packages/patches/docker-fix-tests.patch
+++ /dev/null
@@ -1,28 +0,0 @@
-Author: Danny Milosavljevic <dannym@scratchpost.org>
-The socket name ended up too long inside the container.
-Use a shorter one.
---- a/pkg/authorization/authz_unix_test.go	2019-01-10 01:55:02.997985947 +0100
-+++ b/pkg/authorization/authz_unix_test.go	2019-01-10 02:03:21.177439757 +0100
-@@ -24,7 +24,7 @@
- )
-
- const (
--	pluginAddress = "authz-test-plugin.sock"
-+	pluginAddress = "/tmp/authz-test-plugin.sock"
- )
-
- func TestAuthZRequestPluginError(t *testing.T) {
-@@ -263,12 +263,7 @@
-
- // createTestPlugin creates a new sample authorization plugin
- func createTestPlugin(t *testing.T) *authorizationPlugin {
--	pwd, err := os.Getwd()
--	if err != nil {
--		t.Fatal(err)
--	}
--
--	client, err := plugins.NewClient("unix:///"+path.Join(pwd, pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
-+	client, err := plugins.NewClient("unix:///"+path.Join("/", pluginAddress), &tlsconfig.Options{InsecureSkipVerify: true})
- 	if err != nil {
- 		t.Fatalf("Failed to create client %v", err)
- 	}
--
2.34.0





^ permalink raw reply related	[relevance 83%]

* [bug#52790] [PATCH 1/4] gnu: containerd: Fix patch-paths build phase.
  @ 2021-12-25 14:40 92% ` Pierre Langlois
  2021-12-25 14:40 92%   ` [bug#52790] [PATCH 2/4] gnu: containerd: Update to 1.5.8 Pierre Langlois
  2021-12-25 14:40 83%   ` [bug#52790] [PATCH 4/4] gnu: docker: Update to 20.10.11 Pierre Langlois
  0 siblings, 2 replies; 149+ results
From: Pierre Langlois @ 2021-12-25 14:40 UTC (permalink / raw)
  To: 52790; +Cc: Pierre Langlois

* gnu/packages/docker.scm (containerd)[arguments]: Add 'patch-paths
phases after 'unpack because 'chdir doesn't exist.  Substitute runc
binary for "pkg/cri/config/config_unix.go".
---
 gnu/packages/docker.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index d012ed43c6..47e4fcd2dc 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -190,7 +190,7 @@ (define-public containerd
        `(#:import-path "github.com/containerd/containerd"
          #:phases
          (modify-phases %standard-phases
-           (add-after 'chdir 'patch-paths
+           (add-after 'unpack 'patch-paths
              (lambda* (#:key inputs import-path outputs #:allow-other-keys)
                (with-directory-excursion (string-append "src/" import-path)
                  (substitute* "runtime/v1/linux/runtime.go"
--
2.34.0





^ permalink raw reply related	[relevance 92%]

* [bug#52550] [PATCH 10/10] tests: docker: Fix it.
  @ 2021-12-16 13:06 59% ` Mathieu Othacehe
  0 siblings, 0 replies; 149+ results
From: Mathieu Othacehe @ 2021-12-16 13:06 UTC (permalink / raw)
  To: 52550; +Cc: Mathieu Othacehe

The docker tests are broken because the docker overlay doesn't support running
on our own storage overlay. Use the new <virtual-machine> volatile? field to
spawn a VM with a persistent storage and no overlay.

* gnu/tests/docker.scm (run-docker-test): Add the docker-tarball to the gc
roots as the host store is not shared anymore. Spawn a VM without volatile
storage.
(run-docker-system-test): Ditto.
(%test-docker-system): Adapt it to use the image API.
---
 gnu/tests/docker.scm | 51 +++++++++++++++++++++++++-------------------
 1 file changed, 29 insertions(+), 22 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index bc119988b7..6302bd0727 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -18,9 +18,11 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu tests docker)
+  #:use-module (gnu image)
   #:use-module (gnu tests)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
+  #:use-module (gnu system image)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
   #:use-module (gnu services dbus)
@@ -35,7 +37,7 @@ (define-module (gnu tests docker)
   #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (guix profiles)
-  #:use-module (guix scripts pack)
+  #:use-module ((guix scripts pack) #:prefix pack:)
   #:use-module (guix store)
   #:use-module (guix tests)
   #:use-module (guix build-system trivial)
@@ -56,15 +58,18 @@ (define (run-docker-test docker-tarball)
 inside %DOCKER-OS."
   (define os
     (marionette-operating-system
-     %docker-os
+     (operating-system-with-gc-roots
+      %docker-os
+      (list docker-tarball))
      #:imported-modules '((gnu services herd)
                           (guix combinators))))
 
   (define vm
     (virtual-machine
      (operating-system os)
-     (memory-size 700)
-     (disk-image-size (* 1500 (expt 2 20)))
+     (volatile? #f)
+     (memory-size 1024)
+     (disk-image-size (* 3000 (expt 2 20)))
      (port-forwardings '())))
 
   (define test
@@ -173,11 +178,12 @@ (define (build-tarball&run-docker-test)
                                            guest-script-package))
                                     #:hooks '()
                                     #:locales? #f))
-       (tarball (docker-image "docker-pack" profile
-                              #:symlinks '(("/bin/Guile" -> "bin/guile")
-                                           ("aa.scm" -> "a.scm"))
-                              #:entry-point "bin/guile"
-                              #:localstatedir? #t)))
+       (tarball (pack:docker-image
+                 "docker-pack" profile
+                 #:symlinks '(("/bin/Guile" -> "bin/guile")
+                              ("aa.scm" -> "a.scm"))
+                 #:entry-point "bin/guile"
+                 #:localstatedir? #t)))
     (run-docker-test tarball)))
 
 (define %test-docker
@@ -192,19 +198,18 @@ (define (run-docker-system-test tarball)
 inside %DOCKER-OS."
   (define os
     (marionette-operating-system
-     %docker-os
+     (operating-system-with-gc-roots
+      %docker-os
+      (list tarball))
      #:imported-modules '((gnu services herd)
                           (guix combinators))))
 
   (define vm
     (virtual-machine
      (operating-system os)
-     ;; FIXME: Because we're using the volatile-root setup where the root file
-     ;; system is a tmpfs overlaid over a small root file system, 'docker
-     ;; load' must be able to store the whole image into memory, hence the
-     ;; huge memory requirements.  We should avoid the volatile-root setup
-     ;; instead.
-     (memory-size 4500)
+     (volatile? #f)
+     (disk-image-size (* 5000 (expt 2 20)))
+     (memory-size 2048)
      (port-forwardings '())))
 
   (define test
@@ -293,10 +298,12 @@ (define %test-docker-system
    (description "Run a system image as produced by @command{guix system
 docker-image} inside Docker.")
    (value (with-monad %store-monad
-            (>>= (system-docker-image (operating-system
-                                        (inherit (simple-operating-system))
-                                        ;; Use locales for a single libc to
-                                        ;; reduce space requirements.
-                                        (locale-libcs (list glibc)))
-                                      #:memory-size 1024)
+            (>>= (lower-object
+                  (system-image (os->image
+                                 (operating-system
+                                   (inherit (simple-operating-system))
+                                   ;; Use locales for a single libc to
+                                   ;; reduce space requirements.
+                                   (locale-libcs (list glibc)))
+                                 #:type docker-image-type)))
                  run-docker-system-test)))))
-- 
2.34.0





^ permalink raw reply related	[relevance 59%]

* [bug#51984] [PATCH 1/1] guix: Enable arm64 docker image building for 'guix pack'
  @ 2021-11-19 21:12 72% ` Collin J. Doering
  0 siblings, 0 replies; 149+ results
From: Collin J. Doering @ 2021-11-19 21:12 UTC (permalink / raw)
  To: 51984

---
 guix/docker.scm | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index a6f73d423c..5e6460f43f 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -214,10 +214,11 @@ (define transformation-options
                                             (else
                                              (error "unsupported system"
                                                     system)))))))
-                 (cond* ("x86_64" "amd64")
-                        ("i686"   "386")
-                        ("arm"    "arm")
-                        ("mips64" "mips64le")))))
+                 (cond* ("x86_64"  "amd64")
+                        ("i686"    "386")
+                        ("arm"     "arm")
+                        ("aarch64" "arm64")
+                        ("mips64"  "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
     (with-directory-excursion directory
-- 
2.33.1

-- 
Collin J. Doering

http://rekahsoft.ca
http://blog.rekahsoft.ca
http://git.rekahsoft.ca




^ permalink raw reply related	[relevance 72%]

* [bug#51597] [PATCH] services: docker: Add 'environment-variables' configuration field.
@ 2021-11-04  6:48 70% Alexey Abramov via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Alexey Abramov via Guix-patches via @ 2021-11-04  6:48 UTC (permalink / raw)
  To: 51597

* gnu/services/docker.scm (docker-configuration):  Add the field
(docker-shepherd-service): Pass the list of defined variables to
make-forkexec-constructor.
* doc/guix.texi (Miscellaneous Services): Update doc.
---
 doc/guix.texi           | 3 +++
 gnu/services/docker.scm | 6 ++++++
 2 files changed, 9 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 8693249d7c..cf269d6014 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -33303,6 +33303,9 @@ Enable or disable debug output.
 @item @code{enable-iptables?} (default @code{#t})
 Enable or disable the addition of iptables rules.
 
+@item @code{environment-variables} (default: @code{()})
+Environment variables to set for dockerd
+
 @end table
 @end deftp
 
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index ef551480aa..c4d48676b5 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -62,6 +62,9 @@ loop-back communications.")
   (enable-iptables?
    (boolean #t)
    "Enable addition of iptables rules (enabled by default).")
+  (environment-variables
+   (list '())
+   "Environment variables to set for dockerd")
   (no-serialization))
 
 (define %docker-accounts
@@ -102,6 +105,7 @@ loop-back communications.")
   (let* ((docker (docker-configuration-docker config))
          (enable-proxy? (docker-configuration-enable-proxy? config))
          (enable-iptables? (docker-configuration-enable-iptables? config))
+         (environment-variables (docker-configuration-environment-variables config))
          (proxy (docker-configuration-proxy config))
          (debug? (docker-configuration-debug? config)))
     (shepherd-service
@@ -132,6 +136,8 @@ loop-back communications.")
                            (if #$enable-iptables?
                                "--iptables"
                                "--iptables=false"))
+                     #:environment-variables
+                     (list #$@environment-variables)
                      #:pid-file "/var/run/docker.pid"
                      #:log-file "/var/log/docker.log"))
            (stop #~(make-kill-destructor)))))
-- 
2.31.1





^ permalink raw reply related	[relevance 70%]

* [bug#51306] [PATCH] gnu: docker-compose: Update to 1.29.2
@ 2021-10-20 14:59 72% Olivier Dion via Guix-patches via
  0 siblings, 0 replies; 149+ results
From: Olivier Dion via Guix-patches via @ 2021-10-20 14:59 UTC (permalink / raw)
  To: 51306; +Cc: Olivier Dion

* gnu/packages/docker.scm (docker-compose): Update to 1.29.2.
---
 gnu/packages/docker.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 8bac1b89ce..9ab9e86c21 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2021 Olivier Dion <olivier.dion@polymtl.ca>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -106,14 +107,14 @@ (define-public python-dockerpty
 (define-public docker-compose
   (package
     (name "docker-compose")
-    (version "1.25.4")
+    (version "1.29.2")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "docker-compose" version))
        (sha256
         (base32
-         "1ww8ckpj3n5jdg63qvmiqx3gk0fsrnynnnqj17fppymbwjzf5fps"))))
+         "1dq9kfak61xx7chjrzmkvbw9mvj9008k7g8q7mwi4x133p9dk32c"))))
     (build-system python-build-system)
     ;; TODO: Tests require running Docker daemon.
     (arguments '(#:tests? #f))
-- 
2.33.1





^ permalink raw reply related	[relevance 72%]

* [bug#50227] [PATCH] build-system/go: Trim store references using the native compiler option.
  @ 2021-08-27 19:38 63%     ` Marius Bakke
  0 siblings, 0 replies; 149+ results
From: Marius Bakke @ 2021-08-27 19:38 UTC (permalink / raw)
  To: 50227


[-- Attachment #1.1: Type: text/plain, Size: 864 bytes --]

Marius Bakke <marius@gnu.org> skriver:

> Marius Bakke <marius@gnu.org> skriver:
>
>> * guix/build/go-build-system.scm (build): Add '-trimpath' to the 'go install'
>> invocation.
>> (remove-store-references, remove-go-references): Remove procedures.
>> (%standard-phases): Don't include remove-go-references.
>> * gnu/packages/docker.scm (docker)[arguments]: Add the '-trimpath' option to
>> the build flags.  Remove phase remove-go-references.
>> * gnu/packages/uucp.scm (nncp)[arguments]: Likewise.

[...]

> Docker explodes from 764.4 MiB to 1215.5 MiB with this patch even though
> it does use the '-trimpath' option.  Perhaps -trimpath does not work as
> well with dynamically linked executables as it does for static?

The size difference comes from containerd, which has a custom build
system that does not add -trimpath.  After adding the following hunk:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: Type: text/x-patch, Size: 1032 bytes --]

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 88dccc2ae2..e1ddfc6c38 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -221,6 +221,13 @@ Python without keeping their credentials in a Docker configuration file.")
                    (("exec\\.LookPath\\(\"unpigz\"\\)")
                     (string-append "\"" (assoc-ref inputs "pigz")
                                    "/bin/unpigz\", error(nil)"))))))
+           (add-before 'build 'trim-store-references
+             (lambda* (#:key import-path #:allow-other-keys)
+               (substitute* (string-append "src/" import-path "/Makefile")
+                 ;; Pass the '-trimpath' option down to 'go build' in order
+                 ;; to avoid spurious store references.
+                 (("^GO_BUILD_FLAGS=")
+                  "GO_BUILD_FLAGS=-trimpath"))))
            (replace 'build
              (lambda* (#:key import-path #:allow-other-keys)
                (with-directory-excursion (string-append "src/" import-path)

[-- Attachment #1.3: Type: text/plain, Size: 272 bytes --]


...the size of Docker becomes 763.7 MiB, or 0.7 less than before.

I realize we can set the flag globally in go-build-system, instead of
just for the build phase.  Then we don't need to patch Docker,
containerd, or anything else that does not use the stock build phase.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.4: Type: text/x-patch, Size: 1634 bytes --]

diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index fc5ee39c8d..a6b9397d35 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -137,6 +137,9 @@ dependencies, so it should be self-contained."
   ;; Using the current working directory as GOPATH makes it easier for packagers
   ;; who need to manipulate the unpacked source code.
   (setenv "GOPATH" (string-append (getcwd) ":" (getenv "GOPATH")))
+  ;; Unconditionally set the -trimpath option to avoid spurious store references
+  ;; from having multiple GOPATH entries.  See <https://bugs.gnu.org/33620>.
+  (setenv "GOFLAGS" "-trimpath")
   ;; Go 1.13 uses go modules by default. The go build system does not
   ;; currently support modules, so turn modules off to continue using the old
   ;; GOPATH behavior.
@@ -188,8 +191,6 @@ unpacking."
       (apply invoke "go" "install"
               "-v" ; print the name of packages as they are compiled
               "-x" ; print each command as it is invoked
-              ;; Trim store references from the compiled binaries.
-              "-trimpath"
               ;; Respectively, strip the symbol table and debug
               ;; information, and the DWARF symbol table.
               "-ldflags=-s -w"
@@ -202,6 +203,9 @@ unpacking."
 ;; Can this also install commands???
 (define* (check #:key tests? import-path #:allow-other-keys)
   "Run the tests for the package named by IMPORT-PATH."
+  ;; Remove the global -trimpath option because it can break some test
+  ;; suites.
+  (unsetenv "GOFLAGS")
   (when tests?
     (invoke "go" "test" import-path))
   #t)

[-- Attachment #1.5: Type: text/plain, Size: 44 bytes --]


This may be a cleaner solution.  Thoughts?

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 247 bytes --]

^ permalink raw reply related	[relevance 63%]

* [bug#50227] [PATCH] build-system/go: Trim store references using the native compiler option.
  @ 2021-08-27 16:44 47% ` Marius Bakke
    0 siblings, 1 reply; 149+ results
From: Marius Bakke @ 2021-08-27 16:44 UTC (permalink / raw)
  To: 50227

* guix/build/go-build-system.scm (build): Add '-trimpath' to the 'go install'
invocation.
(remove-store-references, remove-go-references): Remove procedures.
(%standard-phases): Don't include remove-go-references.
* gnu/packages/docker.scm (docker)[arguments]: Add the '-trimpath' option to
the build flags.  Remove phase remove-go-references.
* gnu/packages/uucp.scm (nncp)[arguments]: Likewise.
---
 gnu/packages/docker.scm        |  7 ++--
 gnu/packages/uucp.scm          |  8 ++--
 guix/build/go-build-system.scm | 70 +++-------------------------------
 3 files changed, 14 insertions(+), 71 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 8bac1b89ce..108f355aa7 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -535,6 +535,8 @@ built-in registry server of Docker.")
              ;; Respectively, strip the symbol table and debug
              ;; information, and the DWARF symbol table.
              (setenv "LDFLAGS" "-s -w")
+             ;; Trim store references from the compiled binary.
+             (setenv "BUILDFLAGS" "-trimpath")
              ;; Make build faster
              (setenv "GOCACHE" "/tmp")
              #t))
@@ -568,10 +570,7 @@ built-in registry server of Docker.")
                (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
                (install-file (string-append "bundles/dynbinary-daemon/dockerd-"
                                             (getenv "VERSION"))
-                             out-bin)
-               #t)))
-         (add-after 'install 'remove-go-references
-           (assoc-ref go:%standard-phases 'remove-go-references)))))
+                             out-bin)))))))
     (inputs
      `(("btrfs-progs" ,btrfs-progs)
        ("containerd" ,containerd)       ; for containerd-shim
diff --git a/gnu/packages/uucp.scm b/gnu/packages/uucp.scm
index 120417dea1..9d39c88fe5 100644
--- a/gnu/packages/uucp.scm
+++ b/gnu/packages/uucp.scm
@@ -127,6 +127,10 @@ between computers.")
              (substitute* (list "bin/default.do" "bin/hjson-cli.do" "test.do")
                ((" -mod=vendor") "")
                ((" -m") ""))
+             (substitute* (list "bin/default.do" "bin/hjson-cli.do")
+               ;; Prevent reference to the Go inputs in the compiled binaries.
+               (("\\$GO build")
+                "$GO build -trimpath"))
              ;; Use the correct module path. `go list` does not report the
              ;; correct module path since we have moved the source files.
              (substitute* "bin/default.do"
@@ -138,9 +142,7 @@ between computers.")
          (replace 'check
            (lambda* (#:key tests? #:allow-other-keys)
              (when tests?
-               (invoke "contrib/do" "-c" "test"))))
-         (add-after 'install 'remove-go-references
-           (assoc-ref go:%standard-phases 'remove-go-references)))))
+               (invoke "contrib/do" "-c" "test")))))))
     (inputs
      `(("go-github-com-davecgh-go-xdr" ,go-github-com-davecgh-go-xdr)
        ("go-github-com-dustin-go-humanize" ,go-github-com-dustin-go-humanize)
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 37936fe5ca..fc5ee39c8d 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -28,8 +28,6 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 ftw)
   #:use-module (srfi srfi-1)
-  #:use-module (rnrs io ports)
-  #:use-module (rnrs bytevectors)
   #:export (%standard-phases
             go-build))
 
@@ -47,12 +45,9 @@
 ;; structure called a 'workspace' [1].  This workspace can be found by Go via
 ;; the GOPATH environment variable.  Typically, all Go source code and compiled
 ;; objects are kept in a single workspace, but GOPATH may be a list of
-;; directories [2].  In this go-build-system we create a file system union of
-;; the Go-language dependencies. Previously, we made GOPATH a list of store
-;; directories, but stopped because Go programs started keeping references to
-;; these directories in Go 1.11:
-;; <https://bugs.gnu.org/33620>.
-;;
+;; directories [2], which we rely on here, with the caveat that the current
+;; package must appear first on GOPATH.
+;
 ;; Go software, whether a package or a command, is uniquely named using an
 ;; 'import path'.  The import path is based on the URL of the software's source.
 ;; Because most source code is provided over the internet, the import path is
@@ -88,7 +83,6 @@
 ;; a tmpdir when creating the inputs union.
 ;; * Use Go modules [4]
 ;; * Re-use compiled packages [5]
-;; * Stop needing remove-go-references (-trimpath ? )
 ;; * Remove module packages, only offering the full Git repos? This is
 ;; more idiomatic, I think, because Go downloads Git repos, not modules.
 ;; What are the trade-offs?
@@ -194,6 +188,8 @@ unpacking."
       (apply invoke "go" "install"
               "-v" ; print the name of packages as they are compiled
               "-x" ; print each command as it is invoked
+              ;; Trim store references from the compiled binaries.
+              "-trimpath"
               ;; Respectively, strip the symbol table and debug
               ;; information, and the DWARF symbol table.
               "-ldflags=-s -w"
@@ -236,59 +232,6 @@ the standard install-license-files phase to first enter the correct directory."
                                                     unpack-path))
     (apply (assoc-ref gnu:%standard-phases 'install-license-files) args)))
 
-(define* (remove-store-reference file file-name
-                                  #:optional (store (%store-directory)))
-  "Remove from FILE occurrences of FILE-NAME in STORE; return #t when FILE-NAME
-is encountered in FILE, #f otherwise. This implementation reads FILE one byte at
-a time, which is slow. Instead, we should use the Boyer-Moore string search
-algorithm; there is an example in (guix build grafts)."
-  (define pattern
-    (string-take file-name
-                 (+ 34 (string-length (%store-directory)))))
-
-  (with-fluids ((%default-port-encoding #f))
-    (with-atomic-file-replacement file
-      (lambda (in out)
-        ;; We cannot use `regexp-exec' here because it cannot deal with
-        ;; strings containing NUL characters.
-        (format #t "removing references to `~a' from `~a'...~%" file-name file)
-        (setvbuf in 'block 65536)
-        (setvbuf out 'block 65536)
-        (fold-port-matches (lambda (match result)
-                             (put-bytevector out (string->utf8 store))
-                             (put-u8 out (char->integer #\/))
-                             (put-bytevector out
-                                             (string->utf8
-                                              "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
-                             #t)
-                           #f
-                           pattern
-                           in
-                           (lambda (char result)
-                             (put-u8 out (char->integer char))
-                             result))))))
-
-(define* (remove-go-references #:key allow-go-reference?
-                               inputs outputs #:allow-other-keys)
-  "Remove any references to the Go compiler from the compiled Go executable
-files in OUTPUTS."
-;; We remove this spurious reference to save bandwidth when installing Go
-;; executables. It would be better to not embed the reference in the first
-;; place, but I'm not sure how to do that. The subject was discussed at:
-;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00207.html>
-  (if allow-go-reference?
-    #t
-    (let ((go (assoc-ref inputs "go"))
-          (bin "/bin"))
-      (for-each (lambda (output)
-                  (when (file-exists? (string-append (cdr output)
-                                                     bin))
-                    (for-each (lambda (file)
-                                (remove-store-reference file go))
-                              (find-files (string-append (cdr output) bin)))))
-                outputs)
-      #t)))
-
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (delete 'bootstrap)
@@ -299,8 +242,7 @@ files in OUTPUTS."
     (replace 'build build)
     (replace 'check check)
     (replace 'install install)
-    (replace 'install-license-files install-license-files)
-    (add-after 'install 'remove-go-references remove-go-references)))
+    (replace 'install-license-files install-license-files)))
 
 (define* (go-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
-- 
2.31.1





^ permalink raw reply related	[relevance 47%]

* [bug#44700] [PATCH v3 2/2] services: Migrate to <setuid-program>.
  @ 2021-07-06 20:03 40% ` Brice Waegeneire
  0 siblings, 0 replies; 149+ results
From: Brice Waegeneire @ 2021-07-06 20:03 UTC (permalink / raw)
  To: 44700; +Cc: cwebber

* gnu/services/dbus.scm (dbus-setuid-programs, polkit-setuid-programs):
  Return setuid-programs.
* gnu/services/desktop.scm (enlightenment-setuid-programs): Return
 setuid-programs.
 (%desktop-services)[mount-setuid-helpers]: Use setuid-programs.
* gnu/services/docker.scm (singularity-setuid-programs): Return
 setuid-programs.
* gnu/services/xorg.scm(screen-locker-setuid-programs): Return
 setuid-programs.
* gnu/system.scm (%setuid-programs): Return setuid-programs.
* doc/guix.texi (Setuid Programs, operating-system Reference): Replace
  'list of G-expressions' with 'list of <setuid-program>'.
---
 doc/guix.texi            | 19 +++++++++++--------
 gnu/services/dbus.scm    | 13 +++++++++----
 gnu/services/desktop.scm | 26 ++++++++++++++++----------
 gnu/services/docker.scm  |  9 ++++++---
 gnu/services/xorg.scm    |  4 +++-
 gnu/system.scm           | 31 ++++++++++++++++---------------
 6 files changed, 61 insertions(+), 41 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f7a72b9885..7919332521 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -13860,8 +13860,8 @@ Linux @dfn{pluggable authentication module} (PAM) services.
 @c FIXME: Add xref to PAM services section.
 
 @item @code{setuid-programs} (default: @code{%setuid-programs})
-List of string-valued G-expressions denoting setuid programs.
-@xref{Setuid Programs}.
+List of @code{<setuid-program>}.  @xref{Setuid Programs}, for more
+information.
 
 @item @code{sudoers-file} (default: @code{%sudoers-specification})
 @cindex sudoers file
@@ -32421,13 +32421,15 @@ the store, we let the system administrator @emph{declare} which programs
 should be setuid root.
 
 The @code{setuid-programs} field of an @code{operating-system}
-declaration contains a list of G-expressions denoting the names of
-programs to be setuid-root (@pxref{Using the Configuration System}).
-For instance, the @command{passwd} program, which is part of the Shadow
-package, can be designated by this G-expression (@pxref{G-Expressions}):
+declaration contains a list of @code{<setuid-program>} denoting the
+names of programs to have a setuid or setgid bit set (@pxref{Using the
+Configuration System}).  For instance, the @command{passwd} program,
+which is part of the Shadow package, with a setuid root can be
+designated like this:
 
 @example
-#~(string-append #$shadow "/bin/passwd")
+(setuid-program
+  (program (file-append #$shadow "/bin/passwd")))
 @end example
 
 @deftp {Data Type} setuid-program
@@ -32458,7 +32460,8 @@ A default set of setuid programs is defined by the
 @code{%setuid-programs} variable of the @code{(gnu system)} module.
 
 @defvr {Scheme Variable} %setuid-programs
-A list of G-expressions denoting common programs that are setuid-root.
+A list of @code{<setuid-program>} denoting common programs that are
+setuid-root.
 
 The list includes commands such as @command{passwd}, @command{ping},
 @command{su}, and @command{sudo}.
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index af1a1e4c3a..e7b3dac166 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +22,7 @@
 (define-module (gnu services dbus)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
   #:use-module ((gnu packages glib) #:select (dbus))
@@ -156,10 +158,12 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
          (shell (file-append shadow "/sbin/nologin")))))
 
 (define dbus-setuid-programs
-  ;; Return the file name of the setuid program that we need.
+  ;; Return a list of <setuid-program> for the program that we need.
   (match-lambda
     (($ <dbus-configuration> dbus services)
-     (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
+     (list (setuid-program
+            (program (file-append
+                      dbus "/libexec/dbus-daemon-launch-helper")))))))
 
 (define (dbus-activation config)
   "Return an activation gexp for D-Bus using @var{config}."
@@ -335,8 +339,9 @@ tuples, are all set as environment variables when the bus daemon launches it."
 (define polkit-setuid-programs
   (match-lambda
     (($ <polkit-configuration> polkit)
-     (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
-           (file-append polkit "/bin/pkexec")))))
+     (map file-like->setuid-program
+          (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
+                (file-append polkit "/bin/pkexec"))))))
 
 (define polkit-service-type
   (service-type (name 'polkit)
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index cd800fcc2b..64d0e85301 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -12,6 +12,7 @@
 ;;; Copyright © 2019 David Wilson <david@daviwil.com>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,6 +41,7 @@
   #:use-module ((gnu system file-systems)
                 #:select (%elogind-file-systems file-system))
   #:use-module (gnu system)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
   #:use-module (gnu packages glib)
@@ -1034,14 +1036,15 @@ rules."
 
 (define (enlightenment-setuid-programs enlightenment-desktop-configuration)
   (match-record enlightenment-desktop-configuration
-                <enlightenment-desktop-configuration>
-                (enlightenment)
-    (list (file-append enlightenment
-                       "/lib/enlightenment/utils/enlightenment_sys")
-          (file-append enlightenment
-                       "/lib/enlightenment/utils/enlightenment_system")
-          (file-append enlightenment
-                       "/lib/enlightenment/utils/enlightenment_ckpasswd"))))
+      <enlightenment-desktop-configuration>
+    (enlightenment)
+    (map file-like->setuid-program
+         (list (file-append enlightenment
+                            "/lib/enlightenment/utils/enlightenment_sys")
+               (file-append enlightenment
+                            "/lib/enlightenment/utils/enlightenment_system")
+               (file-append enlightenment
+                            "/lib/enlightenment/utils/enlightenment_ckpasswd")))))
 
 (define enlightenment-desktop-service-type
   (service-type
@@ -1204,8 +1207,11 @@ or setting its password with passwd.")))
          ;; Allow desktop users to also mount NTFS and NFS file systems
          ;; without root.
          (simple-service 'mount-setuid-helpers setuid-program-service-type
-                         (list (file-append nfs-utils "/sbin/mount.nfs")
-                               (file-append ntfs-3g "/sbin/mount.ntfs-3g")))
+                         (map (lambda (program)
+                                (setuid-program
+                                 (program program)))
+                              (list (file-append nfs-utils "/sbin/mount.nfs")
+                               (file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
 
          ;; The global fontconfig cache directory can sometimes contain
          ;; stale entries, possibly referencing fonts that have been GC'd,
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index be85316180..ef551480aa 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
@@ -195,9 +197,10 @@ bundles in Docker containers.")
                                                            "-helper")))
                                  '("action" "mount" "start")))))
 
-  (list (file-append helpers "/singularity-action-helper")
-        (file-append helpers "/singularity-mount-helper")
-        (file-append helpers "/singularity-start-helper")))
+  (map file-like->setuid-program
+       (list (file-append helpers "/singularity-action-helper")
+             (file-append helpers "/singularity-mount-helper")
+             (file-append helpers "/singularity-start-helper"))))
 
 (define singularity-service-type
   (service-type (name 'singularity)
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 8ffea3b9dd..d95f8beb7a 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 shtwzrd <shtwzrd@protonmail.com>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system keyboard)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
@@ -681,7 +683,7 @@ reboot_cmd " shepherd "/sbin/reboot\n"
                              #:allow-empty-passwords? empty?)))))
 
 (define screen-locker-setuid-programs
-  (compose list screen-locker-program))
+  (compose list file-like->setuid-program screen-locker-program))
 
 (define screen-locker-service-type
   (service-type (name 'screen-locker)
diff --git a/gnu/system.scm b/gnu/system.scm
index 385c36a484..681dd33630 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -1105,22 +1105,23 @@ use 'plain-file' instead~%")
 (define %setuid-programs
   ;; Default set of setuid-root programs.
   (let ((shadow (@ (gnu packages admin) shadow)))
-    (list (file-append shadow "/bin/passwd")
-          (file-append shadow "/bin/sg")
-          (file-append shadow "/bin/su")
-          (file-append shadow "/bin/newgrp")
-          (file-append shadow "/bin/newuidmap")
-          (file-append shadow "/bin/newgidmap")
-          (file-append inetutils "/bin/ping")
-          (file-append inetutils "/bin/ping6")
-          (file-append sudo "/bin/sudo")
-          (file-append sudo "/bin/sudoedit")
-          (file-append fuse "/bin/fusermount")
+    (map file-like->setuid-program
+         (list (file-append shadow "/bin/passwd")
+               (file-append shadow "/bin/sg")
+               (file-append shadow "/bin/su")
+               (file-append shadow "/bin/newgrp")
+               (file-append shadow "/bin/newuidmap")
+               (file-append shadow "/bin/newgidmap")
+               (file-append inetutils "/bin/ping")
+               (file-append inetutils "/bin/ping6")
+               (file-append sudo "/bin/sudo")
+               (file-append sudo "/bin/sudoedit")
+               (file-append fuse "/bin/fusermount")
 
-          ;; To allow mounts with the "user" option, "mount" and "umount" must
-          ;; be setuid-root.
-          (file-append util-linux "/bin/mount")
-          (file-append util-linux "/bin/umount"))))
+               ;; To allow mounts with the "user" option, "mount" and "umount" must
+               ;; be setuid-root.
+               (file-append util-linux "/bin/mount")
+               (file-append util-linux "/bin/umount")))))
 
 (define %sudoers-specification
   ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
-- 
2.31.1





^ permalink raw reply related	[relevance 40%]

* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
  @ 2021-07-04  3:21 84%           ` Maxim Cournoyer
  0 siblings, 0 replies; 149+ results
From: Maxim Cournoyer @ 2021-07-04  3:21 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: 49149

[-- Attachment #1: Type: text/plain, Size: 2500 bytes --]

Hi!

Ludovic Courtès <ludo@gnu.org> writes:

> Hi,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>>>
>>>> Instead of just naming them by their pack type, add information from the
>>>> package(s) they contain to make it easier to differentiate them.
>>>>
>>>> * guix/scripts/pack.scm (define-with-source): New macro.
>>>> (manifest->friendly-name): Extract procedure from ...
>>>> (docker-image): ... here, now defined via the above macro.  Adjust REPOSITORY
>>>> argument value accordingly.
>>>> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
>>>
>>> [...]
>>>
>>>> -            (define tag
>>>> -              ;; Compute a meaningful "repository" name, which will show up in
>>>> -              ;; the output of "docker images".
>>>> -              (let ((manifest (profile-manifest #$profile)))
>>>> -                (let loop ((names (map manifest-entry-name
>>>> -                                       (manifest-entries manifest))))
>>>> -                  (define str (string-join names "-"))
>>>> -                  (if (< (string-length str) 40)
>>>> -                      str
>>>> -                      (match names
>>>> -                        ((_) str)
>>>> -                        ((names ... _) (loop names))))))) ;drop one entry
>>>
>>> I think this should not be factorized because the requirements are very
>>> Docker-dependent.  Once factorized, it becomes easy to overlook this.
>>
>> Hmm, I'm not a docker format expert, but my quick reading about it
>> turned no restrictions about what a docker image label should look like?
>> So perhaps it is not specially Docker-dependent.
>
> It’s a hack specifically written with Docker repository names in mind,
> and the 40-or-so character limit, for instance.

The actual name length requirement for a Docker repository name seems to
be that it must be between 2 and 255 characters [0]; the attached patch
ensure that this is respected.

> To me it’s a case where factorization isn’t beneficial.  Even if there’s
> a similar procedure used in a different context, it’s still a different
> context with different constraints.  My 2¢!

It seems to me that with the attached patch we get to share what used to
be a Docker-specific abstraction without any added risk (have our cake
and it eat to!).

What do you think?

Thanks,

Maxim


[-- Attachment #2: 0001-guix-docker-Ensure-repository-name-length-limits-are.patch --]
[-- Type: text/x-patch, Size: 2731 bytes --]

From f3dc90213423bf0a087245bd4bfc8c4a828d4df1 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 3 Jul 2021 23:08:15 -0400
Subject: [PATCH] guix: docker: Ensure repository name length limits are met.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* guix/docker.scm (canonicalize-repository-name): Fix typo in doc.  Capture
repository name length limits and ensure they are met, by either truncating or
padding the normalized name.

Reported-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/docker.scm | 28 ++++++++++++++++++++++------
 1 file changed, 22 insertions(+), 6 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index bd952e45ec..4239ccdf9c 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -59,8 +60,13 @@
     (container_config . #nil)))
 
 (define (canonicalize-repository-name name)
-  "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+  "\"Repository\" names are restricted to roughly [a-z0-9_.-].
 Return a version of TAG that follows these rules."
+  ;; Refer to https://docs.docker.com/docker-hub/repos/.
+  (define min-length 2)
+  (define padding-character #\a)
+  (define max-length 255)
+
   (define ascii-letters
     (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 
@@ -70,11 +76,21 @@ Return a version of TAG that follows these rules."
   (define repo-char-set
     (char-set-union char-set:digit ascii-letters separators))
 
-  (string-map (lambda (chr)
-                (if (char-set-contains? repo-char-set chr)
-                    chr
-                    #\.))
-              (string-trim (string-downcase name) separators)))
+  (define normalized-name
+    (string-map (lambda (chr)
+                  (if (char-set-contains? repo-char-set chr)
+                      chr
+                      #\.))
+                (string-trim (string-downcase name) separators)))
+
+  (let ((l (string-length normalized-name)))
+    (match l
+      ((? (cut > <> max-length))
+       (string-take normalized-name max-length))
+      ((? (cut < <> min-length ))
+       (string-append normalized-name
+                      (make-string (- min-length l) padding-character)))
+      (_ normalized-name))))
 
 (define* (manifest path id #:optional (tag "guix"))
   "Generate a simple image manifest."
-- 
2.32.0


^ permalink raw reply related	[relevance 84%]

* [bug#44700] [PATCH v2 2/2] services: Migrate to <setuid-program>.
  @ 2021-07-03 16:51 45% ` Brice Waegeneire
  0 siblings, 0 replies; 149+ results
From: Brice Waegeneire @ 2021-07-03 16:51 UTC (permalink / raw)
  To: 44700; +Cc: cwebber

* gnu/services/dbus.scm (dbus-setuid-programs, polkit-setuid-programs):
  Return setuid-programs.
* gnu/services/desktop.scm (enlightenment-setuid-programs): Return
 setuid-programs.
 (%desktop-services)[mount-setuid-helpers]: Use setuid-programs.
* gnu/services/docker.scm (singularity-setuid-programs): Return
 setuid-programs.
* gnu/services/xorg.scm(screen-locker-setuid-programs): Return
 setuid-programs.
* gnu/system.scm (%setuid-programs): Return setuid-programs.
---
 gnu/services/dbus.scm    | 13 +++++++++----
 gnu/services/desktop.scm | 26 ++++++++++++++++----------
 gnu/services/docker.scm  |  9 ++++++---
 gnu/services/xorg.scm    |  4 +++-
 gnu/system.scm           | 31 ++++++++++++++++---------------
 5 files changed, 50 insertions(+), 33 deletions(-)

diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index af1a1e4c3a..e7b3dac166 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +22,7 @@
 (define-module (gnu services dbus)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
   #:use-module ((gnu packages glib) #:select (dbus))
@@ -156,10 +158,12 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
          (shell (file-append shadow "/sbin/nologin")))))
 
 (define dbus-setuid-programs
-  ;; Return the file name of the setuid program that we need.
+  ;; Return a list of <setuid-program> for the program that we need.
   (match-lambda
     (($ <dbus-configuration> dbus services)
-     (list (file-append dbus "/libexec/dbus-daemon-launch-helper")))))
+     (list (setuid-program
+            (program (file-append
+                      dbus "/libexec/dbus-daemon-launch-helper")))))))
 
 (define (dbus-activation config)
   "Return an activation gexp for D-Bus using @var{config}."
@@ -335,8 +339,9 @@ tuples, are all set as environment variables when the bus daemon launches it."
 (define polkit-setuid-programs
   (match-lambda
     (($ <polkit-configuration> polkit)
-     (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
-           (file-append polkit "/bin/pkexec")))))
+     (map file-like->setuid-program
+          (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
+                (file-append polkit "/bin/pkexec"))))))
 
 (define polkit-service-type
   (service-type (name 'polkit)
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index cd800fcc2b..6297b8eb0b 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -12,6 +12,7 @@
 ;;; Copyright © 2019 David Wilson <david@daviwil.com>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org>
+;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,6 +41,7 @@
   #:use-module ((gnu system file-systems)
                 #:select (%elogind-file-systems file-system))
   #:use-module (gnu system)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
   #:use-module (gnu packages glib)
@@ -1034,14 +1036,15 @@ rules."
 
 (define (enlightenment-setuid-programs enlightenment-desktop-configuration)
   (match-record enlightenment-desktop-configuration
-                <enlightenment-desktop-configuration>
-                (enlightenment)
-    (list (file-append enlightenment
-                       "/lib/enlightenment/utils/enlightenment_sys")
-          (file-append enlightenment
-                       "/lib/enlightenment/utils/enlightenment_system")
-          (file-append enlightenment
-                       "/lib/enlightenment/utils/enlightenment_ckpasswd"))))
+      <enlightenment-desktop-configuration>
+    (enlightenment)
+    (map file-like->setuid-program
+         (list (file-append enlightenment
+                            "/lib/enlightenment/utils/enlightenment_sys")
+               (file-append enlightenment
+                            "/lib/enlightenment/utils/enlightenment_system")
+               (file-append enlightenment
+                            "/lib/enlightenment/utils/enlightenment_ckpasswd")))))
 
 (define enlightenment-desktop-service-type
   (service-type
@@ -1204,8 +1207,11 @@ or setting its password with passwd.")))
          ;; Allow desktop users to also mount NTFS and NFS file systems
          ;; without root.
          (simple-service 'mount-setuid-helpers setuid-program-service-type
-                         (list (file-append nfs-utils "/sbin/mount.nfs")
-                               (file-append ntfs-3g "/sbin/mount.ntfs-3g")))
+                         (map (lambda (program)
+                                (setuid-program
+                                 (program program)))
+                              (list (file-append nfs-utils "/sbin/mount.nfs")
+                               (file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
 
          ;; The global fontconfig cache directory can sometimes contain
          ;; stale entries, possibly referencing fonts that have been GC'd,
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index be85316180..ef551480aa 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages docker)
   #:use-module (gnu packages linux)               ;singularity
@@ -195,9 +197,10 @@ bundles in Docker containers.")
                                                            "-helper")))
                                  '("action" "mount" "start")))))
 
-  (list (file-append helpers "/singularity-action-helper")
-        (file-append helpers "/singularity-mount-helper")
-        (file-append helpers "/singularity-start-helper")))
+  (map file-like->setuid-program
+       (list (file-append helpers "/singularity-action-helper")
+             (file-append helpers "/singularity-mount-helper")
+             (file-append helpers "/singularity-start-helper"))))
 
 (define singularity-service-type
   (service-type (name 'singularity)
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 8ffea3b9dd..d95f8beb7a 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 shtwzrd <shtwzrd@protonmail.com>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
+  #:use-module (gnu system setuid)
   #:use-module (gnu system keyboard)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
@@ -681,7 +683,7 @@ reboot_cmd " shepherd "/sbin/reboot\n"
                              #:allow-empty-passwords? empty?)))))
 
 (define screen-locker-setuid-programs
-  (compose list screen-locker-program))
+  (compose list file-like->setuid-program screen-locker-program))
 
 (define screen-locker-service-type
   (service-type (name 'screen-locker)
diff --git a/gnu/system.scm b/gnu/system.scm
index 96b45ede96..8a70f86457 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -1074,22 +1074,23 @@ use 'plain-file' instead~%")
 (define %setuid-programs
   ;; Default set of setuid-root programs.
   (let ((shadow (@ (gnu packages admin) shadow)))
-    (list (file-append shadow "/bin/passwd")
-          (file-append shadow "/bin/sg")
-          (file-append shadow "/bin/su")
-          (file-append shadow "/bin/newgrp")
-          (file-append shadow "/bin/newuidmap")
-          (file-append shadow "/bin/newgidmap")
-          (file-append inetutils "/bin/ping")
-          (file-append inetutils "/bin/ping6")
-          (file-append sudo "/bin/sudo")
-          (file-append sudo "/bin/sudoedit")
-          (file-append fuse "/bin/fusermount")
+    (map file-like->setuid-program
+         (list (file-append shadow "/bin/passwd")
+               (file-append shadow "/bin/sg")
+               (file-append shadow "/bin/su")
+               (file-append shadow "/bin/newgrp")
+               (file-append shadow "/bin/newuidmap")
+               (file-append shadow "/bin/newgidmap")
+               (file-append inetutils "/bin/ping")
+               (file-append inetutils "/bin/ping6")
+               (file-append sudo "/bin/sudo")
+               (file-append sudo "/bin/sudoedit")
+               (file-append fuse "/bin/fusermount")
 
-          ;; To allow mounts with the "user" option, "mount" and "umount" must
-          ;; be setuid-root.
-          (file-append util-linux "/bin/mount")
-          (file-append util-linux "/bin/umount"))))
+               ;; To allow mounts with the "user" option, "mount" and "umount" must
+               ;; be setuid-root.
+               (file-append util-linux "/bin/mount")
+               (file-append util-linux "/bin/umount")))))
 
 (define %sudoers-specification
   ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
-- 
2.31.1





^ permalink raw reply related	[relevance 45%]

* [bug#49149] [PATCH v2 2/7] pack: Factorize base tar options.
  @ 2021-06-24  4:40 44%   ` Maxim Cournoyer
    1 sibling, 0 replies; 149+ results
From: Maxim Cournoyer @ 2021-06-24  4:40 UTC (permalink / raw)
  To: 49149; +Cc: Maxim Cournoyer

* guix/docker.scm (%tar-determinism-options): Move to a new module and rename
to `tar-base-options'.  Adjust references accordingly.
* guix/build/pack.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use it.
---
 Makefile.am           |  1 +
 guix/build/pack.scm   | 52 +++++++++++++++++++++++++++
 guix/docker.scm       | 20 ++---------
 guix/scripts/pack.scm | 81 +++++++++++++++++--------------------------
 4 files changed, 87 insertions(+), 67 deletions(-)
 create mode 100644 guix/build/pack.scm

diff --git a/Makefile.am b/Makefile.am
index 7bb5de007e..15ac03ebd9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -220,6 +220,7 @@ MODULES =					\
   guix/build/linux-module-build-system.scm	\
   guix/build/store-copy.scm			\
   guix/build/json.scm				\
+  guix/build/pack.scm				\
   guix/build/utils.scm				\
   guix/build/union.scm				\
   guix/build/profiles.scm			\
diff --git a/guix/build/pack.scm b/guix/build/pack.scm
new file mode 100644
index 0000000000..05c7a3c594
--- /dev/null
+++ b/guix/build/pack.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build pack)
+  #:use-module (guix build utils)
+  #:export (tar-base-options))
+
+(define* (tar-base-options #:key tar compressor)
+  "Return the base GNU tar options required to produce deterministic archives
+deterministically.  When TAR, a GNU tar command file name, is provided, the
+`--sort' option is used only if supported.  When COMPRESSOR, a command such as
+'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via
+the `-I' option."
+  (define (tar-supports-sort? tar)
+    (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null"
+                    "--sort=name")))
+
+  `(,@(if compressor
+          (list "-I" (string-join compressor))
+          '())
+    ;; The --sort option was added to GNU tar in version 1.28, released
+    ;; 2014-07-28.  For testing, we use the bootstrap tar, which is older
+    ;; and doesn't support it.
+    ,@(if (and=> tar tar-supports-sort?)
+          '("--sort=name")
+          '())
+    ;; Use GNU format so there's no file name length limitation.
+    "--format=gnu"
+    "--mtime=@1"
+    "--owner=root:0"
+    "--group=root:0"
+    ;; The 'nlink' of the store item files leads tar to store hard links
+    ;; instead of actual copies.  However, the 'nlink' count depends on
+    ;; deduplication in the store; it's an "implicit input" to the build
+    ;; process.  Use '--hard-dereference' to eliminate it.
+    "--hard-dereference"
+    "--check-links"))
diff --git a/guix/docker.scm b/guix/docker.scm
index 889aaeacb5..bd952e45ec 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -21,6 +21,7 @@
 (define-module (guix docker)
   #:use-module (gcrypt hash)
   #:use-module (guix base16)
+  #:use-module (guix build pack)
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
@@ -110,18 +111,6 @@ Return a version of TAG that follows these rules."
     (rootfs . ((type . "layers")
                (diff_ids . #(,(layer-diff-id layer)))))))
 
-(define %tar-determinism-options
-  ;; GNU tar options to produce archives deterministically.
-  '("--sort=name" "--mtime=@1"
-    "--owner=root:0" "--group=root:0"
-
-    ;; When 'build-docker-image' is passed store items, the 'nlink' of the
-    ;; files therein leads tar to store hard links instead of actual copies.
-    ;; However, the 'nlink' count depends on deduplication in the store; it's
-    ;; an "implicit input" to the build process.  '--hard-dereference'
-    ;; eliminates it.
-    "--hard-dereference"))
-
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
   ;; directive.
@@ -238,7 +227,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
 
           (apply invoke "tar" "-cf" "../layer.tar"
                  `(,@transformation-options
-                   ,@%tar-determinism-options
+                   ,@(tar-base-options)
                    ,@paths
                    ,@(scandir "."
                               (lambda (file)
@@ -273,9 +262,6 @@ SRFI-19 time-utc object, as the creation time in metadata."
           (scm->json (repositories prefix id repository)))))
 
     (apply invoke "tar" "-cf" image "-C" directory
-           `(,@%tar-determinism-options
-             ,@(if compressor
-                   (list "-I" (string-join compressor))
-                   '())
+           `(,@(tar-base-options #:compressor compressor)
              "."))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ac477850e6..d11f498925 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -205,12 +205,14 @@ dependencies are registered."
          (not (equal? '(guix store deduplication) module))))
 
   (with-imported-modules (source-module-closure
-                          `((guix build utils)
+                          `((guix build pack)
+                            (guix build utils)
                             (guix build union)
                             (gnu build install))
                           #:select? import-module?)
     #~(begin
-        (use-modules (guix build utils)
+        (use-modules (guix build pack)
+                     (guix build utils)
                      ((guix build union) #:select (relative-file-name))
                      (gnu build install)
                      (srfi srfi-1)
@@ -240,19 +242,10 @@ dependencies are registered."
           ;; Fully-qualified symlinks.
           (append-map symlink->directives '#$symlinks))
 
-        ;; The --sort option was added to GNU tar in version 1.28, released
-        ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
-        ;; older and doesn't support it.
-        (define tar-supports-sort?
-          (zero? (system* (string-append #+archiver "/bin/tar")
-                          "cf" "/dev/null" "--files-from=/dev/null"
-                          "--sort=name")))
-
         ;; Make sure non-ASCII file names are properly handled.
         #+set-utf8-locale
 
-        ;; Add 'tar' to the search path.
-        (setenv "PATH" #+(file-append archiver "/bin"))
+        (define tar #+(file-append archiver "/bin/tar"))
 
         ;; Note: there is not much to gain here with deduplication and there
         ;; is the overhead of the '.links' directory, so turn it off.
@@ -269,45 +262,33 @@ dependencies are registered."
         (for-each (cut evaluate-populate-directive <> %root)
                   directives)
 
-        ;; Create the tarball.  Use GNU format so there's no file name
-        ;; length limitation.
+        ;; Create the tarball.
         (with-directory-excursion %root
-          (apply invoke "tar"
-                 #+@(if (compressor-command compressor)
-                        #~("-I"
-                           (string-join
-                            '#+(compressor-command compressor)))
-                        #~())
-                 "--format=gnu"
-                 ;; Avoid non-determinism in the archive.
-                 ;; Use mtime = 1, not zero, because that is what the daemon
-                 ;; does for files in the store (see the 'mtimeStore' constant
-                 ;; in local-store.cc.)
-                 (if tar-supports-sort? "--sort=name" "--mtime=@1")
-                 "--owner=root:0"
-                 "--group=root:0"
-                 "--check-links"
-                 "-cvf" #$output
-                 ;; Avoid adding / and /var to the tarball, so
-                 ;; that the ownership and permissions of those
-                 ;; directories will not be overwritten when
-                 ;; extracting the archive.  Do not include /root
-                 ;; because the root account might have a
-                 ;; different home directory.
-                 #$@(if localstatedir?
-                        '("./var/guix")
-                        '())
-
-                 (string-append "." (%store-directory))
-
-                 (delete-duplicates
-                  (filter-map (match-lambda
-                                (('directory directory)
-                                 (string-append "." directory))
-                                ((source '-> _)
-                                 (string-append "." source))
-                                (_ #f))
-                              directives)))))))
+          (apply invoke tar
+                 `(,@(tar-base-options
+                      #:tar tar
+                      #:compressor '#+(and=> compressor compressor-command))
+                   "-cvf" ,#$output
+                   ;; Avoid adding / and /var to the tarball, so
+                   ;; that the ownership and permissions of those
+                   ;; directories will not be overwritten when
+                   ;; extracting the archive.  Do not include /root
+                   ;; because the root account might have a
+                   ;; different home directory.
+                   ,#$@(if localstatedir?
+                           '("./var/guix")
+                           '())
+
+                   ,(string-append "." (%store-directory))
+
+                   ,@(delete-duplicates
+                      (filter-map (match-lambda
+                                    (('directory directory)
+                                     (string-append "." directory))
+                                    ((source '-> _)
+                                     (string-append "." source))
+                                    (_ #f))
+                                  directives))))))))
 
 (define* (self-contained-tarball name profile
                                  #:key target
-- 
2.32.0





^ permalink raw reply related	[relevance 44%]

* [bug#49149] [PATCH 2/7] pack: Factorize base tar options.
  @ 2021-06-21  6:12 44% ` Maxim Cournoyer
  0 siblings, 0 replies; 149+ results
From: Maxim Cournoyer @ 2021-06-21  6:12 UTC (permalink / raw)
  To: 49149; +Cc: Maxim Cournoyer

* guix/docker.scm (%tar-determinism-options): Move to a new module and rename
to `tar-base-options'.  Adjust references accordingly.
* guix/build/pack.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use it.
---
 Makefile.am           |  1 +
 guix/build/pack.scm   | 52 +++++++++++++++++++++++++++
 guix/docker.scm       | 20 ++---------
 guix/scripts/pack.scm | 81 +++++++++++++++++--------------------------
 4 files changed, 87 insertions(+), 67 deletions(-)
 create mode 100644 guix/build/pack.scm

diff --git a/Makefile.am b/Makefile.am
index aa21b5383b..9c4b33c77a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -220,6 +220,7 @@ MODULES =					\
   guix/build/linux-module-build-system.scm	\
   guix/build/store-copy.scm			\
   guix/build/json.scm				\
+  guix/build/pack.scm				\
   guix/build/utils.scm				\
   guix/build/union.scm				\
   guix/build/profiles.scm			\
diff --git a/guix/build/pack.scm b/guix/build/pack.scm
new file mode 100644
index 0000000000..05c7a3c594
--- /dev/null
+++ b/guix/build/pack.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build pack)
+  #:use-module (guix build utils)
+  #:export (tar-base-options))
+
+(define* (tar-base-options #:key tar compressor)
+  "Return the base GNU tar options required to produce deterministic archives
+deterministically.  When TAR, a GNU tar command file name, is provided, the
+`--sort' option is used only if supported.  When COMPRESSOR, a command such as
+'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via
+the `-I' option."
+  (define (tar-supports-sort? tar)
+    (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null"
+                    "--sort=name")))
+
+  `(,@(if compressor
+          (list "-I" (string-join compressor))
+          '())
+    ;; The --sort option was added to GNU tar in version 1.28, released
+    ;; 2014-07-28.  For testing, we use the bootstrap tar, which is older
+    ;; and doesn't support it.
+    ,@(if (and=> tar tar-supports-sort?)
+          '("--sort=name")
+          '())
+    ;; Use GNU format so there's no file name length limitation.
+    "--format=gnu"
+    "--mtime=@1"
+    "--owner=root:0"
+    "--group=root:0"
+    ;; The 'nlink' of the store item files leads tar to store hard links
+    ;; instead of actual copies.  However, the 'nlink' count depends on
+    ;; deduplication in the store; it's an "implicit input" to the build
+    ;; process.  Use '--hard-dereference' to eliminate it.
+    "--hard-dereference"
+    "--check-links"))
diff --git a/guix/docker.scm b/guix/docker.scm
index 889aaeacb5..bd952e45ec 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -21,6 +21,7 @@
 (define-module (guix docker)
   #:use-module (gcrypt hash)
   #:use-module (guix base16)
+  #:use-module (guix build pack)
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
@@ -110,18 +111,6 @@ Return a version of TAG that follows these rules."
     (rootfs . ((type . "layers")
                (diff_ids . #(,(layer-diff-id layer)))))))
 
-(define %tar-determinism-options
-  ;; GNU tar options to produce archives deterministically.
-  '("--sort=name" "--mtime=@1"
-    "--owner=root:0" "--group=root:0"
-
-    ;; When 'build-docker-image' is passed store items, the 'nlink' of the
-    ;; files therein leads tar to store hard links instead of actual copies.
-    ;; However, the 'nlink' count depends on deduplication in the store; it's
-    ;; an "implicit input" to the build process.  '--hard-dereference'
-    ;; eliminates it.
-    "--hard-dereference"))
-
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
   ;; directive.
@@ -238,7 +227,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
 
           (apply invoke "tar" "-cf" "../layer.tar"
                  `(,@transformation-options
-                   ,@%tar-determinism-options
+                   ,@(tar-base-options)
                    ,@paths
                    ,@(scandir "."
                               (lambda (file)
@@ -273,9 +262,6 @@ SRFI-19 time-utc object, as the creation time in metadata."
           (scm->json (repositories prefix id repository)))))
 
     (apply invoke "tar" "-cf" image "-C" directory
-           `(,@%tar-determinism-options
-             ,@(if compressor
-                   (list "-I" (string-join compressor))
-                   '())
+           `(,@(tar-base-options #:compressor compressor)
              "."))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ac477850e6..d11f498925 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -205,12 +205,14 @@ dependencies are registered."
          (not (equal? '(guix store deduplication) module))))
 
   (with-imported-modules (source-module-closure
-                          `((guix build utils)
+                          `((guix build pack)
+                            (guix build utils)
                             (guix build union)
                             (gnu build install))
                           #:select? import-module?)
     #~(begin
-        (use-modules (guix build utils)
+        (use-modules (guix build pack)
+                     (guix build utils)
                      ((guix build union) #:select (relative-file-name))
                      (gnu build install)
                      (srfi srfi-1)
@@ -240,19 +242,10 @@ dependencies are registered."
           ;; Fully-qualified symlinks.
           (append-map symlink->directives '#$symlinks))
 
-        ;; The --sort option was added to GNU tar in version 1.28, released
-        ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
-        ;; older and doesn't support it.
-        (define tar-supports-sort?
-          (zero? (system* (string-append #+archiver "/bin/tar")
-                          "cf" "/dev/null" "--files-from=/dev/null"
-                          "--sort=name")))
-
         ;; Make sure non-ASCII file names are properly handled.
         #+set-utf8-locale
 
-        ;; Add 'tar' to the search path.
-        (setenv "PATH" #+(file-append archiver "/bin"))
+        (define tar #+(file-append archiver "/bin/tar"))
 
         ;; Note: there is not much to gain here with deduplication and there
         ;; is the overhead of the '.links' directory, so turn it off.
@@ -269,45 +262,33 @@ dependencies are registered."
         (for-each (cut evaluate-populate-directive <> %root)
                   directives)
 
-        ;; Create the tarball.  Use GNU format so there's no file name
-        ;; length limitation.
+        ;; Create the tarball.
         (with-directory-excursion %root
-          (apply invoke "tar"
-                 #+@(if (compressor-command compressor)
-                        #~("-I"
-                           (string-join
-                            '#+(compressor-command compressor)))
-                        #~())
-                 "--format=gnu"
-                 ;; Avoid non-determinism in the archive.
-                 ;; Use mtime = 1, not zero, because that is what the daemon
-                 ;; does for files in the store (see the 'mtimeStore' constant
-                 ;; in local-store.cc.)
-                 (if tar-supports-sort? "--sort=name" "--mtime=@1")
-                 "--owner=root:0"
-                 "--group=root:0"
-                 "--check-links"
-                 "-cvf" #$output
-                 ;; Avoid adding / and /var to the tarball, so
-                 ;; that the ownership and permissions of those
-                 ;; directories will not be overwritten when
-                 ;; extracting the archive.  Do not include /root
-                 ;; because the root account might have a
-                 ;; different home directory.
-                 #$@(if localstatedir?
-                        '("./var/guix")
-                        '())
-
-                 (string-append "." (%store-directory))
-
-                 (delete-duplicates
-                  (filter-map (match-lambda
-                                (('directory directory)
-                                 (string-append "." directory))
-                                ((source '-> _)
-                                 (string-append "." source))
-                                (_ #f))
-                              directives)))))))
+          (apply invoke tar
+                 `(,@(tar-base-options
+                      #:tar tar
+                      #:compressor '#+(and=> compressor compressor-command))
+                   "-cvf" ,#$output
+                   ;; Avoid adding / and /var to the tarball, so
+                   ;; that the ownership and permissions of those
+                   ;; directories will not be overwritten when
+                   ;; extracting the archive.  Do not include /root
+                   ;; because the root account might have a
+                   ;; different home directory.
+                   ,#$@(if localstatedir?
+                           '("./var/guix")
+                           '())
+
+                   ,(string-append "." (%store-directory))
+
+                   ,@(delete-duplicates
+                      (filter-map (match-lambda
+                                    (('directory directory)
+                                     (string-append "." directory))
+                                    ((source '-> _)
+                                     (string-append "." source))
+                                    (_ #f))
+                                  directives))))))))
 
 (define* (self-contained-tarball name profile
                                  #:key target
-- 
2.32.0





^ permalink raw reply related	[relevance 44%]

* [bug#42886] [PATCH 1/1] services: docker: Add 'enable-iptables?' argument.
  @ 2020-08-16  8:09 72% ` Alexey Abramov
  0 siblings, 0 replies; 149+ results
From: Alexey Abramov @ 2020-08-16  8:09 UTC (permalink / raw)
  To: 42886

* gnu/services/docker.scm (docker-configuration): Define the argument.
* gnu/services/docker.scm (docker-shepherd-service): Use it.

Signed-off-by: Alexey Abramov <levenson@mmer.org>
---
 gnu/services/docker.scm | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 937dff7bdb..98d9c4355b 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -56,7 +56,10 @@ loop-back communications.")
    "Enable or disable the user-land proxy (enabled by default).")
   (debug?
    (boolean #f)
-   "Enable or disable debug output."))
+   "Enable or disable debug output.")
+  (enable-iptables?
+   (boolean #t)
+   "Enable addition of iptables rules (enabled by default)"))
 
 (define %docker-accounts
   (list (user-group (name "docker") (system? #t))))
@@ -91,6 +94,7 @@ loop-back communications.")
 (define (docker-shepherd-service config)
   (let* ((docker (docker-configuration-docker config))
          (enable-proxy? (docker-configuration-enable-proxy? config))
+         (enable-iptables? (docker-configuration-enable-iptables? config))
          (proxy (docker-configuration-proxy config))
          (debug? (docker-configuration-debug? config)))
     (shepherd-service
@@ -115,7 +119,8 @@ loop-back communications.")
                                   '())
                            (if #$enable-proxy? "--userland-proxy" "")
                            "--userland-proxy-path" (string-append #$proxy
-                                                                  "/bin/proxy"))
+                                                                  "/bin/proxy")
+                           (if #$enable-iptables? "--iptables" "--iptables=false"))
                      #:pid-file "/var/run/docker.pid"
                      #:log-file "/var/log/docker.log"))
            (stop #~(make-kill-destructor)))))
-- 
2.27.0





^ permalink raw reply related	[relevance 72%]

* [bug#41695] [PATCH] Update Go to v1.14.4
  @ 2020-06-06 19:13 72%   ` Katherine Cox-Buday
  0 siblings, 0 replies; 149+ results
From: Katherine Cox-Buday @ 2020-06-06 19:13 UTC (permalink / raw)
  To: Jack Hill; +Cc: 41695

[-- Attachment #1: Type: text/plain, Size: 2765 bytes --]

Jack Hill <jackhill@jackhill.us> writes:

> Katherine,
>
> On Wed, 3 Jun 2020, Katherine Cox-Buday wrote:
>
>> There are too many dependent Go packages to test, but I compiled
>> syncthing which should be a reasonably representative test.
>
> Thanks for working on updating Go.
>
> I have rebuilt all the packages reported by `guix refresh -l go`. The
> three failures were stress-make, which was already broken (build log
> attached), mongodb-tools, which was already broken [0], and docker
> (build log attached).

You're welcome! Thanks for the review. I wish I had more time to
contribute to Guix.

I suppose I should have qualified my statement by saying there's too
many dependent Go packages for me to test. I should invest in a better
computer :)

> Reading through the Go release notes [1], the following change to the
> net/url package caught my eye:
>
>> When parsing of a URL fails (for example by Parse or
>> ParseRequestURI), the resulting Error message will now quote the
>> unparsable URL. This provides clearer structure and consistency with
>> other parsing errors.
>
> I think this could be the cause of the docker test failure. Should we
> patch docker or perhaps try to update it?

Spot on! I've updated docker and docker-cli. hyperledger-fabric depends
on docker-cli and also continues to build. I've attached a patch which
should supersede the prior patch. It updates go, docker, and docker-cli
atomically.

> Another item from the release notes about changes to the Go runtime:
>
>> A consequence of the implementation of preemption is that on Unix
>> systems, including Linux and macOS systems, programs built with Go
>> 1.14 will receive more signals than programs built with earlier
>> releases. This means that programs that use packages like syscall or
>> golang.org/x/sys/unix will see more slow system calls fail with
>> EINTR errors. Those programs will have to handle those errors in
>> some way, most likely looping to try the system call again. For more
>> information about this see man 7 signal for Linux systems or similar
>> documentation for other systems.
>
> I didn't notice any problems caused by this during package rebuilds
> and testing, but it sounds like something that could be difficult to
> write automated tests for, so we should probably be on the lookout for
> future problems at runtime.

Agreed.

> I'm happy to see that that the go modules changes didn't cause us any
> problems with this upgrade.

I believe 1.14 represents a stabilization of the modules feature, so I
would expect future updates to go smoothly as well.

> I am curious, why switch to using git-fetch?

`guix lint` now complains about downloading tarballs. I have also
recently seen some chatter on the mailing list about preferring this.


[-- Attachment #2: 0001-gnu-go-Update-to-1.14.4.patch --]
[-- Type: text/x-patch, Size: 7024 bytes --]

From 600f60e78a19eefc3ea1bf518d658fc8fc47fb36 Mon Sep 17 00:00:00 2001
From: Katherine Cox-Buday <cox.katherine.e@gmail.com>
Date: Wed, 3 Jun 2020 18:31:00 -0500
Subject: [PATCH] gnu: go: Update to 1.14.4.

* gnu/packages/golang.scm (go): Update to 1.14.4.
* gnu/packages/docker.scm (docker, docker-cli): Update to 19.03.11.
---
 gnu/packages/docker.scm | 19 ++++++++++++++++---
 gnu/packages/golang.scm | 27 +++++++++++++++++----------
 2 files changed, 33 insertions(+), 13 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index aeb43a6393..3dd706cbe9 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Michael Rohleder <mike@rohleder.de>
+;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,7 +48,7 @@
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages virtualization))
 
-(define %docker-version "19.03.9")
+(define %docker-version "19.03.11")
 
 (define-public python-docker-py
   (package
@@ -314,7 +315,7 @@ built-in registry server of Docker.")
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1a9hkprkix5d7lqi88r8svvfpzh1qbzw9nrkp11lxrcf9wdan4hg"))
+        (base32 "1pmbggxbazipl24hxiaccbj32379zv79xba76l78v5131ihx922h"))
        (patches
         (search-patches "docker-fix-tests.patch"))))
     (build-system gnu-build-system)
@@ -390,6 +391,17 @@ built-in registry server of Docker.")
              (substitute* "pkg/archive/archive.go"
                (("string\\{\"xz")
                 (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
+             ;; TODO: Remove when Docker proper uses v1.14.x to build
+             (substitute* "registry/resumable/resumablerequestreader_test.go"
+               (("I%27m%20not%20an%20url" all)
+                (string-append "\"" all "\"")))
+             ;; TODO: Remove when Docker proper uses v1.14.x to build
+             (substitute* "vendor/gotest.tools/x/subtest/context.go"
+               (("func \\(tc \\*testcase\\) Cleanup\\(" all)
+                (string-append all "func()"))
+               (("tc\\.Cleanup\\(" all)
+                (string-append all "nil")))
+
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
@@ -488,6 +500,7 @@ built-in registry server of Docker.")
              ;; Timeouts after 5 min.
              (delete-file "plugin/manager_linux_test.go")
              ;; Operation not permitted.
+             (delete-file "daemon/graphdriver/aufs/aufs_test.go")
              (delete-file "daemon/graphdriver/btrfs/btrfs_test.go")
              (delete-file "daemon/graphdriver/overlay/overlay_test.go")
              (delete-file "daemon/graphdriver/overlay2/overlay_test.go")
@@ -592,7 +605,7 @@ provisioning etc.")
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "1599ff7699p3m925rdyfg7gl3cga6gy0lli7qh2ybyiw2kwf4gj9"))))
+       (base32 "1y9ymv70r1hndblr64h19q34arxl2f3dqqi2qcrai5zfimcml6lr"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
diff --git a/gnu/packages/golang.scm b/gnu/packages/golang.scm
index ae0b7c6779..94fadd3302 100644
--- a/gnu/packages/golang.scm
+++ b/gnu/packages/golang.scm
@@ -12,7 +12,7 @@
 ;;; Copyright © 2018 Tomáš Čech <sleep_walker@gnu.org>
 ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
 ;;; Copyright © 2018 Pierre Neidhardt <mail@ambrevar.xyz>
-;;; Copyright @ 2018, 2019 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;; Copyright @ 2018, 2019, 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
 ;;; Copyright @ 2019 Giovanni Biscuolo <g@xelera.eu>
 ;;; Copyright @ 2019, 2020 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2019, 2020 Arun Isaac <arunisaac@systemreboot.net>
@@ -217,19 +217,21 @@ in the style of communicating sequential processes (@dfn{CSP}).")
     (supported-systems '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux"))
     (license license:bsd-3)))
 
-(define-public go-1.13
+(define-public go-1.14
   (package
     (inherit go-1.4)
     (name "go")
-    (version "1.13.9")
+    (version "1.14.4")
     (source
      (origin
-       (method url-fetch)
-       (uri (string-append "https://storage.googleapis.com/golang/"
-                           name version ".src.tar.gz"))
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/golang/go.git")
+             (commit (string-append "go" version))))
+       (file-name (git-file-name name version))
        (sha256
         (base32
-         "07gksk9194wa90xyd6yhagxfv7syvsx29bh8ypc4mg700vc1kfrl"))))
+         "08bazglmqp123c9dgrxflvxd011xsqfxsgah2kzbvca0mhm6qcm3"))))
     (arguments
      (substitute-keyword-arguments (package-arguments go-1.4)
        ((#:phases phases)
@@ -260,7 +262,13 @@ in the style of communicating sequential processes (@dfn{CSP}).")
                   '("cmd/go/testdata/script/mod_case_cgo.txt"
                     "cmd/go/testdata/script/list_find.txt"
                     "cmd/go/testdata/script/list_compiled_imports.txt"
-                    "cmd/go/testdata/script/cgo_syso_issue29253.txt"))
+                    "cmd/go/testdata/script/cgo_syso_issue29253.txt"
+                    "cmd/go/testdata/script/cover_cgo.txt"
+                    "cmd/go/testdata/script/cover_cgo_xtest.txt"
+                    "cmd/go/testdata/script/cover_cgo_extra_test.txt"
+                    "cmd/go/testdata/script/cover_cgo_extra_file.txt"))
+
+                 (for-each make-file-writable (find-files "."))
 
                  (substitute* "os/os_test.go"
                    (("/usr/bin") (getcwd))
@@ -359,7 +367,6 @@ in the style of communicating sequential processes (@dfn{CSP}).")
                  (setenv "GOROOT_FINAL" output)
                  (setenv "CGO_ENABLED" "1")
                  (invoke "sh" "all.bash"))))
-
            (replace 'install
              ;; TODO: Most of this could be factorized with Go 1.4.
              (lambda* (#:key outputs #:allow-other-keys)
@@ -405,7 +412,7 @@ in the style of communicating sequential processes (@dfn{CSP}).")
        ,@(package-native-inputs go-1.4)))
     (supported-systems %supported-systems)))
 
-(define-public go go-1.13)
+(define-public go go-1.14)
 
 (define-public go-github-com-alsm-ioprogress
   (let ((commit "063c3725f436e7fba0c8f588547bee21ffec7ac5")
-- 
2.26.2


[-- Attachment #3: Type: text/plain, Size: 15 bytes --]


-- 
Katherine

^ permalink raw reply related	[relevance 72%]

* [bug#40871] [PATCH] file-systems: mount the PID cgroup filesystem.
@ 2020-04-26 15:58 70% Jakub Kądziołka
  0 siblings, 0 replies; 149+ results
From: Jakub Kądziołka @ 2020-04-26 15:58 UTC (permalink / raw)
  To: 40871

* gnu/system/file-systems.scm (%control-groups): Add "pids".
* gnu/services/docker.scm (docker-shepherd-service): Resolve a TODO.

This has allowed me to make a specific configuration of nsjail work.
---
 gnu/services/docker.scm     | 3 ++-
 gnu/system/file-systems.scm | 3 ++-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 04f9127346..d6dc792821 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -94,7 +95,7 @@ loop-back communications.")
                           file-system-/sys/fs/cgroup/cpuset
                           file-system-/sys/fs/cgroup/devices
                           file-system-/sys/fs/cgroup/memory
-                          ; TODO: file-system-/sys/fs/cgroup/pids
+                          file-system-/sys/fs/cgroup/pids
                           networking
                           udev))
            (start #~(make-forkexec-constructor
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 3b599efa8e..b41f66e943 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -389,7 +390,7 @@ TARGET in the other system."
                    ;; parent directory.
                    (dependencies (list parent))))
                '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
-                 "blkio" "perf_event")))))
+                 "blkio" "perf_event" "pids")))))
 
 (define %elogind-file-systems
   ;; We don't use systemd, but these file systems are needed for elogind,
-- 
2.26.0

^ permalink raw reply related	[relevance 70%]

* [bug#40136] [PATCH] * gnu/packages/docker.scm (docker-compose): update to 1.25.4
@ 2020-03-19 18:54 80% Michael Rohleder
  0 siblings, 0 replies; 149+ results
From: Michael Rohleder @ 2020-03-19 18:54 UTC (permalink / raw)
  To: 40136


[-- Attachment #1.1: Type: text/plain, Size: 472 bytes --]


Fixes <https://bugs.gnu.org/40015>

I tested this only briefly. I could build and run containers from
compose files, so its at least less broken than before where one couldnt
even start docker-compose.

This doesnt need the old jsonschema-2.6 and seems to work with our
current 3.0.1 version, so we can remove it (as stated in the comment).

Now, I am wondering if we need all the python-request versions...


* gnu/packages/docker.scm (docker-compose): update to 1.25.4

[-- Attachment #1.2: [PATCH] * gnu/packages/docker.scm (docker-compose): update to 1.25.4 --]
[-- Type: text/x-patch, Size: 2162 bytes --]

From a234bbe7a61f9595ce4ecc0e6367496093f72788 Mon Sep 17 00:00:00 2001
From: Michael Rohleder <mike@rohleder.de>
Date: Thu, 19 Mar 2020 18:48:21 +0100
Subject: [PATCH] * gnu/packages/docker.scm (docker-compose): update to 1.25.4

---
 gnu/packages/docker.scm | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 7524a0dc1b..69dee2b856 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020 Michael Rohleder <mike@rohleder.de>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -98,19 +99,17 @@ pseudo-terminal (PTY) allocated to a Docker container using the Python
 client.")
     (license license:asl2.0)))
 
-;; When updating, check whether python-jsonschema-2.6 can be removed from Guix
-;; entirely.
 (define-public docker-compose
   (package
     (name "docker-compose")
-    (version "1.24.1")
+    (version "1.25.4")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "docker-compose" version))
        (sha256
         (base32
-         "0lx7bx6jvhydbab8vwry0bclhdf0dfj6jrns1m5y45yp9ybqxmd5"))))
+         "1ww8ckpj3n5jdg63qvmiqx3gk0fsrnynnnqj17fppymbwjzf5fps"))))
     (build-system python-build-system)
     ;; TODO: Tests require running Docker daemon.
     (arguments '(#:tests? #f))
@@ -120,9 +119,9 @@ client.")
        ("python-docker-py" ,python-docker-py)
        ("python-dockerpty" ,python-dockerpty)
        ("python-docopt" ,python-docopt)
-       ("python-jsonschema" ,python-jsonschema-2.6)
+       ("python-jsonschema" ,python-jsonschema)
        ("python-pyyaml" ,python-pyyaml)
-       ("python-requests" ,python-requests-2.20)
+       ("python-requests" ,python-requests)
        ("python-six" ,python-six)
        ("python-texttable" ,python-texttable)
        ("python-websocket-client" ,python-websocket-client)))
-- 
2.25.2


[-- Attachment #1.3: Type: text/plain, Size: 73 bytes --]


* gnu/packages/python-xyz.scm (python-jsonschema-2.6): remove variable.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.4: [PATCH] * gnu/packages/python-xyz.scm (python-jsonschema-2.6): remove variable. --]
[-- Type: text/x-patch, Size: 1856 bytes --]

From 69518dd1935db9ad58e43572688e8d72d645f501 Mon Sep 17 00:00:00 2001
From: Michael Rohleder <mike@rohleder.de>
Date: Thu, 19 Mar 2020 18:56:58 +0100
Subject: [PATCH] * gnu/packages/python-xyz.scm (python-jsonschema-2.6): remove
 variable.

---
 gnu/packages/python-xyz.scm | 26 --------------------------
 1 file changed, 26 deletions(-)

diff --git a/gnu/packages/python-xyz.scm b/gnu/packages/python-xyz.scm
index 07199aa7ca..8271e1ff7e 100644
--- a/gnu/packages/python-xyz.scm
+++ b/gnu/packages/python-xyz.scm
@@ -2306,32 +2306,6 @@ compare, diff, and patch JSON and JSON-like structures in Python.")
               `(("python2-functools32" ,python2-functools32)
                 ,@(package-propagated-inputs jsonschema))))))
 
-;; This old version is still required by docker-compose as of 1.24.0.
-(define-public python-jsonschema-2.6
-  (package
-    (name "python-jsonschema")
-    (version "2.6.0")
-    (source (origin
-             (method url-fetch)
-             (uri (pypi-uri "jsonschema" version))
-             (sha256
-              (base32
-               "00kf3zmpp9ya4sydffpifn0j0mzm342a2vzh82p6r0vh10cg7xbg"))))
-    (build-system python-build-system)
-    (arguments
-     '(#:phases
-       (modify-phases %standard-phases
-         (replace 'check (lambda _ (invoke "nosetests"))))))
-    (native-inputs
-     `(("python-nose" ,python-nose)
-       ("python-vcversioner" ,python-vcversioner)))
-    (home-page "https://github.com/Julian/jsonschema")
-    (synopsis "Implementation of JSON Schema for Python")
-    (description
-     "Jsonschema is an implementation of JSON Schema for Python.")
-    (license license:expat)
-    (properties `((python2-variant . ,(delay python2-jsonschema))))))
-
 (define-public python-schema
   (package
     (name "python-schema")
-- 
2.25.2


[-- Attachment #1.5: Type: text/plain, Size: 135 bytes --]


-- 
Perfection (in design) is achieved not when there is nothing more to
add, but rather when there is nothing more to take away.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 487 bytes --]

^ permalink raw reply related	[relevance 80%]

* [bug#39581] [PATCH] gnu: containerd: Fix test failure with Go 1.13
@ 2020-02-12 20:33 65% Jack Hill
  0 siblings, 0 replies; 149+ results
From: Jack Hill @ 2020-02-12 20:33 UTC (permalink / raw)
  To: 39581; +Cc: Jack Hill

* gnu/packages/docker.scm (containerd)[source]: Add patch.
* gnu/packages/patches/containerd-test-with-go1.13.patch: New file.
* gnu/local.mk (dist_patch_DATA): Add patch.
---
 gnu/local.mk                                  |  1 +
 gnu/packages/docker.scm                       |  4 +++-
 .../patches/containerd-test-with-go1.13.patch | 21 +++++++++++++++++++
 3 files changed, 25 insertions(+), 1 deletion(-)
 create mode 100644 gnu/packages/patches/containerd-test-with-go1.13.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index 3f8fa2ed7b..0efb53f416 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -794,6 +794,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/coda-use-system-libs.patch		\
   %D%/packages/patches/combinatorial-blas-awpm.patch		\
   %D%/packages/patches/combinatorial-blas-io-fix.patch		\
+  %D%/packages/patches/containerd-test-with-go1.13.patch		\
   %D%/packages/patches/cpufrequtils-fix-aclocal.patch		\
   %D%/packages/patches/crawl-upgrade-saves.patch		\
   %D%/packages/patches/crda-optional-gcrypt.patch		\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 1f832a25e5..cc353fd11f 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -183,7 +183,9 @@ Python without keeping their credentials in a Docker configuration file.")
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "0npbzixf3c0jvzm159vygvkydrr8h36c9sq50yv0mdinrys2bvg0"))))
+       (base32 "0npbzixf3c0jvzm159vygvkydrr8h36c9sq50yv0mdinrys2bvg0"))
+      (patches
+        (search-patches "containerd-test-with-go1.13.patch"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/containerd/containerd"
diff --git a/gnu/packages/patches/containerd-test-with-go1.13.patch b/gnu/packages/patches/containerd-test-with-go1.13.patch
new file mode 100644
index 0000000000..964adee9e6
--- /dev/null
+++ b/gnu/packages/patches/containerd-test-with-go1.13.patch
@@ -0,0 +1,21 @@
+Compatibility fix for go 1.13, flag.Parse() shouldn't be called during
+package initialization.
+https://golang.org/doc/go1.13#testing
+--- a/client_test.go	2020-02-12 14:50:28.991245371 -0500
++++ b/client_test.go	2020-02-12 15:12:37.383523980 -0500
+@@ -49,7 +49,6 @@
+ 	flag.StringVar(&address, "address", defaultAddress, "The address to the containerd socket for use in the tests")
+ 	flag.BoolVar(&noDaemon, "no-daemon", false, "Do not start a dedicated daemon for the tests")
+ 	flag.BoolVar(&noCriu, "no-criu", false, "Do not run the checkpoint tests")
+-	flag.Parse()
+ }
+ 
+ func testContext() (context.Context, context.CancelFunc) {
+@@ -59,6 +58,7 @@
+ }
+ 
+ func TestMain(m *testing.M) {
++	flag.Parse()
+ 	if testing.Short() {
+ 		os.Exit(m.Run())
+ 	}
-- 
2.25.0

^ permalink raw reply related	[relevance 65%]

* [bug#38885] [WIP 4/4] gnu: docker: Update to 19.03.5.
  @ 2020-01-03  1:34 75%   ` Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2020-01-03  1:34 UTC (permalink / raw)
  To: 38885; +Cc: Danny Milosavljevic

* gnu/packages/docker.scm (docker-cli): Update to 19.03.5.
(docker)[source]: Remove patches.
[arguments]<#:phases>[patch-paths]: Modify.
[native-inputs]: Add gotestsum.
* gnu/packages/patches/docker-adjust-tests-for-changes-in-go.patch: Delete
file.
* gnu/packages/patches/docker-engine-test-noinstall.patch: Delete file.
* gnu/packages/patches/docker-use-fewer-modprobes.patch: Delete file.
* gnu/local.mk (dist_patch_DATA): Remove them.
---
 gnu/local.mk                                  |   3 -
 gnu/packages/docker.scm                       |  13 +-
 ...ocker-adjust-tests-for-changes-in-go.patch |  67 ---------
 .../docker-engine-test-noinstall.patch        |  23 ---
 .../patches/docker-use-fewer-modprobes.patch  | 137 ------------------
 5 files changed, 6 insertions(+), 237 deletions(-)
 delete mode 100644 gnu/packages/patches/docker-adjust-tests-for-changes-in-go.patch
 delete mode 100644 gnu/packages/patches/docker-engine-test-noinstall.patch
 delete mode 100644 gnu/packages/patches/docker-use-fewer-modprobes.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index 8a21223de5..0edd17e9b1 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -804,10 +804,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/docbook-xsl-nonrecursive-string-subst.patch	\
   %D%/packages/patches/doc++-include-directives.patch		\
   %D%/packages/patches/doc++-segfault-fix.patch			\
-  %D%/packages/patches/docker-adjust-tests-for-changes-in-go.patch	\
-  %D%/packages/patches/docker-engine-test-noinstall.patch	\
   %D%/packages/patches/docker-fix-tests.patch			\
-  %D%/packages/patches/docker-use-fewer-modprobes.patch		\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/doxygen-test.patch			\
   %D%/packages/patches/dstat-fix-crash-when-specifying-delay.patch	\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 948cc30cf6..a15c5d6004 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -46,7 +46,7 @@
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages virtualization))
 
-(define %docker-version "18.09.5")
+(define %docker-version "19.03.5")
 
 (define-public python-docker-py
   (package
@@ -313,12 +313,9 @@ built-in registry server of Docker.")
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0cirpd9l2qazp2jyanwzvrkx2m98nksjdvn43ff38p89w6133ipb"))
+        (base32 "1dlknwn0fh82nbzdzxdk6pfhqwph9vcw3vs3111wfr19y5hwncq9"))
        (patches
-        (search-patches "docker-engine-test-noinstall.patch"
-                        "docker-fix-tests.patch"
-                        "docker-use-fewer-modprobes.patch"
-                        "docker-adjust-tests-for-changes-in-go.patch"))))
+        (search-patches "docker-fix-tests.patch"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -419,6 +416,7 @@ built-in registry server of Docker.")
                                                   "/" relative-path
                                                   "\"")) ...)))))
                  (substitute-LookPath*
+                  ("containerd" "containerd" "bin/containerd")
                   ("ps" "procps" "bin/ps")
                   ("mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
                   ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
@@ -558,6 +556,7 @@ built-in registry server of Docker.")
     (native-inputs
      `(("eudev" ,eudev)      ; TODO: Should be propagated by lvm2 (.pc -> .pc)
        ("go" ,go)
+       ("gotestsum" ,gotestsum)
        ("pkg-config" ,pkg-config)))
     (synopsis "Docker container component library, and daemon")
     (description "This package provides a framework to assemble specialized
@@ -579,7 +578,7 @@ provisioning etc.")
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
-       (base32 "0mxxjzkwdny8p2dmyjich7x1gn7hdlfppzjy2skk2k5bwv7nxpmi"))))
+       (base32 "07ldz46y74b3la4ah65v5bzbfx09yy6kncvxrr0zfx0s1214ar3m"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
diff --git a/gnu/packages/patches/docker-adjust-tests-for-changes-in-go.patch b/gnu/packages/patches/docker-adjust-tests-for-changes-in-go.patch
deleted file mode 100644
index 82d92cd4de..0000000000
--- a/gnu/packages/patches/docker-adjust-tests-for-changes-in-go.patch
+++ /dev/null
@@ -1,67 +0,0 @@
-From 4983ef7c1693ad6dfbe4e3809b12541241d7ff56 Mon Sep 17 00:00:00 2001
-From: Sebastiaan van Stijn <github@gone.nl>
-Date: Wed, 14 Aug 2019 02:51:08 +0200
-Subject: [PATCH] Adjust tests for changes in Go 1.12.8 / 1.11.13
-
-```
-00:38:11 === Failed
-00:38:11 === FAIL: opts TestParseDockerDaemonHost (0.00s)
-00:38:11     hosts_test.go:87: tcp tcp:a.b.c.d address expected error "Invalid bind address format: tcp:a.b.c.d" return, got "parse tcp://tcp:a.b.c.d: invalid port \":a.b.c.d\" after host" and addr
-00:38:11     hosts_test.go:87: tcp tcp:a.b.c.d/path address expected error "Invalid bind address format: tcp:a.b.c.d/path" return, got "parse tcp://tcp:a.b.c.d/path: invalid port \":a.b.c.d\" after host" and addr
-00:38:11
-00:38:11 === FAIL: opts TestParseTCP (0.00s)
-00:38:11     hosts_test.go:129: tcp tcp:a.b.c.d address expected error Invalid bind address format: tcp:a.b.c.d return, got parse tcp://tcp:a.b.c.d: invalid port ":a.b.c.d" after host and addr
-00:38:11     hosts_test.go:129: tcp tcp:a.b.c.d/path address expected error Invalid bind address format: tcp:a.b.c.d/path return, got parse tcp://tcp:a.b.c.d/path: invalid port ":a.b.c.d" after host and addr
-```
-
-Signed-off-by: Sebastiaan van Stijn <github@gone.nl>
-Upstream-commit: 683766613a8c1dca8f95b19ddb7e083bb3aef266
-Component: engine
----
- opts/hosts_test.go | 12 ++++++------
- 1 file changed, 6 insertions(+), 6 deletions(-)
-
-diff --git a/opts/hosts_test.go b/opts/hosts_test.go
-index 8c54ec0f4b..7a0a943adf 100644
---- a/opts/hosts_test.go
-+++ b/opts/hosts_test.go
-@@ -53,8 +53,8 @@ func TestParseHost(t *testing.T) {
- func TestParseDockerDaemonHost(t *testing.T) {
- 	invalids := map[string]string{
- 
--		"tcp:a.b.c.d":                   "Invalid bind address format: tcp:a.b.c.d",
--		"tcp:a.b.c.d/path":              "Invalid bind address format: tcp:a.b.c.d/path",
-+		"tcp:a.b.c.d":                   "",
-+		"tcp:a.b.c.d/path":              "",
- 		"udp://127.0.0.1":               "Invalid bind address format: udp://127.0.0.1",
- 		"udp://127.0.0.1:2375":          "Invalid bind address format: udp://127.0.0.1:2375",
- 		"tcp://unix:///run/docker.sock": "Invalid proto, expected tcp: unix:///run/docker.sock",
-@@ -83,7 +83,7 @@ func TestParseDockerDaemonHost(t *testing.T) {
- 		"localhost:5555/path":         "tcp://localhost:5555/path",
- 	}
- 	for invalidAddr, expectedError := range invalids {
--		if addr, err := parseDaemonHost(invalidAddr); err == nil || err.Error() != expectedError {
-+		if addr, err := parseDaemonHost(invalidAddr); err == nil || expectedError != "" && err.Error() != expectedError {
- 			t.Errorf("tcp %v address expected error %q return, got %q and addr %v", invalidAddr, expectedError, err, addr)
- 		}
- 	}
-@@ -99,8 +99,8 @@ func TestParseTCP(t *testing.T) {
- 		defaultHTTPHost = "tcp://127.0.0.1:2376"
- 	)
- 	invalids := map[string]string{
--		"tcp:a.b.c.d":          "Invalid bind address format: tcp:a.b.c.d",
--		"tcp:a.b.c.d/path":     "Invalid bind address format: tcp:a.b.c.d/path",
-+		"tcp:a.b.c.d":          "",
-+		"tcp:a.b.c.d/path":     "",
- 		"udp://127.0.0.1":      "Invalid proto, expected tcp: udp://127.0.0.1",
- 		"udp://127.0.0.1:2375": "Invalid proto, expected tcp: udp://127.0.0.1:2375",
- 	}
-@@ -125,7 +125,7 @@ func TestParseTCP(t *testing.T) {
- 		"localhost:5555/path":         "tcp://localhost:5555/path",
- 	}
- 	for invalidAddr, expectedError := range invalids {
--		if addr, err := ParseTCPAddr(invalidAddr, defaultHTTPHost); err == nil || err.Error() != expectedError {
-+		if addr, err := ParseTCPAddr(invalidAddr, defaultHTTPHost); err == nil || expectedError != "" && err.Error() != expectedError {
- 			t.Errorf("tcp %v address expected error %v return, got %s and addr %v", invalidAddr, expectedError, err, addr)
- 		}
- 	}
diff --git a/gnu/packages/patches/docker-engine-test-noinstall.patch b/gnu/packages/patches/docker-engine-test-noinstall.patch
deleted file mode 100644
index 85d56a3465..0000000000
--- a/gnu/packages/patches/docker-engine-test-noinstall.patch
+++ /dev/null
@@ -1,23 +0,0 @@
-Last-Update: 2018-06-18
-Forwarded: not-needed
-Author: Dmitry Smirnov <onlyjob@debian.org>
-Description: prevents test-time installation that causes FTBFS.
-~~~~
- go test net: open /usr/lib/go-1.10/pkg/linux_amd64/net.a: permission denied
-~~~~
-
---- a/hack/test/unit
-+++ b/hack/test/unit
-@@ -18,12 +18,8 @@
- 
- exclude_paths="/vendor/|/integration"
- pkg_list=$(go list $TESTDIRS | grep -vE "($exclude_paths)")
- 
--# install test dependencies once before running tests for each package. This
--# significantly reduces the runtime.
--go test -i "${BUILDFLAGS[@]}" $pkg_list
--
- for pkg in $pkg_list; do
-     go test "${BUILDFLAGS[@]}" \
-         -cover \
-         -coverprofile=profile.out \
diff --git a/gnu/packages/patches/docker-use-fewer-modprobes.patch b/gnu/packages/patches/docker-use-fewer-modprobes.patch
deleted file mode 100644
index 4e4a45b6ce..0000000000
--- a/gnu/packages/patches/docker-use-fewer-modprobes.patch
+++ /dev/null
@@ -1,137 +0,0 @@
-This patch makes docker find out whether a filesystem type is supported
-by trying to mount a filesystem of that type rather than invoking "modprobe".
-
-See <https://github.com/moby/moby/pull/38930>.
-
---- docker-18.09.0-checkout/daemon/graphdriver/overlay/overlay.go.orig	1970-01-01 01:00:00.000000000 +0100
-+++ docker-18.09.0-checkout/daemon/graphdriver/overlay/overlay.go	2019-03-19 09:16:03.487087490 +0100
-@@ -8,7 +8,6 @@
- 	"io"
- 	"io/ioutil"
- 	"os"
--	"os/exec"
- 	"path"
- 	"path/filepath"
- 	"strconv"
-@@ -201,9 +200,16 @@
- }
- 
- func supportsOverlay() error {
--	// We can try to modprobe overlay first before looking at
--	// proc/filesystems for when overlay is supported
--	exec.Command("modprobe", "overlay").Run()
-+	// Access overlay filesystem so that Linux loads it (if possible).
-+	mountTarget, err := ioutil.TempDir("", "supportsOverlay")
-+	if err != nil {
-+		logrus.WithField("storage-driver", "overlay2").Error("Could not create temporary directory, so assuming that 'overlay' is not supported.")
-+		return graphdriver.ErrNotSupported
-+	} else {
-+		/* The mounting will fail--after the module has been loaded.*/
-+		defer os.RemoveAll(mountTarget)
-+		unix.Mount("overlay", mountTarget, "overlay", 0, "")
-+	}
- 
- 	f, err := os.Open("/proc/filesystems")
- 	if err != nil {
---- docker-18.09.0-checkout/daemon/graphdriver/overlay2/overlay.go.orig	2019-03-18 23:42:23.728525231 +0100
-+++ docker-18.09.0-checkout/daemon/graphdriver/overlay2/overlay.go	2019-03-19 08:54:31.411906113 +0100
-@@ -10,7 +10,6 @@
- 	"io"
- 	"io/ioutil"
- 	"os"
--	"os/exec"
- 	"path"
- 	"path/filepath"
- 	"strconv"
-@@ -261,9 +260,16 @@
- }
- 
- func supportsOverlay() error {
--	// We can try to modprobe overlay first before looking at
--	// proc/filesystems for when overlay is supported
--	exec.Command("modprobe", "overlay").Run()
-+	// Access overlay filesystem so that Linux loads it (if possible).
-+	mountTarget, err := ioutil.TempDir("", "supportsOverlay2")
-+	if err != nil {
-+		logrus.WithField("storage-driver", "overlay2").Error("Could not create temporary directory, so assuming that 'overlay' is not supported.")
-+		return graphdriver.ErrNotSupported
-+	} else {
-+		/* The mounting will fail--after the module has been loaded.*/
-+		defer os.RemoveAll(mountTarget)
-+		unix.Mount("overlay", mountTarget, "overlay", 0, "")
-+	}
- 
- 	f, err := os.Open("/proc/filesystems")
- 	if err != nil {
---- docker-18.09.0-checkout/daemon/graphdriver/devmapper/deviceset.go.orig	2019-03-19 09:19:16.592844887 +0100
-+++ docker-18.09.0-checkout/daemon/graphdriver/devmapper/deviceset.go	2019-03-19 09:21:18.019361761 +0100
-@@ -540,8 +539,14 @@
- 		return err // error text is descriptive enough
- 	}
- 
--	// Check if kernel supports xfs filesystem or not.
--	exec.Command("modprobe", "xfs").Run()
-+	mountTarget, err := ioutil.TempDir("", "supportsXFS")
-+	if err != nil {
-+		return errors.Wrapf(err, "error checking for xfs support")
-+	} else {
-+		/* The mounting will fail--after the module has been loaded.*/
-+		defer os.RemoveAll(mountTarget)
-+		unix.Mount("none", mountTarget, "xfs", 0, "")
-+	}
- 
- 	f, err := os.Open("/proc/filesystems")
- 	if err != nil {
---- docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/iptables/iptables.go.orig	2019-03-19 09:47:19.430111170 +0100
-+++ docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/iptables/iptables.go	2019-03-19 10:38:01.445136177 +0100
-@@ -72,11 +71,12 @@
- }
- 
- func probe() {
--	if out, err := exec.Command("modprobe", "-va", "nf_nat").CombinedOutput(); err != nil {
--		logrus.Warnf("Running modprobe nf_nat failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
-+	path, err := exec.LookPath("iptables")
-+	if err != nil {
-+		return
- 	}
--	if out, err := exec.Command("modprobe", "-va", "xt_conntrack").CombinedOutput(); err != nil {
--		logrus.Warnf("Running modprobe xt_conntrack failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
-+	if out, err := exec.Command(path, "--wait", "-t", "nat", "-L", "-n").CombinedOutput(); err != nil {
-+		logrus.Warnf("Running iptables --wait -t nat -L -n failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
- 	}
- }
- 
---- docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/ns/init_linux.go.orig	2019-03-19 11:23:20.738316699 +0100
-+++ docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/ns/init_linux.go	2019-03-19 11:27:57.149753073 +0100
-@@ -76,12 +76,8 @@ func NlHandle() *netlink.Handle {
- func getSupportedNlFamilies() []int {
- 	fams := []int{syscall.NETLINK_ROUTE}
- 	// NETLINK_XFRM test
--	if err := loadXfrmModules(); err != nil {
--		if checkXfrmSocket() != nil {
--			logrus.Warnf("Could not load necessary modules for IPSEC rules: %v", err)
--		} else {
--			fams = append(fams, syscall.NETLINK_XFRM)
--		}
-+	if err := checkXfrmSocket(); err != nil {
-+		logrus.Warnf("Could not load necessary modules for IPSEC rules: %v", err)
- 	} else {
- 		fams = append(fams, syscall.NETLINK_XFRM)
- 	}
-@@ -99,16 +95,6 @@ func getSupportedNlFamilies() []int {
- 	return fams
- }
- 
--func loadXfrmModules() error {
--	if out, err := exec.Command("modprobe", "-va", "xfrm_user").CombinedOutput(); err != nil {
--		return fmt.Errorf("Running modprobe xfrm_user failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
--	}
--	if out, err := exec.Command("modprobe", "-va", "xfrm_algo").CombinedOutput(); err != nil {
--		return fmt.Errorf("Running modprobe xfrm_algo failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
--	}
--	return nil
--}
--
- // API check on required xfrm modules (xfrm_user, xfrm_algo)
- func checkXfrmSocket() error {
- 	fd, err := syscall.Socket(syscall.AF_NETLINK, syscall.SOCK_RAW, syscall.NETLINK_XFRM)

^ permalink raw reply related	[relevance 75%]

* [bug#37401] [PATCH 1/2] pack: Provide a meaningful "repository name" for Docker.
  @ 2019-09-13 15:51 55% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-09-13 15:51 UTC (permalink / raw)
  To: 37401; +Cc: Ludovic Courtès

From: Ludovic Courtès <ludovic.courtes@inria.fr>

Previously, images produced by 'guix pack -f docker' would always show
up as "profile" in the output of 'docker images'.  With this change,
'docker images' shows a name constructed from the packages found in the
image--e.g., "bash-coreutils-grep-sed".

* guix/docker.scm (canonicalize-repository-name): New procedure.
(generate-tag): Remove.
(manifest): Add optional 'tag' parameter and honor it.
(repositories): Likewise.
(build-docker-image): Add #:repository parameter and pass it to
'manifest' and 'repositories'.
* guix/scripts/pack.scm (docker-image)[build]: Compute 'tag' and pass it
as #:repository to 'build-docker-image'.
---
 guix/docker.scm       | 43 ++++++++++++++++++++++++++++++-------------
 guix/scripts/pack.scm | 13 +++++++++++++
 2 files changed, 43 insertions(+), 13 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 757bdeb458..97ac6d982b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -57,22 +57,36 @@
     (created . ,time)
     (container_config . #nil)))
 
-(define (generate-tag path)
-  "Generate an image tag for the given PATH."
-  (match (string-split (basename path) #\-)
-    ((hash name . rest) (string-append name ":" hash))))
+(define (canonicalize-repository-name name)
+  "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+Return a version of TAG that follows these rules."
+  (define ascii-letters
+    (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 
-(define (manifest path id)
+  (define separators
+    (string->char-set "_-."))
+
+  (define repo-char-set
+    (char-set-union char-set:digit ascii-letters separators))
+
+  (string-map (lambda (chr)
+                (if (char-set-contains? repo-char-set chr)
+                    chr
+                    #\.))
+              (string-trim (string-downcase name) separators)))
+
+(define* (manifest path id #:optional (tag "guix"))
   "Generate a simple image manifest."
-  `#(((Config . "config.json")
-      (RepoTags . #(,(generate-tag path)))
-      (Layers . #(,(string-append id "/layer.tar"))))))
+  (let ((tag (canonicalize-repository-name tag)))
+    `#(((Config . "config.json")
+        (RepoTags . #(,(string-append tag ":latest")))
+        (Layers . #(,(string-append id "/layer.tar")))))))
 
 ;; According to the specifications this is required for backwards
 ;; compatibility.  It duplicates information provided by the manifest.
-(define (repositories path id)
+(define* (repositories path id #:optional (tag "guix"))
   "Generate a repositories file referencing PATH and the image ID."
-  `((,(generate-tag path) . ((latest . ,id)))))
+  `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
 (define* (config layer time arch #:key entry-point (environment '()))
@@ -112,6 +126,7 @@
 
 (define* (build-docker-image image paths prefix
                              #:key
+                             (repository "guix")
                              (extra-files '())
                              (transformations '())
                              (system (utsname:machine (uname)))
@@ -121,7 +136,9 @@
                              compressor
                              (creation-time (current-time time-utc)))
   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
-must be a store path that is a prefix of any store paths in PATHS.
+must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
+is a descriptive name that will show up in \"REPOSITORY\" column of the output
+of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -243,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata."
                              #:entry-point entry-point))))
       (with-output-to-file "manifest.json"
         (lambda ()
-          (scm->json (manifest prefix id))))
+          (scm->json (manifest prefix id repository))))
       (with-output-to-file "repositories"
         (lambda ()
-          (scm->json (repositories prefix id)))))
+          (scm->json (repositories prefix id repository)))))
 
     (apply invoke "tar" "-cf" image "-C" directory
            `(,@%tar-determinism-options
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index dd91a24284..ed8c177055 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -516,6 +516,18 @@ the image."
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
+            (define tag
+              ;; Compute a meaningful "repository" name, which will show up in
+              ;; the output of "docker images".
+              (let ((manifest (profile-manifest #$profile)))
+                (let loop ((names (map manifest-entry-name
+                                       (manifest-entries manifest))))
+                  (define str (string-join names "-"))
+                  (if (< (string-length str) 40)
+                      str
+                      (match names
+                        ((_) str)
+                        ((names ... _) (loop names))))))) ;drop one entry
 
             (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -524,6 +536,7 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
+                                #:repository tag
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:environment environment
-- 
2.23.0

^ permalink raw reply related	[relevance 55%]

* [bug#37250] [PATCH] gnu: docker: Add support for tini.
@ 2019-09-01  9:44 99% Maxim Cournoyer
  0 siblings, 0 replies; 149+ results
From: Maxim Cournoyer @ 2019-09-01  9:44 UTC (permalink / raw)
  To: 37250


[-- Attachment #1.1: Type: text/plain, Size: 84 bytes --]

Hello!

This enables the use of the --init argument for example with 'docker
run'.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-gnu-Add-tini.patch --]
[-- Type: text/x-patch, Size: 2531 bytes --]

From fdf8690097a236ce5799b70cf4e43ccf7e420022 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 29 Aug 2019 10:01:11 +0900
Subject: [PATCH 1/2] gnu: Add tini.

* gnu/packages/docker.scm (tini): New variable.
---
 gnu/packages/docker.scm | 34 ++++++++++++++++++++++++++++++++++
 1 file changed, 34 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 94cfa2bdb7..8f80cd54d8 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -25,6 +25,7 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system cmake)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
@@ -655,3 +656,36 @@ provisioning etc.")
 way to run commands in the current directory, but within a Docker container
 defined in a per-project configuration file.")
     (license license:gpl3+)))
+
+(define-public tini
+  (package
+    (name "tini")
+    (version "0.18.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/krallin/tini.git")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1h20i3wwlbd8x4jr2gz68hgklh0lb0jj7y5xk1wvr8y58fip1rdn"))))
+    (build-system cmake-build-system)
+    (arguments
+     `(#:tests? #f                    ;tests require a Docker daemon
+       #:phases (modify-phases %standard-phases
+                  (add-after 'unpack 'disable-static-build
+                    ;; Disable the static build as it fails to install, with
+                    ;; the error: "No valid ELF RPATH or RUNPATH entry exists
+                    ;; in the file".
+                    (lambda _
+                      (substitute* "CMakeLists.txt"
+                        ((".*tini-static.*") ""))
+                      #t)))))
+    (home-page "https://github.com/krallin/tini")
+    (synopsis "Tiny but valid init for containers")
+    (description "Tini is an init program specifically designed for use with
+containers.  It manages a single child process and ensures that any zombie
+processes produced from it are reaped and that signals are properly forwarded.
+Tini is integrated with Docker.")
+    (license license:expat)))
-- 
2.23.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.3: 0002-gnu-docker-Add-support-for-tini.patch --]
[-- Type: text/x-patch, Size: 1925 bytes --]

From eb575e31612d89763454eb82bbfd64f87d74be9c Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 29 Aug 2019 10:01:43 +0900
Subject: [PATCH 2/2] gnu: docker: Add support for tini.

* gnu/packages/docker.scm (docker)[inputs]: Add tini.
[phases]{patch-paths}: Patch the path of the default init binary.
---
 gnu/packages/docker.scm | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 8f80cd54d8..28eff0a56c 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -369,7 +369,16 @@ built-in registry server of Docker.")
                (("StockRuntimeName = .*")
                 (string-append "StockRuntimeName = \""
                                (assoc-ref inputs "runc")
-                               "/sbin/runc\"\n")))
+                               "/sbin/runc\"\n"))
+               (("DefaultInitBinary = .*")
+                (string-append "DefaultInitBinary = \""
+                               (assoc-ref inputs "tini")
+                               "/bin/tini\"\n")))
+             (substitute* "daemon/config/config_common_unix_test.go"
+               (("expectedInitPath: \"docker-init\"")
+                (string-append "expectedInitPath: \""
+                               (assoc-ref inputs "tini")
+                               "/bin/tini\"")))
              (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
                (("var defaultCommandCandidates = .*")
                 (string-append "var defaultCommandCandidates = []string{\""
@@ -542,6 +551,7 @@ built-in registry server of Docker.")
        ("runc" ,runc)
        ("util-linux" ,util-linux)
        ("lvm2" ,lvm2)
+       ("tini" ,tini)
        ("xfsprogs" ,xfsprogs)
        ("xz" ,xz)))
     (native-inputs
-- 
2.23.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 99%]

* [bug#37234] [PATCH 06/21] gnu: python-docker-py: Propagate runtime dependency.
  @ 2019-08-30 14:25 72% ` Marius Bakke
  0 siblings, 0 replies; 149+ results
From: Marius Bakke @ 2019-08-30 14:25 UTC (permalink / raw)
  To: 37234

* gnu/packages/docker.scm (python-docker-py)[inputs]: Move
PYTHON-WEBSOCKET-CLIENT from here ...
[propagated-inputs]: ... to here.
---
 gnu/packages/docker.scm | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 94cfa2bdb7..bf83c96e7b 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -65,11 +65,11 @@
      `(("python-requests" ,python-requests-2.20)
        ("python-ipaddress" ,python-ipaddress)
        ("python-six" ,python-six)
-       ("python-urllib3" ,python-urllib3-1.24)
-       ("python-websocket-client" ,python-websocket-client)))
+       ("python-urllib3" ,python-urllib3-1.24)))
     (propagated-inputs
      `(("python-docker-pycreds" ,python-docker-pycreds)
-       ("python-paramiko" ,python-paramiko))) ; adds SSH support
+       ("python-paramiko" ,python-paramiko) ;adds SSH support
+       ("python-websocket-client" ,python-websocket-client))) ;imported by api/client.py
     (home-page "https://github.com/docker/docker-py/")
     (synopsis "Python client for Docker")
     (description "Docker-Py is a Python client for the Docker container
-- 
2.22.1

^ permalink raw reply related	[relevance 72%]

* [bug#36760] [PATCH 1/3] maint: Switch to Guile-JSON 3.x.
  @ 2019-07-22 10:18 24% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-07-22 10:18 UTC (permalink / raw)
  To: 36760

* m4/guix.m4 (GUIX_CHECK_GUILE_JSON): New macro.
* configure.ac: Use it.
* doc/guix.texi (Requirements): Mention the Guile-JSON version.
* guix/git-download.scm (git-fetch)[guile-json]: Use GUILE-JSON-3.
* guix/import/cpan.scm (string->license): Expect vectors instead of
lists.
(module->dist-name): Use 'json-fetch' instead of 'json-fetch-alist'.
(cpan-fetch): Likewise.
* guix/import/crate.scm (crate-fetch): Likewise, and call 'vector->list'
for DEPS.
* guix/import/gem.scm (rubygems-fetch): Likewise.
* guix/import/json.scm (json-fetch-alist): Remove.
* guix/import/pypi.scm (pypi-fetch): Use 'json-fetch' instead of
'json-fetch-alist'.
(latest-source-release, latest-wheel-release): Call 'vector->list' on
RELEASES.
* guix/import/stackage.scm (stackage-lts-info-fetch): Use 'json-fetch'
instead of 'json-fetch-alist'.
(lts-package-version): Use 'vector->list'.
* guix/import/utils.scm (hash-table->alist): Remove.
(alist->package): Pass 'vector->list' on the inputs fields, and default
to the empty vector.
* guix/scripts/import/json.scm (guix-import-json): Remove call to
'hash-table->alist'.
* guix/swh.scm (define-json-reader): Expect pair? or null? instead of
hash-table?.
[extract-field]: Use 'assoc-ref' instead of 'hash-ref'.
(json->branches): Use 'map' instead of 'hash-map->list'.
(json->checksums): Likewise.
(json->directory-entries, origin-visits): Call 'vector->list' on the
result of 'json->scm'.
* tests/import-utils.scm ("alist->package with dependencies"): New test.
* gnu/installer.scm (build-compiled-file)[builder]: Use GUILE-JSON-3.
* gnu/installer.scm (installer-program)[installer-builder]: Likewise.
* gnu/installer/locale.scm (iso639->iso639-languages): Use 'assoc-ref'
instead of 'hash-ref', and pass vectors through 'vector->list'.
(iso3166->iso3166-territories): Likewise.
* gnu/system/vm.scm (system-docker-image)[build]: Use GUILE-JSON-3.
* guix/docker.scm (manifest, config): Adjust for Guile-JSON 3.
* guix/scripts/pack.scm (docker-image)[build]: Use GUILE-JSON-3.
---
 configure.ac                 |  4 ++--
 doc/guix.texi                |  2 +-
 gnu/installer.scm            |  4 ++--
 gnu/installer/locale.scm     | 21 ++++++++++++---------
 gnu/system/vm.scm            |  2 +-
 guix/docker.scm              | 19 ++++++++++---------
 guix/git-download.scm        |  4 ++--
 guix/import/cpan.scm         | 14 +++++++-------
 guix/import/crate.scm        |  6 +++---
 guix/import/gem.scm          | 10 +++++++---
 guix/import/json.scm         | 11 ++---------
 guix/import/pypi.scm         |  8 ++++----
 guix/import/stackage.scm     |  4 ++--
 guix/import/utils.scm        | 25 ++++++-------------------
 guix/scripts/import/json.scm |  2 +-
 guix/scripts/pack.scm        |  2 +-
 guix/self.scm                |  2 +-
 guix/swh.scm                 | 35 +++++++++++++++++++----------------
 m4/guix.m4                   | 21 +++++++++++++++++++++
 tests/import-utils.scm       | 22 ++++++++++++++++++++++
 20 files changed, 126 insertions(+), 92 deletions(-)

diff --git a/configure.ac b/configure.ac
index 3918550a79..689b28d984 100644
--- a/configure.ac
+++ b/configure.ac
@@ -119,8 +119,8 @@ if test "x$have_guile_git" != "xyes"; then
 fi
 
 dnl Check for Guile-JSON.
-GUILE_MODULE_AVAILABLE([have_guile_json], [(json)])
-if test "x$have_guile_json" != "xyes"; then
+GUIX_CHECK_GUILE_JSON
+if test "x$guix_cv_have_recent_guile_json" != "xyes"; then
   AC_MSG_ERROR([Guile-JSON is missing; please install it.])
 fi
 
diff --git a/doc/guix.texi b/doc/guix.texi
index 107c16b8db..3a37555721 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -746,7 +746,7 @@ or later;
 @c FIXME: Specify a version number once a release has been made.
 @uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
 2017 or later;
-@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON};
+@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} 3.x;
 @item @url{https://zlib.net, zlib};
 @item @url{https://www.gnu.org/software/make/, GNU Make}.
 @end itemize
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 1452c4dc7e..15d971dfc4 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -69,7 +69,7 @@ version of this file."
         (setlocale LC_ALL "en_US.utf8")))
 
   (define builder
-    (with-extensions (list guile-json)
+    (with-extensions (list guile-json-3)
       (with-imported-modules (source-module-closure
                               '((gnu installer locale)))
         #~(begin
@@ -313,7 +313,7 @@ selected keymap."
     ;; packages …), etc. modules.
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
-                           guile-json guile-git guix)
+                           guile-json-3 guile-git guix)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (gnu services herd)
diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm
index 13f3a1e881..ccffb6d8ef 100644
--- a/gnu/installer/locale.scm
+++ b/gnu/installer/locale.scm
@@ -134,16 +134,18 @@ ISO639-3 and ISO639-5 files."
         (lambda (port-iso639-5)
           (filter-map
            (lambda (hash)
-             (let ((alpha2 (hash-ref hash "alpha_2"))
-                   (alpha3 (hash-ref hash "alpha_3"))
-                   (name   (hash-ref hash "name")))
+             (let ((alpha2 (assoc-ref hash "alpha_2"))
+                   (alpha3 (assoc-ref hash "alpha_3"))
+                   (name   (assoc-ref hash "name")))
                (and (supported-locale? locales alpha2 alpha3)
                     `((alpha2 . ,alpha2)
                       (alpha3 . ,alpha3)
                       (name   . ,name)))))
            (append
-            (hash-ref (json->scm port-iso639-3) "639-3")
-            (hash-ref (json->scm port-iso639-5) "639-5"))))))))
+            (vector->list
+             (assoc-ref (json->scm port-iso639-3) "639-3"))
+            (vector->list
+             (assoc-ref (json->scm port-iso639-5) "639-5")))))))))
 
 (define (language-code->language-name languages language-code)
   "Using LANGUAGES as a list of ISO639 association lists, return the language
@@ -179,10 +181,11 @@ ISO3166 file."
   (call-with-input-file iso3166
     (lambda (port)
       (map (lambda (hash)
-             `((alpha2 . ,(hash-ref hash "alpha_2"))
-               (alpha3 . ,(hash-ref hash "alpha_3"))
-               (name   . ,(hash-ref hash "name"))))
-           (hash-ref (json->scm port) "3166-1")))))
+             `((alpha2 . ,(assoc-ref hash "alpha_2"))
+               (alpha3 . ,(assoc-ref hash "alpha_3"))
+               (name   . ,(assoc-ref hash "name"))))
+           (vector->list
+            (assoc-ref (json->scm port) "3166-1"))))))
 
 (define (territory-code->territory-name territories territory-code)
   "Using TERRITORIES as a list of ISO3166 association lists return the
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index e7f7d8ca51..ac6e4ded92 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -514,7 +514,7 @@ system."
         (name  (string-append name ".tar.gz"))
         (graph "system-graph"))
     (define build
-      (with-extensions (cons guile-json           ;for (guix docker)
+      (with-extensions (cons guile-json-3         ;for (guix docker)
                              gcrypt-sqlite3&co)   ;for (guix store database)
         (with-imported-modules `(,@(source-module-closure
                                     '((guix docker)
diff --git a/guix/docker.scm b/guix/docker.scm
index b1bd226fa1..c598a073f6 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -62,9 +62,9 @@
 
 (define (manifest path id)
   "Generate a simple image manifest."
-  `(((Config . "config.json")
-     (RepoTags . (,(generate-tag path)))
-     (Layers . (,(string-append id "/layer.tar"))))))
+  `#(((Config . "config.json")
+      (RepoTags . #(,(generate-tag path)))
+      (Layers . #(,(string-append id "/layer.tar"))))))
 
 ;; According to the specifications this is required for backwards
 ;; compatibility.  It duplicates information provided by the manifest.
@@ -81,17 +81,18 @@
   `((architecture . ,arch)
     (comment . "Generated by GNU Guix")
     (created . ,time)
-    (config . ,`((env . ,(map (match-lambda
-                                ((name . value)
-                                 (string-append name "=" value)))
-                              environment))
+    (config . ,`((env . ,(list->vector
+                          (map (match-lambda
+                                 ((name . value)
+                                  (string-append name "=" value)))
+                               environment)))
                  ,@(if entry-point
-                       `((entrypoint . ,entry-point))
+                       `((entrypoint . ,(list->vector entry-point)))
                        '())))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
-               (diff_ids . (,(layer-diff-id layer)))))))
+               (diff_ids . #(,(layer-diff-id layer)))))))
 
 (define %tar-determinism-options
   ;; GNU tar options to produce archives deterministically.
diff --git a/guix/git-download.scm b/guix/git-download.scm
index f904d11c25..8f84681d46 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;;
@@ -85,7 +85,7 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
     (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
 
   (define guile-json
-    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json))
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3))
 
   (define gnutls
     (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index d4bea84353..ec86f11743 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -76,8 +76,8 @@
    ;; ssleay
    ;; sun
    ("zlib" 'zlib)
-   ((x) (string->license x))
-   ((lst ...) `(list ,@(map string->license lst)))
+   (#(x) (string->license x))
+   (#(lst ...) `(list ,@(map string->license lst)))
    (_ #f)))
 
 (define (module->name module)
@@ -88,10 +88,10 @@
   "Return the base distribution module for a given module.  E.g. the 'ok'
 module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
 return \"Test-Simple\""
-  (assoc-ref (json-fetch-alist (string-append
-                                "https://fastapi.metacpan.org/v1/module/"
-                                module
-                                "?fields=distribution"))
+  (assoc-ref (json-fetch (string-append
+                          "https://fastapi.metacpan.org/v1/module/"
+                          module
+                          "?fields=distribution"))
              "distribution"))
 
 (define (package->upstream-name package)
@@ -114,7 +114,7 @@ return \"Test-Simple\""
   "Return an alist representation of the CPAN metadata for the perl module MODULE,
 or #f on failure.  MODULE should be e.g. \"Test::Script\""
   ;; This API always returns the latest release of the module.
-  (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
+  (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name)))
 
 (define (cpan-home name)
   (string-append "https://metacpan.org/release/" name))
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 29318aac0e..52c5cb1c30 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -51,7 +51,7 @@
   (define (crate-kind-predicate kind)
     (lambda (dep) (string=? (assoc-ref dep "kind") kind)))
 
-  (and-let* ((crate-json (json-fetch-alist (string-append crate-url crate-name)))
+  (and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
              (crate (assoc-ref crate-json "crate"))
              (name (assoc-ref crate "name"))
              (version (assoc-ref crate "max_version"))
@@ -63,8 +63,8 @@
                                  string->license)
                           '()))                   ;missing license info
              (path (string-append "/" version "/dependencies"))
-             (deps-json (json-fetch-alist (string-append crate-url name path)))
-             (deps (assoc-ref deps-json "dependencies"))
+             (deps-json (json-fetch (string-append crate-url name path)))
+             (deps (vector->list (assoc-ref deps-json "dependencies")))
              (dep-crates (filter (crate-kind-predicate "normal") deps))
              (dev-dep-crates
               (filter (lambda (dep)
diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index ea576b5e4a..0bf9ff2552 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -40,7 +40,7 @@
 (define (rubygems-fetch name)
   "Return an alist representation of the RubyGems metadata for the package NAME,
 or #f on failure."
-  (json-fetch-alist
+  (json-fetch
    (string-append "https://rubygems.org/api/v1/gems/" name ".json")))
 
 (define (ruby-package-name name)
@@ -130,14 +130,18 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
                                (assoc-ref package "info")))
                 (home-page    (assoc-ref package "homepage_uri"))
                 (dependencies-names (map (lambda (dep) (assoc-ref dep "name"))
-                                         (assoc-ref* package "dependencies" "runtime")))
+                                         (vector->list
+                                          (assoc-ref* package
+                                                      "dependencies"
+                                                      "runtime"))))
                 (dependencies (map (lambda (dep)
                                      (if (string=? dep "bundler")
                                          "bundler" ; special case, no prefix
                                          (ruby-package-name dep)))
                                    dependencies-names))
                 (licenses     (map string->license
-                                   (assoc-ref package "licenses"))))
+                                   (vector->list
+                                    (assoc-ref package "licenses")))))
            (values (make-gem-sexp name version hash home-page synopsis
                                   description dependencies licenses)
                    dependencies-names)))))
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 81ea5e7b31..8900724dcd 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,8 +23,7 @@
   #:use-module (guix http-client)
   #:use-module (guix import utils)
   #:use-module (srfi srfi-34)
-  #:export (json-fetch
-            json-fetch-alist))
+  #:export (json-fetch))
 
 (define* (json-fetch url
                      ;; Note: many websites returns 403 if we omit a
@@ -43,9 +42,3 @@ the query."
            (result (json->scm port)))
       (close-port port)
       result)))
-
-(define (json-fetch-alist url)
-  "Return an alist representation of the JSON resource URL, or #f if URL
-returns 403 or 404."
-  (and=> (json-fetch url)
-         hash-table->alist))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index ab7a024ee0..9b3d80a02e 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -56,7 +56,7 @@
 (define (pypi-fetch name)
   "Return an alist representation of the PyPI metadata for the package NAME,
 or #f on failure."
-  (json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json")))
+  (json-fetch (string-append "https://pypi.org/pypi/" name "/json")))
 
 ;; For packages found on PyPI that lack a source distribution.
 (define-condition-type &missing-source-error &error
@@ -69,7 +69,7 @@ or #f on failure."
                               (assoc-ref* pypi-package "info" "version"))))
     (or (find (lambda (release)
                 (string=? "sdist" (assoc-ref release "packagetype")))
-              releases)
+              (vector->list releases))
         (raise (condition (&missing-source-error
                            (package pypi-package)))))))
 
@@ -80,7 +80,7 @@ or #f if there isn't any."
                               (assoc-ref* pypi-package "info" "version"))))
     (or (find (lambda (release)
                 (string=? "bdist_wheel" (assoc-ref release "packagetype")))
-              releases)
+              (vector->list releases))
         #f)))
 
 (define (python->package-name name)
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index 1c1e73a723..194bea633e 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -60,7 +60,7 @@
      (let* ((url (if (string=? "" version)
                      (string-append %stackage-url "/lts")
                      (string-append %stackage-url "/lts-" version)))
-            (lts-info (json-fetch-alist url)))
+            (lts-info (json-fetch url)))
        (if lts-info
            (reverse lts-info)
            (leave-with-message "LTS release version not found: ~a" version))))))
@@ -74,7 +74,7 @@
 (define (lts-package-version pkgs-info name)
   "Return the version of the package with upstream NAME included in PKGS-INFO."
   (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
-                   pkgs-info)))
+                   (vector->list pkgs-info))))
     (stackage-package-version pkg)))
 
 \f
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 84503ab907..2a3b7341fb 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -45,7 +45,6 @@
   #:use-module (srfi srfi-41)
   #:export (factorize-uri
 
-            hash-table->alist
             flatten
             assoc-ref*
 
@@ -100,21 +99,6 @@ of the string VERSION is replaced by the symbol 'version."
                '()
                indices))))))
 
-(define (hash-table->alist table)
-  "Return an alist represenation of TABLE."
-  (map (match-lambda
-        ((key . (lst ...))
-         (cons key
-               (map (lambda (x)
-                      (if (hash-table? x)
-                          (hash-table->alist x)
-                          x))
-                    lst)))
-        ((key . (? hash-table? table))
-         (cons key (hash-table->alist table)))
-        (pair pair))
-       (hash-map->list cons table)))
-
 (define (flatten lst)
   "Return a list that recursively concatenates all sub-lists of LST."
   (fold-right
@@ -330,11 +314,14 @@ the expected fields of an <origin> object."
       (lookup-build-system-by-name
        (string->symbol (assoc-ref meta "build-system"))))
     (native-inputs
-     (specs->package-lists (or (assoc-ref meta "native-inputs") '())))
+     (specs->package-lists
+      (vector->list (or (assoc-ref meta "native-inputs") '#()))))
     (inputs
-     (specs->package-lists (or (assoc-ref meta "inputs") '())))
+     (specs->package-lists
+      (vector->list (or (assoc-ref meta "inputs") '#()))))
     (propagated-inputs
-     (specs->package-lists (or (assoc-ref meta "propagated-inputs") '())))
+     (specs->package-lists
+      (vector->list (or (assoc-ref meta "propagated-inputs") '#()))))
     (home-page
      (assoc-ref meta "home-page"))
     (synopsis
diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm
index 8771e7b0eb..c9daf65479 100644
--- a/guix/scripts/import/json.scm
+++ b/guix/scripts/import/json.scm
@@ -93,7 +93,7 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n"))
            (let ((json (json-string->scm
                         (with-input-from-file file-name read-string))))
              ;; TODO: also print define-module boilerplate
-             (package->code (alist->package (hash-table->alist json)))))
+             (package->code (alist->package json))))
          (lambda _
            (leave (G_ "invalid JSON in file '~a'~%") file-name))))
       (()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 01472d9768..fdb98983bf 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -479,7 +479,7 @@ the image."
 
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
-    (with-extensions (list guile-json guile-gcrypt)
+    (with-extensions (list guile-json-3 guile-gcrypt)
       (with-imported-modules `(((guix config) => ,(make-config.scm))
                                ,@(source-module-closure
                                   `((guix docker)
diff --git a/guix/self.scm b/guix/self.scm
index 838ede7690..f03fe01d0c 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -50,7 +50,7 @@
                (module-ref (resolve-interface module) variable))))
     (match-lambda
       ("guile"      (ref '(gnu packages commencement) 'guile-final))
-      ("guile-json" (ref '(gnu packages guile) 'guile-json))
+      ("guile-json" (ref '(gnu packages guile) 'guile-json-3))
       ("guile-ssh"  (ref '(gnu packages ssh)   'guile-ssh))
       ("guile-git"  (ref '(gnu packages guile) 'guile-git))
       ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
diff --git a/guix/swh.scm b/guix/swh.scm
index d692f81806..df2a138f04 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -138,16 +138,16 @@ following SPEC, a series of field specifications."
                         (json->scm input))
                        ((string? input)
                         (json-string->scm input))
-                       ((hash-table? input)
+                       ((or (null? input) (pair? input))
                         input))))
       (let-syntax ((extract-field (syntax-rules ()
                                     ((_ table (field key json->value))
-                                     (json->value (hash-ref table key)))
+                                     (json->value (assoc-ref table key)))
                                     ((_ table (field key))
-                                     (hash-ref table key))
+                                     (assoc-ref table key))
                                     ((_ table (field))
-                                     (hash-ref table
-                                               (symbol->string 'field))))))
+                                     (assoc-ref table
+                                                (symbol->string 'field))))))
         (ctor (extract-field table spec) ...)))))
 
 (define-syntax-rule (define-json-mapping rtd ctor pred json->record
@@ -257,12 +257,13 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   (target-url   branch-target-url))
 
 (define (json->branches branches)
-  (hash-map->list (lambda (key value)
-                    (make-branch key
-                                 (string->symbol
-                                  (hash-ref value "target_type"))
-                                 (hash-ref value "target_url")))
-                  branches))
+  (map (match-lambda
+         ((key . value)
+          (make-branch key
+                       (string->symbol
+                        (assoc-ref value "target_type"))
+                       (assoc-ref value "target_url"))))
+       branches))
 
 ;; <https://archive.softwareheritage.org/api/1/release/1f44934fb6e2cefccbecd4fa347025349fa9ff76/>
 (define-json-mapping <release> make-release release?
@@ -292,9 +293,10 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   (license-url   content-license-url "license_url"))
 
 (define (json->checksums checksums)
-  (hash-map->list (lambda (key value)
-                    (cons key (base16-string->bytevector value)))
-                  checksums))
+  (map (match-lambda
+         ((key . value)
+          (cons key (base16-string->bytevector value))))
+       checksums))
 
 ;; <https://archive.softwareheritage.org/api/1/directory/27c69c5d298a43096a53affbf881e7b13f17bdcd/>
 (define-json-mapping <directory-entry> make-directory-entry directory-entry?
@@ -365,14 +367,15 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   json->directory-entries)
 
 (define (json->directory-entries port)
-  (map json->directory-entry (json->scm port)))
+  (map json->directory-entry
+       (vector->list (json->scm port))))
 
 (define (origin-visits origin)
   "Return the list of visits of ORIGIN, a record as returned by
 'lookup-origin'."
   (call (swh-url (origin-visits-url origin))
         (lambda (port)
-          (map json->visit (json->scm port)))))
+          (map json->visit (vector->list (json->scm port))))))
 
 (define (visit-snapshot visit)
   "Return the snapshot corresponding to VISIT."
diff --git a/m4/guix.m4 b/m4/guix.m4
index d0c5ec0f08..716bfb08ec 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -174,6 +174,27 @@ AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [
      fi])
 ])
 
+dnl GUIX_CHECK_GUILE_JSON
+dnl
+dnl Check whether a recent-enough Guile-JSON is available.
+AC_DEFUN([GUIX_CHECK_GUILE_JSON], [
+  dnl Check whether we're using Guile-JSON 3.x, which uses a JSON-to-Scheme
+  dnl mapping different from that of earlier versions.
+  AC_CACHE_CHECK([whether Guile-JSON is available and recent enough],
+    [guix_cv_have_recent_guile_json],
+    [GUILE_CHECK([retval],
+      [(use-modules (json) (ice-9 match))
+       (match (json-string->scm \"[[] { \\\"a\\\": 42 } []]\")
+         (#(("a" . 42)) #t)
+	 (_ #f))])
+     if test "$retval" = 0; then
+       guix_cv_have_recent_guile_json="yes"
+     else
+       guix_cv_have_recent_guile_json="no"
+     fi])
+])
+
+
 dnl GUIX_TEST_ROOT_DIRECTORY
 AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
   AC_CACHE_CHECK([for unit test root directory],
diff --git a/tests/import-utils.scm b/tests/import-utils.scm
index 5c0c041360..c3ab25d788 100644
--- a/tests/import-utils.scm
+++ b/tests/import-utils.scm
@@ -23,6 +23,7 @@
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
   #:use-module (guix build-system)
+  #:use-module (gnu packages)
   #:use-module (srfi srfi-64))
 
 (test-begin "import-utils")
@@ -98,4 +99,25 @@
     (or (package-license (alist->package meta))
         'license-is-false)))
 
+(test-equal "alist->package with dependencies"
+  `(("gettext" ,(specification->package "gettext")))
+  (let* ((meta '(("name" . "hello")
+                 ("version" . "2.10")
+                 ("source" . (("method" . "url-fetch")
+                              ("uri"    . "mirror://gnu/hello/hello-2.10.tar.gz")
+                              ("sha256" .
+                               (("base32" .
+                                 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
+                 ("build-system" . "gnu")
+                 ("home-page" . "https://gnu.org")
+                 ("synopsis" . "Say hi")
+                 ("description" . "This package says hi.")
+                                                  ;
+                 ;; Note: As with Guile-JSON 3.x, JSON arrays are represented
+                 ;; by vectors.
+                 ("native-inputs" . #("gettext"))
+
+                 ("license" . #f))))
+    (package-native-inputs (alist->package meta))))
+
 (test-end "import-utils")
-- 
2.22.0

^ permalink raw reply related	[relevance 24%]

* [bug#36608] [PATCH 9/9] Update docker-compose to 1.24.1.
                     ` (2 preceding siblings ...)
  2019-07-11 20:52 70% ` [bug#36608] [PATCH 8/9] " Jacob MacDonald
@ 2019-07-11 20:52 71% ` Jacob MacDonald
  3 siblings, 0 replies; 149+ results
From: Jacob MacDonald @ 2019-07-11 20:52 UTC (permalink / raw)
  To: 36608

[-- Attachment #1: Type: text/plain, Size: 1 bytes --]



[-- Attachment #2: 0009-gnu-docker-compose-Update-to-1.24.1.patch --]
[-- Type: text/x-patch, Size: 1986 bytes --]

From d7b8d3fe4739ecfb2935fd445d0a164b32fc2f12 Mon Sep 17 00:00:00 2001
From: Jacob MacDonald <jaccarmac@gmail.com>
Date: Thu, 11 Jul 2019 15:36:36 -0500
Subject: [PATCH 9/9] gnu: docker-compose: Update to 1.24.1.

* gnu/packages/docker.scm (docker-compose): Update to 1.24.1.
---
 gnu/packages/docker.scm | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index de69524404..9d96a6345b 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -103,25 +103,32 @@ client.")
 (define-public docker-compose
   (package
     (name "docker-compose")
-    (version "1.5.2")
+    (version "1.24.1")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "docker-compose" version))
        (sha256
         (base32
-         "0ksg7hm2yvc977968dixxisrhcmvskzpcx3pz0v1kazrdqp7xakr"))))
+         "0lx7bx6jvhydbab8vwry0bclhdf0dfj6jrns1m5y45yp9ybqxmd5"))))
     (build-system python-build-system)
     ;; TODO: Tests require running Docker daemon.
     (arguments '(#:tests? #f))
     (inputs
-     `(("python-docker-py" ,python-docker-py)
+     `(("python2-backport-ssl-match-hostname"
+        ,python2-backport-ssl-match-hostname)
+       ("python-cached-property"
+        ,python-cached-property)
+       ("python-colorama" ,python-colorama)
+       ("python-docker-py" ,python-docker-py)
        ("python-docker-pycreds" ,python-docker-pycreds)
        ("python-dockerpty" ,python-dockerpty)
        ("python-docopt" ,python-docopt)
+       ("python-ipaddress" ,python-ipaddress)
+       ("python-paramiko" ,python-paramiko)
        ("python-jsonschema" ,python-jsonschema-2.6)
        ("python-pyyaml" ,python-pyyaml)
-       ("python-requests" ,python-requests-2.7)
+       ("python-requests" ,python-requests-2.20)
        ("python-six" ,python-six)
        ("python-texttable" ,python-texttable)
        ("python-websocket-client" ,python-websocket-client)))
-- 
2.22.0


^ permalink raw reply related	[relevance 71%]

* [bug#36608] [PATCH 8/9] Update docker-compose to 1.24.1.
    2019-07-11 20:51 72% ` [bug#36608] [PATCH 6/9] " Jacob MacDonald
  2019-07-11 20:51 72% ` [bug#36608] [PATCH 7/9] " Jacob MacDonald
@ 2019-07-11 20:52 70% ` Jacob MacDonald
  2019-07-11 20:52 71% ` [bug#36608] [PATCH 9/9] " Jacob MacDonald
  3 siblings, 0 replies; 149+ results
From: Jacob MacDonald @ 2019-07-11 20:52 UTC (permalink / raw)
  To: 36608

[-- Attachment #1: Type: text/plain, Size: 1 bytes --]



[-- Attachment #2: 0008-gnu-python-docker-py-Update-to-3.7.3.patch --]
[-- Type: text/x-patch, Size: 2042 bytes --]

From ce4ba389f4feb4be00ab0f1910ec4114e0c41a15 Mon Sep 17 00:00:00 2001
From: Jacob MacDonald <jaccarmac@gmail.com>
Date: Thu, 11 Jul 2019 15:38:17 -0500
Subject: [PATCH 8/9] gnu: python-docker-py: Update to 3.7.3.

* gnu/packages/docker.scm (python-docker-py): Update to 3.7.3.
---
 gnu/packages/docker.scm | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index e4a7d4c2fd..de69524404 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -39,6 +39,7 @@
   #:use-module (gnu packages networking)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
   #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages version-control)
@@ -49,20 +50,26 @@
 (define-public python-docker-py
   (package
     (name "python-docker-py")
-    (version "1.10.6")
+    (version "3.7.3")
     (source
      (origin
        (method url-fetch)
-       (uri (pypi-uri "docker-py" version))
+       (uri (pypi-uri "docker" version))
        (sha256
         (base32
-         "05f49f6hnl7npmi7kigg0ibqk8s3fhzx1ivvz1kqvlv4ay3paajc"))))
+         "0qmrcvpaz37p85hfddsd4yc8hgqlkzs4cz09q9wmy0pz5pwajqm0"))))
     (build-system python-build-system)
     ;; TODO: Tests require a running Docker daemon.
     (arguments '(#:tests? #f))
     (inputs
-     `(("python-requests" ,python-requests)
+     `(("python2-backport-ssl-match-hostname"
+        ,python2-backport-ssl-match-hostname)
+       ("python-requests" ,python-requests-2.20)
+       ("python-docker-pycreds" ,python-docker-pycreds)
+       ("python-ipaddress" ,python-ipaddress)
+       ("python-paramiko" ,python-paramiko)
        ("python-six" ,python-six)
+       ("python-urllib3" ,python-urllib3-1.24)
        ("python-websocket-client" ,python-websocket-client)))
     (home-page "https://github.com/docker/docker-py/")
     (synopsis "Python client for Docker")
-- 
2.22.0


^ permalink raw reply related	[relevance 70%]

* [bug#36608] [PATCH 6/9] Update docker-compose to 1.24.1.
  @ 2019-07-11 20:51 72% ` Jacob MacDonald
  2019-07-11 20:51 72% ` [bug#36608] [PATCH 7/9] " Jacob MacDonald
                   ` (2 subsequent siblings)
  3 siblings, 0 replies; 149+ results
From: Jacob MacDonald @ 2019-07-11 20:51 UTC (permalink / raw)
  To: 36608

[-- Attachment #1: Type: text/plain, Size: 1 bytes --]



[-- Attachment #2: 0006-gnu-python-docker-pycreds-Update-to-0.4.0.patch --]
[-- Type: text/x-patch, Size: 1134 bytes --]

From 8778d69652a250567e292d1494489de5dcd8b533 Mon Sep 17 00:00:00 2001
From: Jacob MacDonald <jaccarmac@gmail.com>
Date: Thu, 11 Jul 2019 15:39:48 -0500
Subject: [PATCH 6/9] gnu: python-docker-pycreds: Update to 0.4.0.

* gnu/packages/docker.scm (python-docker-pycreds): Update to 0.4.0.
---
 gnu/packages/docker.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index bb981665d6..fac7d4889a 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -129,14 +129,14 @@ created and all the services are started as specified in the configuration.")
 (define-public python-docker-pycreds
   (package
     (name "python-docker-pycreds")
-    (version "0.3.0")
+    (version "0.4.0")
     (source
       (origin
         (method url-fetch)
         (uri (pypi-uri "docker-pycreds" version))
         (sha256
          (base32
-          "1zxvam1q22qb0jf48553nnncnfrcp88ag4xa0qmq6vr0imn9a3lb"))))
+          "1m44smrggnqghxkqfl7vhapdw89m1p3vdr177r6cq17lr85jgqvc"))))
     (build-system python-build-system)
     (arguments
      `(#:phases
-- 
2.22.0


^ permalink raw reply related	[relevance 72%]

* [bug#36608] [PATCH 7/9] Update docker-compose to 1.24.1.
    2019-07-11 20:51 72% ` [bug#36608] [PATCH 6/9] " Jacob MacDonald
@ 2019-07-11 20:51 72% ` Jacob MacDonald
  2019-07-11 20:52 70% ` [bug#36608] [PATCH 8/9] " Jacob MacDonald
  2019-07-11 20:52 71% ` [bug#36608] [PATCH 9/9] " Jacob MacDonald
  3 siblings, 0 replies; 149+ results
From: Jacob MacDonald @ 2019-07-11 20:51 UTC (permalink / raw)
  To: 36608

[-- Attachment #1: Type: text/plain, Size: 1 bytes --]



[-- Attachment #2: 0007-gnu-python-dockerpty-Update-to-0.4.1.patch --]
[-- Type: text/x-patch, Size: 1065 bytes --]

From fef43a887916608104244aeab14c00f0968025c6 Mon Sep 17 00:00:00 2001
From: Jacob MacDonald <jaccarmac@gmail.com>
Date: Thu, 11 Jul 2019 15:39:18 -0500
Subject: [PATCH 7/9] gnu: python-dockerpty: Update to 0.4.1.

* gnu/packages/docker.scm (python-dockerpty): Update to 0.4.1.
---
 gnu/packages/docker.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index fac7d4889a..e4a7d4c2fd 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -73,14 +73,14 @@ management tool.")
 (define-public python-dockerpty
   (package
     (name "python-dockerpty")
-    (version "0.3.4")
+    (version "0.4.1")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "dockerpty" version))
        (sha256
         (base32
-         "0za6rr349641wv76ww9l3zcic2xyxrirlxpnzl4296h897648455"))))
+         "1kjn64wx23jmr8dcc6g7bwlmrhfmxr77gh6iphqsl39sayfxdab9"))))
     (build-system python-build-system)
     (native-inputs
      `(("python-six" ,python-six)))
-- 
2.22.0


^ permalink raw reply related	[relevance 72%]

* [bug#36469] [PATCH 1/2] pack: 'docker' backend records the profile's search paths.
  @ 2019-07-02  8:56 73% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-07-02  8:56 UTC (permalink / raw)
  To: 36469; +Cc: Ludovic Courtès

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* 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  | 16 ++++++++++------
 guix/docker.scm       | 17 +++++++++++++----
 guix/scripts/pack.scm | 23 +++++++++++++++++++----
 3 files changed, 42 insertions(+), 14 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index f2674cdbe8..27fde49e75 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,13 @@ 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!\")"))
+                       (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 +148,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 +162,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 7fe83d9797..b1bd226fa1 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 c90b777222..bb6a8cda1a 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))
-- 
2.22.0

^ permalink raw reply related	[relevance 73%]

* [bug#36093] [PATCH v2 2/2] pack: Add '--entry-point'.
  2019-06-06 11:03 43% ` [bug#36093] [PATCH v2 1/2] services: Add Singularity Ludovic Courtès
@ 2019-06-06 11:03 47%   ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-06-06 11:03 UTC (permalink / raw)
  To: 36093; +Cc: Ludovic Courtès

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* guix/scripts/pack.scm (self-contained-tarball): Add #:entry-point and
warn when it's true.
(squashfs-image): Add #:entry-point and honor it.
(docker-image): Add #:entry-point and honor it.
(%options, show-help): Add '--entry-point'.
(guix-pack): Honor '--entry-point' and pass #:entry-point to BUILD-IMAGE.
* gnu/tests/docker.scm (run-docker-test): Test 'docker run' with the
default entry point.
(build-tarball&run-docker-test): Pass #:entry-point to 'docker-image'.
* doc/guix.texi (Invoking guix pack): Document it.
* gnu/tests/singularity.scm (run-singularity-test)["singularity run"]:
New test.
(build-tarball&run-singularity-test): Pass #:entry-point to
'squashfs-image'.
---
 doc/guix.texi             | 23 ++++++++++++++++++++++
 gnu/tests/docker.scm      | 19 +++++++++++-------
 gnu/tests/singularity.scm |  9 +++++++++
 guix/scripts/pack.scm     | 41 +++++++++++++++++++++++++++++++++++++++
 4 files changed, 85 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index c89df4ade3..6851b911c0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4866,6 +4866,29 @@ advantage to work without requiring special kernel support, but it incurs
 run-time overhead every time a system call is made.
 @end quotation
 
+@cindex entry point, for Docker images
+@item --entry-point=@var{command}
+Use @var{command} as the @dfn{entry point} of the resulting pack, if the pack
+format supports it---currently @code{docker} and @code{squashfs} (Singularity)
+support it.  @var{command} must be relative to the profile contained in the
+pack.
+
+The entry point specifies the command that tools like @code{docker run} or
+@code{singularity run} automatically start by default.  For example, you can
+do:
+
+@example
+guix pack -f docker --entry-point=bin/guile guile
+@end example
+
+The resulting pack can easily be loaded and @code{docker run} with no extra
+arguments will spawn @code{bin/guile}:
+
+@example
+docker load -i pack.tar.gz
+docker run @var{image-id}
+@end example
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Consider the package @var{expr} evaluates to.
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 3cd3a27884..f2674cdbe8 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -101,7 +101,7 @@ inside %DOCKER-OS."
              marionette))
 
           (test-equal "Load docker image and run it"
-            "hello world"
+            '("hello world" "hi!")
             (marionette-eval
              `(begin
                 (define slurp
@@ -117,12 +117,16 @@ inside %DOCKER-OS."
                        (repository&tag (string-drop raw-line
                                                     (string-length
                                                      "Loaded image: ")))
-                       (response (slurp
-                                  ,(string-append #$docker-cli "/bin/docker")
-                                  "run" "--entrypoint" "bin/Guile"
-                                  repository&tag
-                                  "/aa.scm")))
-                  response))
+                       (response1 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" "--entrypoint" "bin/Guile"
+                                   repository&tag
+                                   "/aa.scm"))
+                       (response2 (slurp          ;default entry point
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" repository&tag
+                                   "-c" "(display \"hi!\")")))
+                  (list response1 response2)))
              marionette))
 
           (test-end)
@@ -161,6 +165,7 @@ standard output device and then enters a new line.")
        (tarball (docker-image "docker-pack" profile
                               #:symlinks '(("/bin/Guile" -> "bin/guile")
                                            ("aa.scm" -> "a.scm"))
+                              #:entry-point "bin/guile"
                               #:localstatedir? #t)))
     (run-docker-test tarball)))
 
diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm
index 55324ef9ea..668043a0bc 100644
--- a/gnu/tests/singularity.scm
+++ b/gnu/tests/singularity.scm
@@ -103,6 +103,14 @@
                    (cdr (waitpid pid)))))
              marionette))
 
+          (test-equal "singularity run"           ;test the entry point
+            42
+            (marionette-eval
+             `(status:exit-val
+               (system* #$(file-append singularity "/bin/singularity")
+                        "run" #$image "-c" "(exit 42)"))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
@@ -118,6 +126,7 @@
                                      #:hooks '()
                                      #:locales? #f))
        (tarball  (squashfs-image "singularity-pack" profile
+                                 #:entry-point "bin/guile"
                                  #:symlinks '(("/bin" -> "bin")))))
     (run-singularity-test tarball)))
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c17b374330..5da23e038b 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -152,6 +152,7 @@ dependencies are registered."
                                  #:key target
                                  (profile-name "guix-profile")
                                  deduplicate?
+                                 entry-point
                                  (compressor (first %compressors))
                                  localstatedir?
                                  (symlinks '())
@@ -275,6 +276,10 @@ added to the pack."
                                           (_ #f))
                                         directives)))))))))
 
+  (when entry-point
+    (warning (G_ "entry point not supported in the '~a' format~%")
+             'tarball))
+
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
                     build
@@ -284,6 +289,7 @@ added to the pack."
                          #:key target
                          (profile-name "guix-profile")
                          (compressor (first %compressors))
+                         entry-point
                          localstatedir?
                          (symlinks '())
                          (archiver squashfs-tools-next))
@@ -315,6 +321,7 @@ added to the pack."
                        (ice-9 match))
 
           (define database #+database)
+          (define entry-point #$entry-point)
 
           (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -371,6 +378,28 @@ added to the pack."
                                                             target)))))))
                       '#$symlinks)
 
+                   ;; Create /.singularity.d/actions, and optionally the 'run'
+                   ;; script, used by 'singularity run'.
+                   "-p" "/.singularity.d d 555 0 0"
+                   "-p" "/.singularity.d/actions d 555 0 0"
+                   ,@(if entry-point
+                         `(;; This one if for Singularity 2.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/actions/run s 777 0 0 "
+                             (relative-file-name "/.singularity.d/actions"
+                                                 (string-append #$profile "/"
+                                                                entry-point)))
+
+                           ;; This one is for Singularity 3.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/runscript s 777 0 0 "
+                             (relative-file-name "/.singularity.d"
+                                                 (string-append #$profile "/"
+                                                                entry-point))))
+                         '())
+
                    ;; Create empty mount points.
                    "-p" "/proc d 555 0 0"
                    "-p" "/sys d 555 0 0"
@@ -392,6 +421,7 @@ added to the pack."
                        #:key target
                        (profile-name "guix-profile")
                        (compressor (first %compressors))
+                       entry-point
                        localstatedir?
                        (symlinks '())
                        (archiver tar))
@@ -425,6 +455,8 @@ the image."
                                 #$profile
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
+                                #:entry-point (string-append #$profile "/"
+                                                             #$entry-point)
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
                                 #:creation-time (make-time time-utc 0 1))))))
@@ -689,6 +721,9 @@ please email '~a'~%")
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
                                (alist-delete 'system result eq?))))
+         (option '("entry-point") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'entry-point arg result)))
          (option '("target") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'target arg
@@ -765,6 +800,9 @@ Create a bundle of PACKAGE.\n"))
   -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
   (display (G_ "
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
+  (display (G_ "
+      --entry-point=PROGRAM
+                         use PROGRAM as the entry point of the pack"))
   (display (G_ "
       --save-provenance  save provenance information"))
   (display (G_ "
@@ -889,6 +927,7 @@ Create a bundle of PACKAGE.\n"))
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
                  (localstatedir? (assoc-ref opts 'localstatedir?))
+                 (entry-point    (assoc-ref opts 'entry-point))
                  (profile-name   (assoc-ref opts 'profile-name))
                  (gc-root        (assoc-ref opts 'gc-root)))
             (when (null? (manifest-entries manifest))
@@ -919,6 +958,8 @@ Create a bundle of PACKAGE.\n"))
                                                      symlinks
                                                      #:localstatedir?
                                                      localstatedir?
+                                                     #:entry-point
+                                                     entry-point
                                                      #:profile-name
                                                      profile-name
                                                      #:archiver
-- 
2.21.0

^ permalink raw reply related	[relevance 47%]

* [bug#36093] [PATCH v2 1/2] services: Add Singularity.
  @ 2019-06-06 11:03 43% ` Ludovic Courtès
  2019-06-06 11:03 47%   ` [bug#36093] [PATCH v2 2/2] pack: Add '--entry-point' Ludovic Courtès
  0 siblings, 1 reply; 149+ results
From: Ludovic Courtès @ 2019-06-06 11:03 UTC (permalink / raw)
  To: 36093; +Cc: Ludovic Courtès

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* gnu/packages/linux.scm (singularity)[source](snippet): Change file
name of setuid helpers in libexec/cli/*.exec.
[arguments]: Remove "--disable-suid".
* gnu/services/docker.scm (%singularity-activation): New variable.
(singularity-setuid-programs): New procedure.
(singularity-service-type): New variable.
* gnu/tests/singularity.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* doc/guix.texi (Miscellaneous Services): Document it.
---
 doc/guix.texi             |  13 +++-
 gnu/local.mk              |   1 +
 gnu/packages/linux.scm    |  10 ++-
 gnu/services/docker.scm   |  61 +++++++++++++++++-
 gnu/tests/singularity.scm | 128 ++++++++++++++++++++++++++++++++++++++
 5 files changed, 208 insertions(+), 5 deletions(-)
 create mode 100644 gnu/tests/singularity.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 996255d9dc..c89df4ade3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24090,7 +24090,7 @@ The following is an example @code{dicod-service} configuration.
 @cindex Docker
 @subsubheading Docker Service
 
-The @code{(gnu services docker)} module provides the following service.
+The @code{(gnu services docker)} module provides the following services.
 
 @defvr {Scheme Variable} docker-service-type
 
@@ -24114,6 +24114,17 @@ The Containerd package to use.
 @end table
 @end deftp
 
+@defvr {Scheme Variable} singularity-service-type
+This is the type of the service that allows you to run
+@url{https://www.sylabs.io/singularity/, Singularity}, a Docker-style tool to
+create and run application bundles (aka. ``containers'').  The value for this
+service is the Singularity package to use.
+
+The service does not install a daemon; instead, it installs helper programs as
+setuid-root (@pxref{Setuid Programs}) such that unprivileged users can invoke
+@command{singularity run} and similar commands.
+@end defvr
+
 @node Setuid Programs
 @section Setuid Programs
 
diff --git a/gnu/local.mk b/gnu/local.mk
index 6878aef44a..c61ccff5e8 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -586,6 +586,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/networking.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
+  %D%/tests/singularity.scm			\
   %D%/tests/ssh.scm				\
   %D%/tests/version-control.scm			\
   %D%/tests/virtualization.scm			\
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index ffc5e9736e..e3cf2d729c 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -2884,12 +2884,16 @@ thanks to the use of namespaces.")
                   (substitute* "bin/singularity.in"
                     (("^PATH=.*" all)
                      (string-append "#" all "\n")))
+
+                  (substitute* (find-files "libexec/cli" "\\.exec$")
+                    (("\\$SINGULARITY_libexecdir/singularity/bin/([a-z]+)-suid"
+                      _ program)
+                     (string-append "/run/setuid-programs/singularity-"
+                                    program "-helper")))
                   #t))))
     (build-system gnu-build-system)
     (arguments
-     `(#:configure-flags
-       (list "--disable-suid"
-             "--localstatedir=/var")
+     `(#:configure-flags '("--localstatedir=/var")
        #:phases
        (modify-phases %standard-phases
          (add-after 'unpack 'patch-reference-to-squashfs-tools
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 94a04c8996..04f9127346 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -24,12 +24,14 @@
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages docker)
+  #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (guix packages)
 
   #:export (docker-configuration
-            docker-service-type))
+            docker-service-type
+            singularity-service-type))
 
 ;;; We're not using serialize-configuration, but we must define this because
 ;;; the define-configuration macro validates it exists.
@@ -120,3 +122,60 @@ bundles in Docker containers.")
                   (service-extension account-service-type
                                      (const %docker-accounts))))
                 (default-value (docker-configuration))))
+
+\f
+;;;
+;;; Singularity.
+;;;
+
+(define %singularity-activation
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+
+        (define %mount-directory
+          "/var/singularity/mnt/")
+
+        ;; Create the directories that Singularity 2.6 expects to find.  Make
+        ;; them #o755 like the 'install-data-hook' rule in 'Makefile.am' of
+        ;; Singularity 2.6.1.
+        (for-each (lambda (directory)
+                    (let ((directory (string-append %mount-directory
+                                                    directory)))
+                      (mkdir-p directory)
+                      (chmod directory #o755)))
+                  '("container" "final" "overlay" "session"))
+        (chmod %mount-directory #o755))))
+
+(define (singularity-setuid-programs singularity)
+  "Return the setuid-root programs that SINGULARITY needs."
+  (define helpers
+    ;; The helpers, under a meaningful name.
+    (computed-file "singularity-setuid-helpers"
+                   #~(begin
+                       (mkdir #$output)
+                       (for-each (lambda (program)
+                                   (symlink (string-append #$singularity
+                                                           "/libexec/singularity"
+                                                           "/bin/"
+                                                           program "-suid")
+                                            (string-append #$output
+                                                           "/singularity-"
+                                                           program
+                                                           "-helper")))
+                                 '("action" "mount" "start")))))
+
+  (list (file-append helpers "/singularity-action-helper")
+        (file-append helpers "/singularity-mount-helper")
+        (file-append helpers "/singularity-start-helper")))
+
+(define singularity-service-type
+  (service-type (name 'singularity)
+                (description
+                 "Install the Singularity application bundle tool.")
+                (extensions
+                 (list (service-extension setuid-program-service-type
+                                          singularity-setuid-programs)
+                       (service-extension activation-service-type
+                                          (const %singularity-activation))))
+                (default-value singularity)))
diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm
new file mode 100644
index 0000000000..55324ef9ea
--- /dev/null
+++ b/gnu/tests/singularity.scm
@@ -0,0 +1,128 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests singularity)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu services)
+  #:use-module (gnu services docker)
+  #:use-module (gnu packages bash)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages linux)               ;singularity
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module (guix grafts)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix scripts pack)
+  #:export (%test-singularity))
+
+(define %singularity-os
+  (simple-operating-system
+   (service singularity-service-type)
+   (simple-service 'guest-account
+                   account-service-type
+                   (list (user-account (name "guest") (uid 1000) (group "guest"))
+                         (user-group (name "guest") (id 1000))))))
+
+(define (run-singularity-test image)
+  "Load IMAGE, a Squashfs image, as a Singularity image and run it inside
+%SINGULARITY-OS."
+  (define os
+    (marionette-operating-system %singularity-os))
+
+  (define singularity-exec
+    #~(begin
+        (use-modules (ice-9 popen) (rnrs io ports))
+
+        (let* ((pipe (open-pipe* OPEN_READ
+                                 #$(file-append singularity
+                                                "/bin/singularity")
+                                 "exec" #$image "/bin/guile"
+                                 "-c" "(display \"hello, world\")"))
+               (str  (get-string-all pipe))
+               (status (close-pipe pipe)))
+          (and (zero? status)
+               (string=? str "hello, world")))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "singularity")
+
+          (test-assert "singularity exec /bin/guile (as root)"
+            (marionette-eval '#$singularity-exec
+                             marionette))
+
+          (test-equal "singularity exec /bin/guile (unprivileged)"
+            0
+            (marionette-eval
+             `(begin
+                (use-modules (ice-9 match))
+
+                (match (primitive-fork)
+                  (0
+                   (dynamic-wind
+                     (const #f)
+                     (lambda ()
+                       (setgid 1000)
+                       (setuid 1000)
+                       (execl #$(program-file "singularity-exec-test"
+                                              #~(exit #$singularity-exec))
+                              "test"))
+                     (lambda ()
+                       (primitive-exit 127))))
+                  (pid
+                   (cdr (waitpid pid)))))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "singularity-test" test))
+
+(define (build-tarball&run-singularity-test)
+  (mlet* %store-monad
+      ((_        (set-grafting #f))
+       (guile    (set-guile-for-build (default-guile)))
+       ;; 'singularity exec' insists on having /bin/sh in the image.
+       (profile  (profile-derivation (packages->manifest
+                                      (list bash-minimal guile-2.2))
+                                     #:hooks '()
+                                     #:locales? #f))
+       (tarball  (squashfs-image "singularity-pack" profile
+                                 #:symlinks '(("/bin" -> "bin")))))
+    (run-singularity-test tarball)))
+
+(define %test-singularity
+  (system-test
+   (name "singularity")
+   (description "Test Singularity container of Guix.")
+   (value (build-tarball&run-singularity-test))))
-- 
2.21.0

^ permalink raw reply related	[relevance 43%]

* [bug#36093] [PATCH 2/2] pack: Add '--entry-point'.
  2019-06-04 21:01 43% ` [bug#36093] [PATCH 1/2] services: Add Singularity Ludovic Courtès
@ 2019-06-04 21:01 47%   ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-06-04 21:01 UTC (permalink / raw)
  To: 36093; +Cc: Ludovic Courtès

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* guix/scripts/pack.scm (self-contained-tarball): Add #:entry-point and
warn when it's true.
(squashfs-image): Add #:entry-point and honor it.
(docker-image): Add #:entry-point and honor it.
(%options, show-help): Add '--entry-point'.
(guix-pack): Honor '--entry-point' and pass #:entry-point to BUILD-IMAGE.
* gnu/tests/docker.scm (run-docker-test): Test 'docker run' with the
default entry point.
(build-tarball&run-docker-test): Pass #:entry-point to 'docker-image'.
* doc/guix.texi (Invoking guix pack): Document it.
* gnu/tests/singularity.scm (run-singularity-test)["singularity run"]:
New test.
(build-tarball&run-singularity-test): Pass #:entry-point to
'squashfs-image'.
---
 doc/guix.texi             | 23 ++++++++++++++++++++++
 gnu/tests/docker.scm      | 19 +++++++++++-------
 gnu/tests/singularity.scm |  9 +++++++++
 guix/scripts/pack.scm     | 41 +++++++++++++++++++++++++++++++++++++++
 4 files changed, 85 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 2189f297bd..37af0ebd83 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4866,6 +4866,29 @@ advantage to work without requiring special kernel support, but it incurs
 run-time overhead every time a system call is made.
 @end quotation
 
+@cindex entry point, for Docker images
+@item --entry-point=@var{command}
+Use @var{command} as the @dfn{entry point} of the resulting pack, if the pack
+format supports it---currently @code{docker} and @code{squashfs} (Singularity)
+support it.  @var{command} must be relative to the profile contained in the
+pack.
+
+The entry point specifies the command that tools like @code{docker run} or
+@code{singularity run} automatically start by default.  For example, you can
+do:
+
+@example
+guix pack -f docker --entry-point=bin/guile guile
+@end example
+
+The resulting pack can easily be loaded and @code{docker run} with no extra
+arguments will spawn @code{bin/guile}:
+
+@example
+docker load -i pack.tar.gz
+docker run @var{image-id}
+@end example
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Consider the package @var{expr} evaluates to.
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 3cd3a27884..f2674cdbe8 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -101,7 +101,7 @@ inside %DOCKER-OS."
              marionette))
 
           (test-equal "Load docker image and run it"
-            "hello world"
+            '("hello world" "hi!")
             (marionette-eval
              `(begin
                 (define slurp
@@ -117,12 +117,16 @@ inside %DOCKER-OS."
                        (repository&tag (string-drop raw-line
                                                     (string-length
                                                      "Loaded image: ")))
-                       (response (slurp
-                                  ,(string-append #$docker-cli "/bin/docker")
-                                  "run" "--entrypoint" "bin/Guile"
-                                  repository&tag
-                                  "/aa.scm")))
-                  response))
+                       (response1 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" "--entrypoint" "bin/Guile"
+                                   repository&tag
+                                   "/aa.scm"))
+                       (response2 (slurp          ;default entry point
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" repository&tag
+                                   "-c" "(display \"hi!\")")))
+                  (list response1 response2)))
              marionette))
 
           (test-end)
@@ -161,6 +165,7 @@ standard output device and then enters a new line.")
        (tarball (docker-image "docker-pack" profile
                               #:symlinks '(("/bin/Guile" -> "bin/guile")
                                            ("aa.scm" -> "a.scm"))
+                              #:entry-point "bin/guile"
                               #:localstatedir? #t)))
     (run-docker-test tarball)))
 
diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm
index 55324ef9ea..668043a0bc 100644
--- a/gnu/tests/singularity.scm
+++ b/gnu/tests/singularity.scm
@@ -103,6 +103,14 @@
                    (cdr (waitpid pid)))))
              marionette))
 
+          (test-equal "singularity run"           ;test the entry point
+            42
+            (marionette-eval
+             `(status:exit-val
+               (system* #$(file-append singularity "/bin/singularity")
+                        "run" #$image "-c" "(exit 42)"))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
@@ -118,6 +126,7 @@
                                      #:hooks '()
                                      #:locales? #f))
        (tarball  (squashfs-image "singularity-pack" profile
+                                 #:entry-point "bin/guile"
                                  #:symlinks '(("/bin" -> "bin")))))
     (run-singularity-test tarball)))
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c17b374330..5da23e038b 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -152,6 +152,7 @@ dependencies are registered."
                                  #:key target
                                  (profile-name "guix-profile")
                                  deduplicate?
+                                 entry-point
                                  (compressor (first %compressors))
                                  localstatedir?
                                  (symlinks '())
@@ -275,6 +276,10 @@ added to the pack."
                                           (_ #f))
                                         directives)))))))))
 
+  (when entry-point
+    (warning (G_ "entry point not supported in the '~a' format~%")
+             'tarball))
+
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
                     build
@@ -284,6 +289,7 @@ added to the pack."
                          #:key target
                          (profile-name "guix-profile")
                          (compressor (first %compressors))
+                         entry-point
                          localstatedir?
                          (symlinks '())
                          (archiver squashfs-tools-next))
@@ -315,6 +321,7 @@ added to the pack."
                        (ice-9 match))
 
           (define database #+database)
+          (define entry-point #$entry-point)
 
           (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -371,6 +378,28 @@ added to the pack."
                                                             target)))))))
                       '#$symlinks)
 
+                   ;; Create /.singularity.d/actions, and optionally the 'run'
+                   ;; script, used by 'singularity run'.
+                   "-p" "/.singularity.d d 555 0 0"
+                   "-p" "/.singularity.d/actions d 555 0 0"
+                   ,@(if entry-point
+                         `(;; This one if for Singularity 2.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/actions/run s 777 0 0 "
+                             (relative-file-name "/.singularity.d/actions"
+                                                 (string-append #$profile "/"
+                                                                entry-point)))
+
+                           ;; This one is for Singularity 3.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/runscript s 777 0 0 "
+                             (relative-file-name "/.singularity.d"
+                                                 (string-append #$profile "/"
+                                                                entry-point))))
+                         '())
+
                    ;; Create empty mount points.
                    "-p" "/proc d 555 0 0"
                    "-p" "/sys d 555 0 0"
@@ -392,6 +421,7 @@ added to the pack."
                        #:key target
                        (profile-name "guix-profile")
                        (compressor (first %compressors))
+                       entry-point
                        localstatedir?
                        (symlinks '())
                        (archiver tar))
@@ -425,6 +455,8 @@ the image."
                                 #$profile
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
+                                #:entry-point (string-append #$profile "/"
+                                                             #$entry-point)
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
                                 #:creation-time (make-time time-utc 0 1))))))
@@ -689,6 +721,9 @@ please email '~a'~%")
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
                                (alist-delete 'system result eq?))))
+         (option '("entry-point") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'entry-point arg result)))
          (option '("target") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'target arg
@@ -765,6 +800,9 @@ Create a bundle of PACKAGE.\n"))
   -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
   (display (G_ "
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
+  (display (G_ "
+      --entry-point=PROGRAM
+                         use PROGRAM as the entry point of the pack"))
   (display (G_ "
       --save-provenance  save provenance information"))
   (display (G_ "
@@ -889,6 +927,7 @@ Create a bundle of PACKAGE.\n"))
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
                  (localstatedir? (assoc-ref opts 'localstatedir?))
+                 (entry-point    (assoc-ref opts 'entry-point))
                  (profile-name   (assoc-ref opts 'profile-name))
                  (gc-root        (assoc-ref opts 'gc-root)))
             (when (null? (manifest-entries manifest))
@@ -919,6 +958,8 @@ Create a bundle of PACKAGE.\n"))
                                                      symlinks
                                                      #:localstatedir?
                                                      localstatedir?
+                                                     #:entry-point
+                                                     entry-point
                                                      #:profile-name
                                                      profile-name
                                                      #:archiver
-- 
2.21.0

^ permalink raw reply related	[relevance 47%]

* [bug#36093] [PATCH 1/2] services: Add Singularity.
  @ 2019-06-04 21:01 43% ` Ludovic Courtès
  2019-06-04 21:01 47%   ` [bug#36093] [PATCH 2/2] pack: Add '--entry-point' Ludovic Courtès
  0 siblings, 1 reply; 149+ results
From: Ludovic Courtès @ 2019-06-04 21:01 UTC (permalink / raw)
  To: 36093; +Cc: Ludovic Courtès

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* gnu/packages/linux.scm (singularity)[source](snippet): Change file
name of setuid helpers in libexec/cli/*.exec.
[arguments]: Remove "--disable-suid".
* gnu/services/docker.scm (%singularity-activation): New variable.
(singularity-setuid-programs): New procedure.
(singularity-service-type): New variable.
* gnu/tests/singularity.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* doc/guix.texi (Miscellaneous Services): Document it.
---
 doc/guix.texi             |  13 +++-
 gnu/local.mk              |   1 +
 gnu/packages/linux.scm    |  10 ++-
 gnu/services/docker.scm   |  53 +++++++++++++++-
 gnu/tests/singularity.scm | 128 ++++++++++++++++++++++++++++++++++++++
 5 files changed, 200 insertions(+), 5 deletions(-)
 create mode 100644 gnu/tests/singularity.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index a8f3a5ad27..2189f297bd 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24090,7 +24090,7 @@ The following is an example @code{dicod-service} configuration.
 @cindex Docker
 @subsubheading Docker Service
 
-The @code{(gnu services docker)} module provides the following service.
+The @code{(gnu services docker)} module provides the following services.
 
 @defvr {Scheme Variable} docker-service-type
 
@@ -24114,6 +24114,17 @@ The Containerd package to use.
 @end table
 @end deftp
 
+@defvr {Scheme Variable} singularity-service-type
+This is the type of the service that runs
+@url{https://www.sylabs.io/singularity/, Singularity}, a Docker-style tool to
+create and run application bundles (aka. ``containers'').  The value for this
+service is the Singularity package to use.
+
+The service does not install a daemon; instead, it installs helper programs as
+setuid-root (@pxref{Setuid Programs}) such that unprivileged users can invoke
+@command{singularity run} and similar commands.
+@end defvr
+
 @node Setuid Programs
 @section Setuid Programs
 
diff --git a/gnu/local.mk b/gnu/local.mk
index b0992547b4..251c1eab64 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -586,6 +586,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/networking.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
+  %D%/tests/singularity.scm			\
   %D%/tests/ssh.scm				\
   %D%/tests/version-control.scm			\
   %D%/tests/virtualization.scm			\
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index ef45465288..4997fac181 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -2884,12 +2884,16 @@ thanks to the use of namespaces.")
                   (substitute* "bin/singularity.in"
                     (("^PATH=.*" all)
                      (string-append "#" all "\n")))
+
+                  (substitute* (find-files "libexec/cli" "\\.exec$")
+                    (("\\$SINGULARITY_libexecdir/singularity/bin/([a-z]+)-suid"
+                      _ program)
+                     (string-append "/run/setuid-programs/singularity-"
+                                    program "-helper")))
                   #t))))
     (build-system gnu-build-system)
     (arguments
-     `(#:configure-flags
-       (list "--disable-suid"
-             "--localstatedir=/var")
+     `(#:configure-flags '("--localstatedir=/var")
        #:phases
        (modify-phases %standard-phases
          (add-after 'unpack 'patch-reference-to-squashfs-tools
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 94a04c8996..b245513913 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -24,12 +24,14 @@
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages docker)
+  #:use-module (gnu packages linux)               ;singularity
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (guix packages)
 
   #:export (docker-configuration
-            docker-service-type))
+            docker-service-type
+            singularity-service-type))
 
 ;;; We're not using serialize-configuration, but we must define this because
 ;;; the define-configuration macro validates it exists.
@@ -120,3 +122,52 @@ bundles in Docker containers.")
                   (service-extension account-service-type
                                      (const %docker-accounts))))
                 (default-value (docker-configuration))))
+
+\f
+;;;
+;;; Singularity.
+;;;
+
+(define %singularity-activation
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+
+        ;; Create the directories that Singularity 2.6 expects to find.
+        (for-each (lambda (directory)
+                    (mkdir-p (string-append "/var/singularity/mnt/"
+                                            directory)))
+                  '("container" "final" "overlay" "session")))))
+
+(define (singularity-setuid-programs singularity)
+  "Return the setuid-root programs that SINGULARITY needs."
+  (define helpers
+    ;; The helpers, under a meaningful name.
+    (computed-file "singularity-setuid-helpers"
+                   #~(begin
+                       (mkdir #$output)
+                       (for-each (lambda (program)
+                                   (symlink (string-append #$singularity
+                                                           "/libexec/singularity"
+                                                           "/bin/"
+                                                           program "-suid")
+                                            (string-append #$output
+                                                           "/singularity-"
+                                                           program
+                                                           "-helper")))
+                                 '("action" "mount" "start")))))
+
+  (list (file-append helpers "/singularity-action-helper")
+        (file-append helpers "/singularity-mount-helper")
+        (file-append helpers "/singularity-start-helper")))
+
+(define singularity-service-type
+  (service-type (name 'singularity)
+                (description
+                 "Install the Singularity application bundle tool.")
+                (extensions
+                 (list (service-extension setuid-program-service-type
+                                          singularity-setuid-programs)
+                       (service-extension activation-service-type
+                                          (const %singularity-activation))))
+                (default-value singularity)))
diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm
new file mode 100644
index 0000000000..55324ef9ea
--- /dev/null
+++ b/gnu/tests/singularity.scm
@@ -0,0 +1,128 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests singularity)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu services)
+  #:use-module (gnu services docker)
+  #:use-module (gnu packages bash)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages linux)               ;singularity
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module (guix grafts)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix scripts pack)
+  #:export (%test-singularity))
+
+(define %singularity-os
+  (simple-operating-system
+   (service singularity-service-type)
+   (simple-service 'guest-account
+                   account-service-type
+                   (list (user-account (name "guest") (uid 1000) (group "guest"))
+                         (user-group (name "guest") (id 1000))))))
+
+(define (run-singularity-test image)
+  "Load IMAGE, a Squashfs image, as a Singularity image and run it inside
+%SINGULARITY-OS."
+  (define os
+    (marionette-operating-system %singularity-os))
+
+  (define singularity-exec
+    #~(begin
+        (use-modules (ice-9 popen) (rnrs io ports))
+
+        (let* ((pipe (open-pipe* OPEN_READ
+                                 #$(file-append singularity
+                                                "/bin/singularity")
+                                 "exec" #$image "/bin/guile"
+                                 "-c" "(display \"hello, world\")"))
+               (str  (get-string-all pipe))
+               (status (close-pipe pipe)))
+          (and (zero? status)
+               (string=? str "hello, world")))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "singularity")
+
+          (test-assert "singularity exec /bin/guile (as root)"
+            (marionette-eval '#$singularity-exec
+                             marionette))
+
+          (test-equal "singularity exec /bin/guile (unprivileged)"
+            0
+            (marionette-eval
+             `(begin
+                (use-modules (ice-9 match))
+
+                (match (primitive-fork)
+                  (0
+                   (dynamic-wind
+                     (const #f)
+                     (lambda ()
+                       (setgid 1000)
+                       (setuid 1000)
+                       (execl #$(program-file "singularity-exec-test"
+                                              #~(exit #$singularity-exec))
+                              "test"))
+                     (lambda ()
+                       (primitive-exit 127))))
+                  (pid
+                   (cdr (waitpid pid)))))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "singularity-test" test))
+
+(define (build-tarball&run-singularity-test)
+  (mlet* %store-monad
+      ((_        (set-grafting #f))
+       (guile    (set-guile-for-build (default-guile)))
+       ;; 'singularity exec' insists on having /bin/sh in the image.
+       (profile  (profile-derivation (packages->manifest
+                                      (list bash-minimal guile-2.2))
+                                     #:hooks '()
+                                     #:locales? #f))
+       (tarball  (squashfs-image "singularity-pack" profile
+                                 #:symlinks '(("/bin" -> "bin")))))
+    (run-singularity-test tarball)))
+
+(define %test-singularity
+  (system-test
+   (name "singularity")
+   (description "Test Singularity container of Guix.")
+   (value (build-tarball&run-singularity-test))))
-- 
2.21.0

^ permalink raw reply related	[relevance 43%]

* [bug#35697] [PATCH 7/8] docker: 'build-docker-image' accepts an optional #:entry-point.
  @ 2019-05-12 10:38 65% ` Ludovic Courtès
  2019-05-12 10:38 45% ` [bug#35697] [PATCH 8/8] vm: 'system-docker-image' provides an entry point Ludovic Courtès
  1 sibling, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-05-12 10:38 UTC (permalink / raw)
  To: 35697; +Cc: Chris Marusich

* guix/docker.scm (config): Add #:entry-point and honor it.
(build-docker-image): Likewise.
---
 guix/docker.scm | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index c6e9c6fee5..7fe83d9797 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -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)
+(define* (config layer time arch #:key entry-point)
   "Generate a minimal image configuration for the given LAYER file."
   ;; "architecture" must be values matching "platform.arch" in the
   ;; runtime-spec at
@@ -81,7 +81,9 @@
   `((architecture . ,arch)
     (comment . "Generated by GNU Guix")
     (created . ,time)
-    (config . #nil)
+    (config . ,(if entry-point
+                   `((entrypoint . ,entry-point))
+                   #nil))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
@@ -110,6 +112,7 @@ return \"a\"."
                              (transformations '())
                              (system (utsname:machine (uname)))
                              database
+                             entry-point
                              compressor
                              (creation-time (current-time time-utc)))
   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
@@ -118,6 +121,9 @@ must be a store path that is a prefix of any store paths in PATHS.
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
 
+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.
+
 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
@@ -227,7 +233,8 @@ SRFI-19 time-utc object, as the creation time in metadata."
       (with-output-to-file "config.json"
         (lambda ()
           (scm->json (config (string-append id "/layer.tar")
-                             time arch))))
+                             time arch
+                             #:entry-point entry-point))))
       (with-output-to-file "manifest.json"
         (lambda ()
           (scm->json (manifest prefix id))))
-- 
2.21.0

^ permalink raw reply related	[relevance 65%]

* [bug#35697] [PATCH 8/8] vm: 'system-docker-image' provides an entry point.
    2019-05-12 10:38 65% ` [bug#35697] [PATCH 7/8] docker: 'build-docker-image' accepts an optional #:entry-point Ludovic Courtès
@ 2019-05-12 10:38 45% ` Ludovic Courtès
  1 sibling, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-05-12 10:38 UTC (permalink / raw)
  To: 35697; +Cc: Chris Marusich

This simplifies use of images created with 'guix system docker-image'.

* gnu/system/vm.scm (system-docker-image)[boot-program]: New variable.
[os]: Add it to the GC roots.
[build]: Pass #:entry-point to 'build-docker-image'.
* gnu/tests/docker.scm (run-docker-system-test): New procedure.
(%test-docker-system): New variable.
* doc/guix.texi (Invoking guix system): Remove GUIX_NEW_SYSTEM hack and
'--entrypoint' from the example.  Mention 'docker create', 'docker
start', and 'docker exec'.
---
 doc/guix.texi        |  18 ++++---
 gnu/system/vm.scm    |  18 ++++++-
 gnu/tests/docker.scm | 118 ++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 145 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index df7208229c..da65fd8a4e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24497,20 +24497,26 @@ system configuration file.  You can then load the image and launch a
 Docker container using commands like the following:
 
 @example
-image_id="$(docker load < guix-system-docker-image.tar.gz)"
-docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
-    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
-    $image_id /var/guix/profiles/system/boot
+image_id="`docker load < guix-system-docker-image.tar.gz`"
+container_id="`docker create $image_id`"
+docker start $container_id
 @end example
 
 This command starts a new Docker container from the specified image.  It
 will boot the Guix system in the usual manner, which means it will
 start any services you have defined in the operating system
-configuration.  Depending on what you run in the Docker container, it
+configuration.  You can get an interactive shell running in the container
+using @command{docker exec}:
+
+@example
+docker exec -ti $container_id /run/current-system/profile/bin/bash --login
+@end example
+
+Depending on what you run in the Docker container, it
 may be necessary to give the container additional permissions.  For
 example, if you intend to build software using Guix inside of the Docker
 container, you may need to pass the @option{--privileged} option to
-@code{docker run}.
+@code{docker create}.
 
 @item container
 Return a script to run the operating system declared in @var{file}
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 124abd0fc9..f3027cd4ca 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -473,7 +473,7 @@ the image."
 
 (define* (system-docker-image os
                               #:key
-                              (name "guixsd-docker-image")
+                              (name "guix-docker-image")
                               register-closures?)
   "Build a docker image.  OS is the desired <operating-system>.  NAME is the
 base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
@@ -487,7 +487,19 @@ should set REGISTER-CLOSURES? to #f."
          (local-file (search-path %load-path
                                   "guix/store/schema.sql"))))
 
-  (let ((os    (containerized-operating-system os '()))
+  (define boot-program
+    ;; Program that runs the boot script of OS, which in turn starts shepherd.
+    (program-file "boot-program"
+                  #~(let ((system (cadr (command-line))))
+                      (setenv "GUIX_NEW_SYSTEM" system)
+                      (execl #$(file-append guile-2.2 "/bin/guile")
+                             "guile" "--no-auto-compile"
+                             (string-append system "/boot")))))
+
+
+  (let ((os    (operating-system-with-gc-roots
+                (containerized-operating-system os '())
+                (list boot-program)))
         (name  (string-append name ".tar.gz"))
         (graph "system-graph"))
     (define build
@@ -538,9 +550,11 @@ should set REGISTER-CLOSURES? to #f."
                                  (string-append "/xchg/" #$graph)
                                read-reference-graph)))
                  #$os
+                 #:entry-point '(#$boot-program #$os)
                  #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
                  #:creation-time (make-time time-utc 0 1)
                  #:transformations `((,root-directory -> ""))))))))
+
     (expression->derivation-in-linux-vm
      name build
      #:make-disk-image? #f
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 25e172efae..3cd3a27884 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@
   #: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)
   #:use-module (guix grafts)
   #:use-module (guix monads)
@@ -38,7 +40,8 @@
   #:use-module (guix tests)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
-  #:export (%test-docker))
+  #:export (%test-docker
+            %test-docker-system))
 
 (define %docker-os
   (simple-operating-system
@@ -166,3 +169,116 @@ standard output device and then enters a new line.")
    (name "docker")
    (description "Test Docker container of Guix.")
    (value (build-tarball&run-docker-test))))
+
+\f
+(define (run-docker-system-test tarball)
+  "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
+inside %DOCKER-OS."
+  (define os
+    (marionette-operating-system
+     %docker-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     ;; FIXME: Because we're using the volatile-root setup where the root file
+     ;; system is a tmpfs overlaid over a small root file system, 'docker
+     ;; load' must be able to store the whole image into memory, hence the
+     ;; huge memory requirements.  We should avoid the volatile-root setup
+     ;; instead.
+     (memory-size 3000)
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix build utils))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette)
+                       (guix build utils))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "docker")
+
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'dockerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "load system image and run it"
+            (marionette-eval
+             `(begin
+                (define (slurp command . args)
+                  ;; Return the output from COMMAND.
+                  (let* ((port (apply open-pipe* OPEN_READ command args))
+                         (output (read-line port))
+                         (status (close-pipe port)))
+                    output))
+
+                (define (docker-cli command . args)
+                  ;; Run the given Docker COMMAND.
+                  (apply invoke #$(file-append docker-cli "/bin/docker")
+                         command args))
+
+                (define (wait-for-container-file container file)
+                  ;; Wait for FILE to show up in CONTAINER.
+                  (docker-cli "exec" container
+                              #$(file-append guile-2.2 "/bin/guile")
+                              "-c"
+                              (object->string
+                               `(let loop ((n 15))
+                                  (when (zero? n)
+                                    (error "file didn't show up" ,file))
+                                  (unless (file-exists? ,file)
+                                    (sleep 1)
+                                    (loop (- n 1)))))))
+
+                (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
+                                    "load" "-i" #$tarball))
+                       (repository&tag (string-drop line
+                                                    (string-length
+                                                     "Loaded image: ")))
+                       (container (slurp
+                                   #$(file-append docker-cli "/bin/docker")
+                                   "create" repository&tag)))
+                  (docker-cli "start" container)
+
+                  ;; Wait for shepherd to be ready.
+                  (wait-for-container-file container
+                                           "/var/run/shepherd/socket")
+
+                  (docker-cli "exec" container
+                              "/run/current-system/profile/bin/herd"
+                              "status")
+                  (slurp #$(file-append docker-cli "/bin/docker")
+                         "exec" container
+                         "/run/current-system/profile/bin/herd"
+                         "status" "guix-daemon")))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "docker-system-test" test))
+
+(define %test-docker-system
+  (system-test
+   (name "docker-system")
+   (description "Run a system image as produced by @command{guix system
+docker-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (system-docker-image (simple-operating-system))
+                 run-docker-system-test)))))
-- 
2.21.0

^ permalink raw reply related	[relevance 45%]

* [bug#35282] [PATCHv2] gnu: docker: Patch paths of xz and docker-proxy.
  @ 2019-04-15 20:19 98%   ` Maxim Cournoyer
  0 siblings, 0 replies; 149+ results
From: Maxim Cournoyer @ 2019-04-15 20:19 UTC (permalink / raw)
  To: Danny Milosavljevic; +Cc: 35282


[-- Attachment #1.1: Type: text/plain, Size: 186 bytes --]

Hello again,

Actually, the proposed change was not sufficient, as it would transform
reexec.Command -> exec.Command. The attached series fixes it (patch
0003, with the other rebased).


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-gnu-docker-Fix-indentation.patch --]
[-- Type: text/x-patch, Size: 14540 bytes --]

From 1405716eff1c15bf2a44704f4a32e6e823f73bf2 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 21:55:48 -0400
Subject: [PATCH 1/7] gnu: docker: Fix indentation.

* gnu/packages/docker.scm (docker): Fix indentation using Emacs.
---
 gnu/packages/docker.scm | 184 ++++++++++++++++++++--------------------
 1 file changed, 92 insertions(+), 92 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 1067555296..7445856347 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -299,17 +299,17 @@ built-in registry server of Docker.")
     (version %docker-version)
     (source
      (origin
-      (method git-fetch)
-      (uri (git-reference
-            (url "https://github.com/docker/engine.git")
-            (commit (string-append "v" version))))
-      (file-name (git-file-name name version))
-      (sha256
-       (base32 "06yr5xwr181lalh8z1lk07nxlp7hn38aq8cyqjk617dfy4lz0ixx"))
-      (patches
-       (search-patches "docker-engine-test-noinstall.patch"
-                       "docker-fix-tests.patch"
-                       "docker-use-fewer-modprobes.patch"))))
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/docker/engine.git")
+             (commit (string-append "v" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "06yr5xwr181lalh8z1lk07nxlp7hn38aq8cyqjk617dfy4lz0ixx"))
+       (patches
+        (search-patches "docker-engine-test-noinstall.patch"
+                        "docker-fix-tests.patch"
+                        "docker-use-fewer-modprobes.patch"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -326,77 +326,77 @@ built-in registry server of Docker.")
          (add-after 'unpack 'patch-paths
            (lambda* (#:key inputs #:allow-other-keys)
              (substitute* "builder/builder-next/executor_unix.go"
-              (("CommandCandidates:.*runc.*")
-               (string-append "CommandCandidates: []string{\""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"},\n")))
+               (("CommandCandidates:.*runc.*")
+                (string-append "CommandCandidates: []string{\""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"},\n")))
              (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-              (("DefaultCommand = .*")
-               (string-append "DefaultCommand = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n")))
+               (("DefaultCommand = .*")
+                (string-append "DefaultCommand = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n")))
              (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
-              (("defaultRuntime[ \t]*=.*")
-               (string-append "defaultRuntime = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n"))
-              (("defaultShim[ \t]*=.*")
-               (string-append "defaultShim = \""
-                              (assoc-ref inputs "containerd")
-                              "/bin/containerd-shim\"\n")))
+               (("defaultRuntime[ \t]*=.*")
+                (string-append "defaultRuntime = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n"))
+               (("defaultShim[ \t]*=.*")
+                (string-append "defaultShim = \""
+                               (assoc-ref inputs "containerd")
+                               "/bin/containerd-shim\"\n")))
              (substitute* "daemon/daemon_unix.go"
-              (("DefaultShimBinary = .*")
-               (string-append "DefaultShimBinary = \""
-                              (assoc-ref inputs "containerd")
-                              "/bin/containerd-shim\"\n"))
-              (("DefaultRuntimeBinary = .*")
-               (string-append "DefaultRuntimeBinary = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n"))
-              (("DefaultRuntimeName = .*")
-               (string-append "DefaultRuntimeName = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n")))
+               (("DefaultShimBinary = .*")
+                (string-append "DefaultShimBinary = \""
+                               (assoc-ref inputs "containerd")
+                               "/bin/containerd-shim\"\n"))
+               (("DefaultRuntimeBinary = .*")
+                (string-append "DefaultRuntimeBinary = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n"))
+               (("DefaultRuntimeName = .*")
+                (string-append "DefaultRuntimeName = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n")))
              (substitute* "daemon/config/config.go"
-              (("StockRuntimeName = .*")
-               (string-append "StockRuntimeName = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n")))
+               (("StockRuntimeName = .*")
+                (string-append "StockRuntimeName = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n")))
              (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
-              (("var defaultCommandCandidates = .*")
-               (string-append "var defaultCommandCandidates = []string{\""
-                              (assoc-ref inputs "runc") "/sbin/runc\"}")))
+               (("var defaultCommandCandidates = .*")
+                (string-append "var defaultCommandCandidates = []string{\""
+                               (assoc-ref inputs "runc") "/sbin/runc\"}")))
              (let ((source-files (filter (lambda (name)
-                                    (not (string-contains name "test")))
-                                  (find-files "." "\\.go$"))))
+                                           (not (string-contains name "test")))
+                                         (find-files "." "\\.go$"))))
                (let-syntax ((substitute-LookPath
                              (lambda (x)
                                (syntax-case x ()
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                     ((#,(string-append "exec\\.LookPath\\(\""
-                                                        (syntax->datum
-                                                         #'source-text)
-                                                        "\")"))
-                                      (string-append "\""
-                                                     (assoc-ref inputs package)
-                                                     relative-path
-                                                     "\", error(nil)")))))))
+                                      ((#,(string-append "exec\\.LookPath\\(\""
+                                                         (syntax->datum
+                                                          #'source-text)
+                                                         "\")"))
+                                       (string-append "\""
+                                                      (assoc-ref inputs package)
+                                                      relative-path
+                                                      "\", error(nil)")))))))
                             (substitute-Command
                              (lambda (x)
                                (syntax-case x ()
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                     ((#,(string-append "exec\\.Command\\(\""
-                                                        (syntax->datum
-                                                         #'source-text)
-                                                        "\"")) ; )
-                                      (string-append "exec.Command(\""
-                                                     (assoc-ref inputs package)
-                                                     relative-path
-                                                     "\"")))))))) ; )
+                                      ((#,(string-append "exec\\.Command\\(\""
+                                                         (syntax->datum
+                                                          #'source-text)
+                                                         "\"")) ; )
+                                       (string-append "exec.Command(\""
+                                                      (assoc-ref inputs package)
+                                                      relative-path
+                                                      "\"")))))))) ; )
                  (substitute-LookPath "ps" "procps" "/bin/ps")
                  (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
                  (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
@@ -418,13 +418,13 @@ built-in registry server of Docker.")
                  (substitute-Command "tune2fs" "e2fsprogs" "/sbin/tune2fs")
                  (substitute-Command "blkid" "util-linux" "/sbin/blkid")
                  (substitute-Command "resize2fs" "e2fsprogs" "/sbin/resize2fs")
-; docker-mountfrom ??
-; docker
-; docker-untar ??
-; docker-applyLayer ??
-; /usr/bin/uname
-; grep
-; apparmor_parser
+                 ;; docker-mountfrom ??
+                 ;; docker
+                 ;; docker-untar ??
+                 ;; docker-applyLayer ??
+                 ;; /usr/bin/uname
+                 ;; grep
+                 ;; apparmor_parser
                  (substitute-Command "ps" "procps" "/bin/ps")
                  (substitute-Command "losetup" "util-linux" "/sbin/losetup")
                  (substitute-Command "uname" "coreutils" "/bin/uname")
@@ -434,24 +434,24 @@ built-in registry server of Docker.")
                ;; invokes other programs we don't know about and thus don't
                ;; substitute.
                (substitute* source-files
-                ;; Search for Java in PATH.
-                (("\\<exec\\.Command\\(\"java\"") ; )
-                 "xxec.Command(\"java\"") ; )
-                ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                (("\\<exec\\.Command\\(\"auplink\"") ; )
-                 "xxec.Command(\"auplink\"") ; )
-                ;; Fail on other unsubstituted commands.
-                (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                  _ executable) ; )
-                 (string-append "exec.Guix_doesnt_want_Command(\""
-                                executable "\"")) ;)
-                (("\\<xxec\\.Command")
-                 "exec.Command")
-                ;; Search for ZFS in PATH.
-                (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
-                ;; Fail on other unsubstituted LookPaths.
-                (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"") ; ))
-                (("\\<LooxPath") "LookPath")))
+                 ;; Search for Java in PATH.
+                 (("\\<exec\\.Command\\(\"java\"") ; )
+                  "xxec.Command(\"java\"")         ; )
+                 ;; Search for AUFS in PATH (mainline Linux doesn't support it).
+                 (("\\<exec\\.Command\\(\"auplink\"") ; )
+                  "xxec.Command(\"auplink\"")         ; )
+                 ;; Fail on other unsubstituted commands.
+                 (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
+                   _ executable)        ; )
+                  (string-append "exec.Guix_doesnt_want_Command(\""
+                                 executable "\"")) ;)
+                 (("\\<xxec\\.Command")
+                  "exec.Command")
+                 ;; Search for ZFS in PATH.
+                 (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                 ;; Fail on other unsubstituted LookPaths.
+                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"") ; ))
+                 (("\\<LooxPath") "LookPath")))
              #t))
          (add-after 'patch-paths 'delete-failing-tests
            (lambda _
@@ -498,7 +498,7 @@ built-in registry server of Docker.")
              ;; But go needs to have the uncanonicalized directory name, so
              ;; store that.
              (setenv "PWD" (string-append (getcwd)
-                            "/.gopath/src/github.com/docker/docker"))
+                                          "/.gopath/src/github.com/docker/docker"))
              (with-directory-excursion ".gopath/src/github.com/docker/docker"
                (invoke "hack/test/unit"))
              (setenv "PWD" #f)
@@ -512,7 +512,7 @@ built-in registry server of Docker.")
                #t))))))
     (inputs
      `(("btrfs-progs" ,btrfs-progs)
-       ("containerd" ,containerd) ; for containerd-shim
+       ("containerd" ,containerd)       ; for containerd-shim
        ("coreutils" ,coreutils)
        ("dbus" ,dbus)
        ("e2fsprogs" ,e2fsprogs)
@@ -528,7 +528,7 @@ built-in registry server of Docker.")
        ("lvm2" ,lvm2)
        ("xfsprogs" ,xfsprogs)))
     (native-inputs
-     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+     `(("eudev" ,eudev)      ; TODO: Should be propagated by lvm2 (.pc -> .pc)
        ("go" ,go)
        ("pkg-config" ,pkg-config)))
     (synopsis "Docker container component library, and daemon")
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.3: 0002-gnu-docker-Cleanup-extraneous-comments.patch --]
[-- Type: text/x-patch, Size: 3247 bytes --]

From 64b8226b954c18aa9fd246c26b8c5958fa5d2e86 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 22:08:52 -0400
Subject: [PATCH 2/7] gnu: docker: Cleanup extraneous comments.

* gnu/packages/docker.scm (docker): Remove "parenthesis-balancing" comments.
---
 gnu/packages/docker.scm | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 7445856347..10aa3aa5b4 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -392,11 +392,11 @@ built-in registry server of Docker.")
                                       ((#,(string-append "exec\\.Command\\(\""
                                                          (syntax->datum
                                                           #'source-text)
-                                                         "\"")) ; )
+                                                         "\""))
                                        (string-append "exec.Command(\""
                                                       (assoc-ref inputs package)
                                                       relative-path
-                                                      "\"")))))))) ; )
+                                                      "\""))))))))
                  (substitute-LookPath "ps" "procps" "/bin/ps")
                  (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
                  (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
@@ -435,22 +435,22 @@ built-in registry server of Docker.")
                ;; substitute.
                (substitute* source-files
                  ;; Search for Java in PATH.
-                 (("\\<exec\\.Command\\(\"java\"") ; )
-                  "xxec.Command(\"java\"")         ; )
+                 (("\\<exec\\.Command\\(\"java\"")
+                  "xxec.Command(\"java\"")
                  ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                 (("\\<exec\\.Command\\(\"auplink\"") ; )
-                  "xxec.Command(\"auplink\"")         ; )
+                 (("\\<exec\\.Command\\(\"auplink\"")
+                  "xxec.Command(\"auplink\"")
                  ;; Fail on other unsubstituted commands.
                  (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                   _ executable)        ; )
+                   _ executable)
                   (string-append "exec.Guix_doesnt_want_Command(\""
-                                 executable "\"")) ;)
+                                 executable "\""))
                  (("\\<xxec\\.Command")
                   "exec.Command")
                  ;; Search for ZFS in PATH.
                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
                  ;; Fail on other unsubstituted LookPaths.
-                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"") ; ))
+                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
                  (("\\<LooxPath") "LookPath")))
              #t))
          (add-after 'patch-paths 'delete-failing-tests
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.4: 0003-gnu-docker-Harmonize-LookPath-regexes.patch --]
[-- Type: text/x-patch, Size: 2530 bytes --]

From 9d7cc43b251061b15dbd70f0fe45696ec7b55f2e Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 22:12:00 -0400
Subject: [PATCH 3/7] gnu: docker: Harmonize LookPath regexes.

* gnu/packages/docker.scm (docker)[phases]: In the patch-paths phase, update
the regexes used by SUBSTITUTE-LOOKPATH and SUBSTITUTE-COMMAND to match at the
start of the word, like it's done later.
---
 gnu/packages/docker.scm | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 10aa3aa5b4..ce9d4d4643 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -375,7 +375,7 @@ built-in registry server of Docker.")
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                      ((#,(string-append "exec\\.LookPath\\(\""
+                                      ((#,(string-append "\\<exec\\.LookPath\\(\""
                                                          (syntax->datum
                                                           #'source-text)
                                                          "\")"))
@@ -389,11 +389,12 @@ built-in registry server of Docker.")
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                      ((#,(string-append "exec\\.Command\\(\""
+                                      ((#,(string-append "\\<(re)?exec\\.Command\\(\""
                                                          (syntax->datum
                                                           #'source-text)
-                                                         "\""))
-                                       (string-append "exec.Command(\""
+                                                         "\"") _ re?)
+                                       (string-append (if re? re? "")
+                                                      "exec.Command(\""
                                                       (assoc-ref inputs package)
                                                       relative-path
                                                       "\""))))))))
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.5: 0004-gnu-docker-Make-macros-use-a-relative-path-as-argume.patch --]
[-- Type: text/x-patch, Size: 6242 bytes --]

From 8776742130efab07e2f00287d039ec2fbf5e21bf Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 22:57:33 -0400
Subject: [PATCH 4/7] gnu: docker: Make macros use a relative path as argument.

* gnu/packages/docker.scm (docker)[phases]: Move implementation detail inside
the SUBSTITUTE-LOOKPATH and SUBSTITUTE-COMMAND macros definition, so that the
relative path argument can be given as a relative path.
---
 gnu/packages/docker.scm | 56 ++++++++++++++++++++---------------------
 1 file changed, 28 insertions(+), 28 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index ce9d4d4643..f6e0e813ba 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -381,7 +381,7 @@ built-in registry server of Docker.")
                                                          "\")"))
                                        (string-append "\""
                                                       (assoc-ref inputs package)
-                                                      relative-path
+                                                      "/" relative-path
                                                       "\", error(nil)")))))))
                             (substitute-Command
                              (lambda (x)
@@ -396,29 +396,29 @@ built-in registry server of Docker.")
                                        (string-append (if re? re? "")
                                                       "exec.Command(\""
                                                       (assoc-ref inputs package)
-                                                      relative-path
+                                                      "/" relative-path
                                                       "\""))))))))
-                 (substitute-LookPath "ps" "procps" "/bin/ps")
-                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
-                 (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
-                 (substitute-LookPath "pvdisplay" "lvm2" "/sbin/pvdisplay")
-                 (substitute-LookPath "blkid" "util-linux" "/sbin/blkid")
-                 (substitute-LookPath "unpigz" "pigz" "/bin/unpigz")
-                 (substitute-LookPath "iptables" "iptables" "/sbin/iptables")
-                 (substitute-LookPath "iptables-legacy" "iptables" "/sbin/iptables")
-                 (substitute-LookPath "ip" "iproute2" "/sbin/ip")
-                 (substitute-Command "modprobe" "kmod" "/bin/modprobe")
-                 (substitute-Command "pvcreate" "lvm2" "/sbin/pvcreate")
-                 (substitute-Command "vgcreate" "lvm2" "/sbin/vgcreate")
-                 (substitute-Command "lvcreate" "lvm2" "/sbin/lvcreate")
-                 (substitute-Command "lvconvert" "lvm2" "/sbin/lvconvert")
-                 (substitute-Command "lvchange" "lvm2" "/sbin/lvchange")
-                 (substitute-Command "mkfs.xfs" "xfsprogs" "/sbin/mkfs.xfs")
-                 (substitute-Command "xfs_growfs" "xfsprogs" "/sbin/xfs_growfs")
-                 (substitute-Command "mkfs.ext4" "e2fsprogs" "/sbin/mkfs.ext4")
-                 (substitute-Command "tune2fs" "e2fsprogs" "/sbin/tune2fs")
-                 (substitute-Command "blkid" "util-linux" "/sbin/blkid")
-                 (substitute-Command "resize2fs" "e2fsprogs" "/sbin/resize2fs")
+                 (substitute-LookPath "ps" "procps" "bin/ps")
+                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
+                 (substitute-LookPath "lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
+                 (substitute-LookPath "pvdisplay" "lvm2" "sbin/pvdisplay")
+                 (substitute-LookPath "blkid" "util-linux" "sbin/blkid")
+                 (substitute-LookPath "unpigz" "pigz" "bin/unpigz")
+                 (substitute-LookPath "iptables" "iptables" "sbin/iptables")
+                 (substitute-LookPath "iptables-legacy" "iptables" "sbin/iptables")
+                 (substitute-LookPath "ip" "iproute2" "sbin/ip")
+                 (substitute-Command "modprobe" "kmod" "bin/modprobe")
+                 (substitute-Command "pvcreate" "lvm2" "sbin/pvcreate")
+                 (substitute-Command "vgcreate" "lvm2" "sbin/vgcreate")
+                 (substitute-Command "lvcreate" "lvm2" "sbin/lvcreate")
+                 (substitute-Command "lvconvert" "lvm2" "sbin/lvconvert")
+                 (substitute-Command "lvchange" "lvm2" "sbin/lvchange")
+                 (substitute-Command "mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
+                 (substitute-Command "xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
+                 (substitute-Command "mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
+                 (substitute-Command "tune2fs" "e2fsprogs" "sbin/tune2fs")
+                 (substitute-Command "blkid" "util-linux" "sbin/blkid")
+                 (substitute-Command "resize2fs" "e2fsprogs" "sbin/resize2fs")
                  ;; docker-mountfrom ??
                  ;; docker
                  ;; docker-untar ??
@@ -426,11 +426,11 @@ built-in registry server of Docker.")
                  ;; /usr/bin/uname
                  ;; grep
                  ;; apparmor_parser
-                 (substitute-Command "ps" "procps" "/bin/ps")
-                 (substitute-Command "losetup" "util-linux" "/sbin/losetup")
-                 (substitute-Command "uname" "coreutils" "/bin/uname")
-                 (substitute-Command "dbus-launch" "dbus" "/bin/dbus-launch")
-                 (substitute-Command "git" "git" "/bin/git"))
+                 (substitute-Command "ps" "procps" "bin/ps")
+                 (substitute-Command "losetup" "util-linux" "sbin/losetup")
+                 (substitute-Command "uname" "coreutils" "bin/uname")
+                 (substitute-Command "dbus-launch" "dbus" "bin/dbus-launch")
+                 (substitute-Command "git" "git" "bin/git"))
                ;; Make compilation fail when, in future versions, Docker
                ;; invokes other programs we don't know about and thus don't
                ;; substitute.
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.6: 0005-gnu-docker-Optimize-substitution-macros.patch --]
[-- Type: text/x-patch, Size: 9007 bytes --]

From 6599410beb1b71bfdd71658554cecc08d7471e3a Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 13 Apr 2019 22:00:45 -0400
Subject: [PATCH 5/7] gnu: docker: Optimize substitution macros.

This change halves the time needed to patch the paths.

* gnu/packages/docker.scm (docker)[phases]{patch-paths}: Allow passing
multiple SOURCE-TEXT, PACKAGE and RELATIVE-PATH tuples so that the rewrite
rules can be generated and processed by a single use of the SUBSTITUTE*
macro.  Rename SUBSTITUTE-LOOKPATH to SUBSTITUTE-LOOKPATH* and
substitute-Command to SUBSTITUTE-COMMAND* to denote the change.  Adapt the
uses of SUBSTITUTE-LOOKPATH* and SUBSTITUTE-COMMAND*.
---
 gnu/packages/docker.scm | 122 ++++++++++++++++++++--------------------
 1 file changed, 60 insertions(+), 62 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index f6e0e813ba..3cd989cfcb 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -369,68 +369,66 @@ built-in registry server of Docker.")
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
-               (let-syntax ((substitute-LookPath
-                             (lambda (x)
-                               (syntax-case x ()
-                                 ((substitute-LookPath source-text package
-                                                       relative-path)
-                                  #`(substitute* source-files
-                                      ((#,(string-append "\\<exec\\.LookPath\\(\""
-                                                         (syntax->datum
-                                                          #'source-text)
-                                                         "\")"))
-                                       (string-append "\""
-                                                      (assoc-ref inputs package)
-                                                      "/" relative-path
-                                                      "\", error(nil)")))))))
-                            (substitute-Command
-                             (lambda (x)
-                               (syntax-case x ()
-                                 ((substitute-LookPath source-text package
-                                                       relative-path)
-                                  #`(substitute* source-files
-                                      ((#,(string-append "\\<(re)?exec\\.Command\\(\""
-                                                         (syntax->datum
-                                                          #'source-text)
-                                                         "\"") _ re?)
-                                       (string-append (if re? re? "")
-                                                      "exec.Command(\""
-                                                      (assoc-ref inputs package)
-                                                      "/" relative-path
-                                                      "\""))))))))
-                 (substitute-LookPath "ps" "procps" "bin/ps")
-                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
-                 (substitute-LookPath "lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
-                 (substitute-LookPath "pvdisplay" "lvm2" "sbin/pvdisplay")
-                 (substitute-LookPath "blkid" "util-linux" "sbin/blkid")
-                 (substitute-LookPath "unpigz" "pigz" "bin/unpigz")
-                 (substitute-LookPath "iptables" "iptables" "sbin/iptables")
-                 (substitute-LookPath "iptables-legacy" "iptables" "sbin/iptables")
-                 (substitute-LookPath "ip" "iproute2" "sbin/ip")
-                 (substitute-Command "modprobe" "kmod" "bin/modprobe")
-                 (substitute-Command "pvcreate" "lvm2" "sbin/pvcreate")
-                 (substitute-Command "vgcreate" "lvm2" "sbin/vgcreate")
-                 (substitute-Command "lvcreate" "lvm2" "sbin/lvcreate")
-                 (substitute-Command "lvconvert" "lvm2" "sbin/lvconvert")
-                 (substitute-Command "lvchange" "lvm2" "sbin/lvchange")
-                 (substitute-Command "mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                 (substitute-Command "xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
-                 (substitute-Command "mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
-                 (substitute-Command "tune2fs" "e2fsprogs" "sbin/tune2fs")
-                 (substitute-Command "blkid" "util-linux" "sbin/blkid")
-                 (substitute-Command "resize2fs" "e2fsprogs" "sbin/resize2fs")
-                 ;; docker-mountfrom ??
-                 ;; docker
-                 ;; docker-untar ??
-                 ;; docker-applyLayer ??
-                 ;; /usr/bin/uname
-                 ;; grep
-                 ;; apparmor_parser
-                 (substitute-Command "ps" "procps" "bin/ps")
-                 (substitute-Command "losetup" "util-linux" "sbin/losetup")
-                 (substitute-Command "uname" "coreutils" "bin/uname")
-                 (substitute-Command "dbus-launch" "dbus" "bin/dbus-launch")
-                 (substitute-Command "git" "git" "bin/git"))
+               (let-syntax ((substitute-LookPath*
+                             (syntax-rules ()
+                               ((_ (source-text package relative-path) ...)
+                                (substitute* source-files
+                                  (((string-append "\\<exec\\.LookPath\\(\""
+                                                   source-text
+                                                   "\")"))
+                                   (string-append "\""
+                                                  (assoc-ref inputs package)
+                                                  "/" relative-path
+                                                  "\", error(nil)")) ...))))
+                            (substitute-Command*
+                             (syntax-rules ()
+                               ((_ (source-text package relative-path) ...)
+                                (substitute* source-files
+                                  (((string-append "\\<(re)?exec\\.Command\\(\""
+                                                   source-text
+                                                   "\"") _ re?)
+                                   (string-append (if re? re? "")
+                                                  "exec.Command(\""
+                                                  (assoc-ref inputs package)
+                                                  "/" relative-path
+                                                  "\"")) ...)))))
+                 (substitute-LookPath*
+                  ("ps" "procps" "bin/ps")
+                  ("mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
+                  ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
+                  ("pvdisplay" "lvm2" "sbin/pvdisplay")
+                  ("blkid" "util-linux" "sbin/blkid")
+                  ("unpigz" "pigz" "bin/unpigz")
+                  ("iptables" "iptables" "sbin/iptables")
+                  ("iptables-legacy" "iptables" "sbin/iptables")
+                  ("ip" "iproute2" "sbin/ip"))
+
+                 (substitute-Command*
+                  ("modprobe" "kmod" "bin/modprobe")
+                  ("pvcreate" "lvm2" "sbin/pvcreate")
+                  ("vgcreate" "lvm2" "sbin/vgcreate")
+                  ("lvcreate" "lvm2" "sbin/lvcreate")
+                  ("lvconvert" "lvm2" "sbin/lvconvert")
+                  ("lvchange" "lvm2" "sbin/lvchange")
+                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
+                  ("xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
+                  ("mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
+                  ("tune2fs" "e2fsprogs" "sbin/tune2fs")
+                  ("blkid" "util-linux" "sbin/blkid")
+                  ("resize2fs" "e2fsprogs" "sbin/resize2fs")
+                  ("ps" "procps" "bin/ps")
+                  ("losetup" "util-linux" "sbin/losetup")
+                  ("uname" "coreutils" "bin/uname")
+                  ("dbus-launch" "dbus" "bin/dbus-launch")
+                  ("git" "git" "bin/git")))
+               ;; docker-mountfrom ??
+               ;; docker
+               ;; docker-untar ??
+               ;; docker-applyLayer ??
+               ;; /usr/bin/uname
+               ;; grep
+               ;; apparmor_parser
+
                ;; Make compilation fail when, in future versions, Docker
                ;; invokes other programs we don't know about and thus don't
                ;; substitute.
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.7: 0006-gnu-docker-Patch-the-reference-to-the-docker-proxy.patch --]
[-- Type: text/x-patch, Size: 1844 bytes --]

From 28ab7d7810a1dbcf67254939ab49354651cd8a7c Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 13 Apr 2019 22:48:09 -0400
Subject: [PATCH 6/7] gnu: docker: Patch the reference to the docker proxy.

* gnu/packages/docker.scm (docker)[inputs]: Add docker-libnetwork-cmd-proxy.
* gnu/packages/docker.scm (docker)[phases]{patch-paths}: Patch proxy.go to
refer to the docker-proxy binary by its absolute path.
---
 gnu/packages/docker.scm | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3cd989cfcb..16bc812dd7 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -366,6 +366,11 @@ built-in registry server of Docker.")
                (("var defaultCommandCandidates = .*")
                 (string-append "var defaultCommandCandidates = []string{\""
                                (assoc-ref inputs "runc") "/sbin/runc\"}")))
+             (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
+               (("var userlandProxyCommandName = .*")
+                (string-append "var userlandProxyCommandName = \""
+                               (assoc-ref inputs "docker-proxy")
+                               "/bin/proxy\"\n")))
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
@@ -514,6 +519,7 @@ built-in registry server of Docker.")
        ("containerd" ,containerd)       ; for containerd-shim
        ("coreutils" ,coreutils)
        ("dbus" ,dbus)
+       ("docker-proxy" ,docker-libnetwork-cmd-proxy)
        ("e2fsprogs" ,e2fsprogs)
        ("git" ,git)
        ("iproute2" ,iproute)
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.8: 0007-gnu-docker-Refer-to-xz-by-its-absolute-path.patch --]
[-- Type: text/x-patch, Size: 1592 bytes --]

From 9809ec36652d4949af65eb75755e9dd6d8da5c40 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 13 Apr 2019 22:58:55 -0400
Subject: [PATCH 7/7] gnu: docker: Refer to xz by its absolute path.

* gnu/packages/docker.scm (docker)[inputs]: Add xz.
[phases]{patch-paths}: Patch the reference to xz.
---
 gnu/packages/docker.scm | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 16bc812dd7..43071775e4 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -371,6 +371,9 @@ built-in registry server of Docker.")
                 (string-append "var userlandProxyCommandName = \""
                                (assoc-ref inputs "docker-proxy")
                                "/bin/proxy\"\n")))
+             (substitute* "pkg/archive/archive.go"
+               (("string\\{\"xz")
+                (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
@@ -531,7 +534,8 @@ built-in registry server of Docker.")
        ("runc" ,runc)
        ("util-linux" ,util-linux)
        ("lvm2" ,lvm2)
-       ("xfsprogs" ,xfsprogs)))
+       ("xfsprogs" ,xfsprogs)
+       ("xz" ,xz)))
     (native-inputs
      `(("eudev" ,eudev)      ; TODO: Should be propagated by lvm2 (.pc -> .pc)
        ("go" ,go)
-- 
2.20.1


[-- Attachment #1.9: Type: text/plain, Size: 16 bytes --]


Thanks!

Maxim

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 98%]

* [bug#35282] [PATCH] gnu: docker: Patch paths of xz and docker-proxy.
@ 2019-04-15  0:12 81% Maxim Cournoyer
    0 siblings, 1 reply; 149+ results
From: Maxim Cournoyer @ 2019-04-15  0:12 UTC (permalink / raw)
  To: 35282

[-- Attachment #1: Type: text/plain, Size: 506 bytes --]

This patch series make a couple cosmetic/performance changes to the
docker package, and then goes on to patch the references to the
docker-proxy binary and the xz compression tool.

Prior to this patch, importing a docker image compressed using xz such
as in:

--8<---------------cut here---------------start------------->8---
docker load < some-docker-image.tar.xz
--8<---------------cut here---------------end--------------->8---

Would fail unless xz was found in the system's profile.

Thanks,

Maxim


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-gnu-docker-Fix-indentation.patch --]
[-- Type: text/x-patch, Size: 14272 bytes --]

From 1405716eff1c15bf2a44704f4a32e6e823f73bf2 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 21:55:48 -0400
Subject: [PATCH 1/7] gnu: docker: Fix indentation.

* gnu/packages/docker.scm (docker): Fix indentation using Emacs.
---
 gnu/packages/docker.scm | 184 ++++++++++++++++++++--------------------
 1 file changed, 92 insertions(+), 92 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 1067555296..7445856347 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -299,17 +299,17 @@ built-in registry server of Docker.")
     (version %docker-version)
     (source
      (origin
-      (method git-fetch)
-      (uri (git-reference
-            (url "https://github.com/docker/engine.git")
-            (commit (string-append "v" version))))
-      (file-name (git-file-name name version))
-      (sha256
-       (base32 "06yr5xwr181lalh8z1lk07nxlp7hn38aq8cyqjk617dfy4lz0ixx"))
-      (patches
-       (search-patches "docker-engine-test-noinstall.patch"
-                       "docker-fix-tests.patch"
-                       "docker-use-fewer-modprobes.patch"))))
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/docker/engine.git")
+             (commit (string-append "v" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "06yr5xwr181lalh8z1lk07nxlp7hn38aq8cyqjk617dfy4lz0ixx"))
+       (patches
+        (search-patches "docker-engine-test-noinstall.patch"
+                        "docker-fix-tests.patch"
+                        "docker-use-fewer-modprobes.patch"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
@@ -326,77 +326,77 @@ built-in registry server of Docker.")
          (add-after 'unpack 'patch-paths
            (lambda* (#:key inputs #:allow-other-keys)
              (substitute* "builder/builder-next/executor_unix.go"
-              (("CommandCandidates:.*runc.*")
-               (string-append "CommandCandidates: []string{\""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"},\n")))
+               (("CommandCandidates:.*runc.*")
+                (string-append "CommandCandidates: []string{\""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"},\n")))
              (substitute* "vendor/github.com/containerd/go-runc/runc.go"
-              (("DefaultCommand = .*")
-               (string-append "DefaultCommand = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n")))
+               (("DefaultCommand = .*")
+                (string-append "DefaultCommand = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n")))
              (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
-              (("defaultRuntime[ \t]*=.*")
-               (string-append "defaultRuntime = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n"))
-              (("defaultShim[ \t]*=.*")
-               (string-append "defaultShim = \""
-                              (assoc-ref inputs "containerd")
-                              "/bin/containerd-shim\"\n")))
+               (("defaultRuntime[ \t]*=.*")
+                (string-append "defaultRuntime = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n"))
+               (("defaultShim[ \t]*=.*")
+                (string-append "defaultShim = \""
+                               (assoc-ref inputs "containerd")
+                               "/bin/containerd-shim\"\n")))
              (substitute* "daemon/daemon_unix.go"
-              (("DefaultShimBinary = .*")
-               (string-append "DefaultShimBinary = \""
-                              (assoc-ref inputs "containerd")
-                              "/bin/containerd-shim\"\n"))
-              (("DefaultRuntimeBinary = .*")
-               (string-append "DefaultRuntimeBinary = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n"))
-              (("DefaultRuntimeName = .*")
-               (string-append "DefaultRuntimeName = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n")))
+               (("DefaultShimBinary = .*")
+                (string-append "DefaultShimBinary = \""
+                               (assoc-ref inputs "containerd")
+                               "/bin/containerd-shim\"\n"))
+               (("DefaultRuntimeBinary = .*")
+                (string-append "DefaultRuntimeBinary = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n"))
+               (("DefaultRuntimeName = .*")
+                (string-append "DefaultRuntimeName = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n")))
              (substitute* "daemon/config/config.go"
-              (("StockRuntimeName = .*")
-               (string-append "StockRuntimeName = \""
-                              (assoc-ref inputs "runc")
-                              "/sbin/runc\"\n")))
+               (("StockRuntimeName = .*")
+                (string-append "StockRuntimeName = \""
+                               (assoc-ref inputs "runc")
+                               "/sbin/runc\"\n")))
              (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
-              (("var defaultCommandCandidates = .*")
-               (string-append "var defaultCommandCandidates = []string{\""
-                              (assoc-ref inputs "runc") "/sbin/runc\"}")))
+               (("var defaultCommandCandidates = .*")
+                (string-append "var defaultCommandCandidates = []string{\""
+                               (assoc-ref inputs "runc") "/sbin/runc\"}")))
              (let ((source-files (filter (lambda (name)
-                                    (not (string-contains name "test")))
-                                  (find-files "." "\\.go$"))))
+                                           (not (string-contains name "test")))
+                                         (find-files "." "\\.go$"))))
                (let-syntax ((substitute-LookPath
                              (lambda (x)
                                (syntax-case x ()
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                     ((#,(string-append "exec\\.LookPath\\(\""
-                                                        (syntax->datum
-                                                         #'source-text)
-                                                        "\")"))
-                                      (string-append "\""
-                                                     (assoc-ref inputs package)
-                                                     relative-path
-                                                     "\", error(nil)")))))))
+                                      ((#,(string-append "exec\\.LookPath\\(\""
+                                                         (syntax->datum
+                                                          #'source-text)
+                                                         "\")"))
+                                       (string-append "\""
+                                                      (assoc-ref inputs package)
+                                                      relative-path
+                                                      "\", error(nil)")))))))
                             (substitute-Command
                              (lambda (x)
                                (syntax-case x ()
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                     ((#,(string-append "exec\\.Command\\(\""
-                                                        (syntax->datum
-                                                         #'source-text)
-                                                        "\"")) ; )
-                                      (string-append "exec.Command(\""
-                                                     (assoc-ref inputs package)
-                                                     relative-path
-                                                     "\"")))))))) ; )
+                                      ((#,(string-append "exec\\.Command\\(\""
+                                                         (syntax->datum
+                                                          #'source-text)
+                                                         "\"")) ; )
+                                       (string-append "exec.Command(\""
+                                                      (assoc-ref inputs package)
+                                                      relative-path
+                                                      "\"")))))))) ; )
                  (substitute-LookPath "ps" "procps" "/bin/ps")
                  (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
                  (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
@@ -418,13 +418,13 @@ built-in registry server of Docker.")
                  (substitute-Command "tune2fs" "e2fsprogs" "/sbin/tune2fs")
                  (substitute-Command "blkid" "util-linux" "/sbin/blkid")
                  (substitute-Command "resize2fs" "e2fsprogs" "/sbin/resize2fs")
-; docker-mountfrom ??
-; docker
-; docker-untar ??
-; docker-applyLayer ??
-; /usr/bin/uname
-; grep
-; apparmor_parser
+                 ;; docker-mountfrom ??
+                 ;; docker
+                 ;; docker-untar ??
+                 ;; docker-applyLayer ??
+                 ;; /usr/bin/uname
+                 ;; grep
+                 ;; apparmor_parser
                  (substitute-Command "ps" "procps" "/bin/ps")
                  (substitute-Command "losetup" "util-linux" "/sbin/losetup")
                  (substitute-Command "uname" "coreutils" "/bin/uname")
@@ -434,24 +434,24 @@ built-in registry server of Docker.")
                ;; invokes other programs we don't know about and thus don't
                ;; substitute.
                (substitute* source-files
-                ;; Search for Java in PATH.
-                (("\\<exec\\.Command\\(\"java\"") ; )
-                 "xxec.Command(\"java\"") ; )
-                ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                (("\\<exec\\.Command\\(\"auplink\"") ; )
-                 "xxec.Command(\"auplink\"") ; )
-                ;; Fail on other unsubstituted commands.
-                (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                  _ executable) ; )
-                 (string-append "exec.Guix_doesnt_want_Command(\""
-                                executable "\"")) ;)
-                (("\\<xxec\\.Command")
-                 "exec.Command")
-                ;; Search for ZFS in PATH.
-                (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
-                ;; Fail on other unsubstituted LookPaths.
-                (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"") ; ))
-                (("\\<LooxPath") "LookPath")))
+                 ;; Search for Java in PATH.
+                 (("\\<exec\\.Command\\(\"java\"") ; )
+                  "xxec.Command(\"java\"")         ; )
+                 ;; Search for AUFS in PATH (mainline Linux doesn't support it).
+                 (("\\<exec\\.Command\\(\"auplink\"") ; )
+                  "xxec.Command(\"auplink\"")         ; )
+                 ;; Fail on other unsubstituted commands.
+                 (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
+                   _ executable)        ; )
+                  (string-append "exec.Guix_doesnt_want_Command(\""
+                                 executable "\"")) ;)
+                 (("\\<xxec\\.Command")
+                  "exec.Command")
+                 ;; Search for ZFS in PATH.
+                 (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
+                 ;; Fail on other unsubstituted LookPaths.
+                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"") ; ))
+                 (("\\<LooxPath") "LookPath")))
              #t))
          (add-after 'patch-paths 'delete-failing-tests
            (lambda _
@@ -498,7 +498,7 @@ built-in registry server of Docker.")
              ;; But go needs to have the uncanonicalized directory name, so
              ;; store that.
              (setenv "PWD" (string-append (getcwd)
-                            "/.gopath/src/github.com/docker/docker"))
+                                          "/.gopath/src/github.com/docker/docker"))
              (with-directory-excursion ".gopath/src/github.com/docker/docker"
                (invoke "hack/test/unit"))
              (setenv "PWD" #f)
@@ -512,7 +512,7 @@ built-in registry server of Docker.")
                #t))))))
     (inputs
      `(("btrfs-progs" ,btrfs-progs)
-       ("containerd" ,containerd) ; for containerd-shim
+       ("containerd" ,containerd)       ; for containerd-shim
        ("coreutils" ,coreutils)
        ("dbus" ,dbus)
        ("e2fsprogs" ,e2fsprogs)
@@ -528,7 +528,7 @@ built-in registry server of Docker.")
        ("lvm2" ,lvm2)
        ("xfsprogs" ,xfsprogs)))
     (native-inputs
-     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+     `(("eudev" ,eudev)      ; TODO: Should be propagated by lvm2 (.pc -> .pc)
        ("go" ,go)
        ("pkg-config" ,pkg-config)))
     (synopsis "Docker container component library, and daemon")
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-gnu-docker-Cleanup-extraneous-comments.patch --]
[-- Type: text/x-patch, Size: 3186 bytes --]

From 64b8226b954c18aa9fd246c26b8c5958fa5d2e86 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 22:08:52 -0400
Subject: [PATCH 2/7] gnu: docker: Cleanup extraneous comments.

* gnu/packages/docker.scm (docker): Remove "parenthesis-balancing" comments.
---
 gnu/packages/docker.scm | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 7445856347..10aa3aa5b4 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -392,11 +392,11 @@ built-in registry server of Docker.")
                                       ((#,(string-append "exec\\.Command\\(\""
                                                          (syntax->datum
                                                           #'source-text)
-                                                         "\"")) ; )
+                                                         "\""))
                                        (string-append "exec.Command(\""
                                                       (assoc-ref inputs package)
                                                       relative-path
-                                                      "\"")))))))) ; )
+                                                      "\""))))))))
                  (substitute-LookPath "ps" "procps" "/bin/ps")
                  (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
                  (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
@@ -435,22 +435,22 @@ built-in registry server of Docker.")
                ;; substitute.
                (substitute* source-files
                  ;; Search for Java in PATH.
-                 (("\\<exec\\.Command\\(\"java\"") ; )
-                  "xxec.Command(\"java\"")         ; )
+                 (("\\<exec\\.Command\\(\"java\"")
+                  "xxec.Command(\"java\"")
                  ;; Search for AUFS in PATH (mainline Linux doesn't support it).
-                 (("\\<exec\\.Command\\(\"auplink\"") ; )
-                  "xxec.Command(\"auplink\"")         ; )
+                 (("\\<exec\\.Command\\(\"auplink\"")
+                  "xxec.Command(\"auplink\"")
                  ;; Fail on other unsubstituted commands.
                  (("\\<exec\\.Command\\(\"([a-zA-Z0-9][a-zA-Z0-9_-]*)\""
-                   _ executable)        ; )
+                   _ executable)
                   (string-append "exec.Guix_doesnt_want_Command(\""
-                                 executable "\"")) ;)
+                                 executable "\""))
                  (("\\<xxec\\.Command")
                   "exec.Command")
                  ;; Search for ZFS in PATH.
                  (("\\<LookPath\\(\"zfs\"\\)") "LooxPath(\"zfs\")")
                  ;; Fail on other unsubstituted LookPaths.
-                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"") ; ))
+                 (("\\<LookPath\\(\"") "Guix_doesnt_want_LookPath\\(\"")
                  (("\\<LooxPath") "LookPath")))
              #t))
          (add-after 'patch-paths 'delete-failing-tests
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0003-gnu-docker-Harmonize-LookPath-regexes.patch --]
[-- Type: text/x-patch, Size: 1967 bytes --]

From 4ec93a7d398693bc35584b7c287cd49cdfcf2d8f Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 22:12:00 -0400
Subject: [PATCH 3/7] gnu: docker: Harmonize LookPath regexes.

* gnu/packages/docker.scm (docker)[phases]: In the patch-paths phase, update
the regexes used by SUBSTITUTE-LOOKPATH and SUBSTITUTE-COMMAND to match at the
start of the word, like it's done later.
---
 gnu/packages/docker.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 10aa3aa5b4..6e598e4d18 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -375,7 +375,7 @@ built-in registry server of Docker.")
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                      ((#,(string-append "exec\\.LookPath\\(\""
+                                      ((#,(string-append "\\<exec\\.LookPath\\(\""
                                                          (syntax->datum
                                                           #'source-text)
                                                          "\")"))
@@ -389,7 +389,7 @@ built-in registry server of Docker.")
                                  ((substitute-LookPath source-text package
                                                        relative-path)
                                   #`(substitute* source-files
-                                      ((#,(string-append "exec\\.Command\\(\""
+                                      ((#,(string-append "\\<exec\\.Command\\(\""
                                                          (syntax->datum
                                                           #'source-text)
                                                          "\""))
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: 0004-gnu-docker-Make-macros-use-a-relative-path-as-argume.patch --]
[-- Type: text/x-patch, Size: 6139 bytes --]

From e6d6211902463da59ed4716c14334c88907c26c0 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 11 Apr 2019 22:57:33 -0400
Subject: [PATCH 4/7] gnu: docker: Make macros use a relative path as argument.

* gnu/packages/docker.scm (docker)[phases]: Move implementation detail inside
the SUBSTITUTE-LOOKPATH and SUBSTITUTE-COMMAND macros definition, so that the
relative path argument can be given as a relative path.
---
 gnu/packages/docker.scm | 56 ++++++++++++++++++++---------------------
 1 file changed, 28 insertions(+), 28 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 6e598e4d18..0b602cee1d 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -381,7 +381,7 @@ built-in registry server of Docker.")
                                                          "\")"))
                                        (string-append "\""
                                                       (assoc-ref inputs package)
-                                                      relative-path
+                                                      "/" relative-path
                                                       "\", error(nil)")))))))
                             (substitute-Command
                              (lambda (x)
@@ -395,29 +395,29 @@ built-in registry server of Docker.")
                                                          "\""))
                                        (string-append "exec.Command(\""
                                                       (assoc-ref inputs package)
-                                                      relative-path
+                                                      "/" relative-path
                                                       "\""))))))))
-                 (substitute-LookPath "ps" "procps" "/bin/ps")
-                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
-                 (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
-                 (substitute-LookPath "pvdisplay" "lvm2" "/sbin/pvdisplay")
-                 (substitute-LookPath "blkid" "util-linux" "/sbin/blkid")
-                 (substitute-LookPath "unpigz" "pigz" "/bin/unpigz")
-                 (substitute-LookPath "iptables" "iptables" "/sbin/iptables")
-                 (substitute-LookPath "iptables-legacy" "iptables" "/sbin/iptables")
-                 (substitute-LookPath "ip" "iproute2" "/sbin/ip")
-                 (substitute-Command "modprobe" "kmod" "/bin/modprobe")
-                 (substitute-Command "pvcreate" "lvm2" "/sbin/pvcreate")
-                 (substitute-Command "vgcreate" "lvm2" "/sbin/vgcreate")
-                 (substitute-Command "lvcreate" "lvm2" "/sbin/lvcreate")
-                 (substitute-Command "lvconvert" "lvm2" "/sbin/lvconvert")
-                 (substitute-Command "lvchange" "lvm2" "/sbin/lvchange")
-                 (substitute-Command "mkfs.xfs" "xfsprogs" "/sbin/mkfs.xfs")
-                 (substitute-Command "xfs_growfs" "xfsprogs" "/sbin/xfs_growfs")
-                 (substitute-Command "mkfs.ext4" "e2fsprogs" "/sbin/mkfs.ext4")
-                 (substitute-Command "tune2fs" "e2fsprogs" "/sbin/tune2fs")
-                 (substitute-Command "blkid" "util-linux" "/sbin/blkid")
-                 (substitute-Command "resize2fs" "e2fsprogs" "/sbin/resize2fs")
+                 (substitute-LookPath "ps" "procps" "bin/ps")
+                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
+                 (substitute-LookPath "lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
+                 (substitute-LookPath "pvdisplay" "lvm2" "sbin/pvdisplay")
+                 (substitute-LookPath "blkid" "util-linux" "sbin/blkid")
+                 (substitute-LookPath "unpigz" "pigz" "bin/unpigz")
+                 (substitute-LookPath "iptables" "iptables" "sbin/iptables")
+                 (substitute-LookPath "iptables-legacy" "iptables" "sbin/iptables")
+                 (substitute-LookPath "ip" "iproute2" "sbin/ip")
+                 (substitute-Command "modprobe" "kmod" "bin/modprobe")
+                 (substitute-Command "pvcreate" "lvm2" "sbin/pvcreate")
+                 (substitute-Command "vgcreate" "lvm2" "sbin/vgcreate")
+                 (substitute-Command "lvcreate" "lvm2" "sbin/lvcreate")
+                 (substitute-Command "lvconvert" "lvm2" "sbin/lvconvert")
+                 (substitute-Command "lvchange" "lvm2" "sbin/lvchange")
+                 (substitute-Command "mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
+                 (substitute-Command "xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
+                 (substitute-Command "mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
+                 (substitute-Command "tune2fs" "e2fsprogs" "sbin/tune2fs")
+                 (substitute-Command "blkid" "util-linux" "sbin/blkid")
+                 (substitute-Command "resize2fs" "e2fsprogs" "sbin/resize2fs")
                  ;; docker-mountfrom ??
                  ;; docker
                  ;; docker-untar ??
@@ -425,11 +425,11 @@ built-in registry server of Docker.")
                  ;; /usr/bin/uname
                  ;; grep
                  ;; apparmor_parser
-                 (substitute-Command "ps" "procps" "/bin/ps")
-                 (substitute-Command "losetup" "util-linux" "/sbin/losetup")
-                 (substitute-Command "uname" "coreutils" "/bin/uname")
-                 (substitute-Command "dbus-launch" "dbus" "/bin/dbus-launch")
-                 (substitute-Command "git" "git" "/bin/git"))
+                 (substitute-Command "ps" "procps" "bin/ps")
+                 (substitute-Command "losetup" "util-linux" "sbin/losetup")
+                 (substitute-Command "uname" "coreutils" "bin/uname")
+                 (substitute-Command "dbus-launch" "dbus" "bin/dbus-launch")
+                 (substitute-Command "git" "git" "bin/git"))
                ;; Make compilation fail when, in future versions, Docker
                ;; invokes other programs we don't know about and thus don't
                ;; substitute.
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: 0005-gnu-docker-Optimize-substitution-macros.patch --]
[-- Type: text/x-patch, Size: 8694 bytes --]

From aa63b48d0d4a5d48d745e9be8e7222e9f73f0af8 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 13 Apr 2019 22:00:45 -0400
Subject: [PATCH 5/7] gnu: docker: Optimize substitution macros.

This change halves the time needed to patch the paths.

* gnu/packages/docker.scm (docker)[phases]{patch-paths}: Allow passing
multiple SOURCE-TEXT, PACKAGE and RELATIVE-PATH tuples so that the rewrite
rules can be generated and processed by a single use of the SUBSTITUTE*
macro.  Rename SUBSTITUTE-LOOKPATH to SUBSTITUTE-LOOKPATH* and
substitute-Command to SUBSTITUTE-COMMAND* to denote the change.  Adapt the
uses of SUBSTITUTE-LOOKPATH* and SUBSTITUTE-COMMAND*.
---
 gnu/packages/docker.scm | 120 ++++++++++++++++++++--------------------
 1 file changed, 59 insertions(+), 61 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 0b602cee1d..912827b79b 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -369,67 +369,65 @@ built-in registry server of Docker.")
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
-               (let-syntax ((substitute-LookPath
-                             (lambda (x)
-                               (syntax-case x ()
-                                 ((substitute-LookPath source-text package
-                                                       relative-path)
-                                  #`(substitute* source-files
-                                      ((#,(string-append "\\<exec\\.LookPath\\(\""
-                                                         (syntax->datum
-                                                          #'source-text)
-                                                         "\")"))
-                                       (string-append "\""
-                                                      (assoc-ref inputs package)
-                                                      "/" relative-path
-                                                      "\", error(nil)")))))))
-                            (substitute-Command
-                             (lambda (x)
-                               (syntax-case x ()
-                                 ((substitute-LookPath source-text package
-                                                       relative-path)
-                                  #`(substitute* source-files
-                                      ((#,(string-append "\\<exec\\.Command\\(\""
-                                                         (syntax->datum
-                                                          #'source-text)
-                                                         "\""))
-                                       (string-append "exec.Command(\""
-                                                      (assoc-ref inputs package)
-                                                      "/" relative-path
-                                                      "\""))))))))
-                 (substitute-LookPath "ps" "procps" "bin/ps")
-                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
-                 (substitute-LookPath "lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
-                 (substitute-LookPath "pvdisplay" "lvm2" "sbin/pvdisplay")
-                 (substitute-LookPath "blkid" "util-linux" "sbin/blkid")
-                 (substitute-LookPath "unpigz" "pigz" "bin/unpigz")
-                 (substitute-LookPath "iptables" "iptables" "sbin/iptables")
-                 (substitute-LookPath "iptables-legacy" "iptables" "sbin/iptables")
-                 (substitute-LookPath "ip" "iproute2" "sbin/ip")
-                 (substitute-Command "modprobe" "kmod" "bin/modprobe")
-                 (substitute-Command "pvcreate" "lvm2" "sbin/pvcreate")
-                 (substitute-Command "vgcreate" "lvm2" "sbin/vgcreate")
-                 (substitute-Command "lvcreate" "lvm2" "sbin/lvcreate")
-                 (substitute-Command "lvconvert" "lvm2" "sbin/lvconvert")
-                 (substitute-Command "lvchange" "lvm2" "sbin/lvchange")
-                 (substitute-Command "mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
-                 (substitute-Command "xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
-                 (substitute-Command "mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
-                 (substitute-Command "tune2fs" "e2fsprogs" "sbin/tune2fs")
-                 (substitute-Command "blkid" "util-linux" "sbin/blkid")
-                 (substitute-Command "resize2fs" "e2fsprogs" "sbin/resize2fs")
-                 ;; docker-mountfrom ??
-                 ;; docker
-                 ;; docker-untar ??
-                 ;; docker-applyLayer ??
-                 ;; /usr/bin/uname
-                 ;; grep
-                 ;; apparmor_parser
-                 (substitute-Command "ps" "procps" "bin/ps")
-                 (substitute-Command "losetup" "util-linux" "sbin/losetup")
-                 (substitute-Command "uname" "coreutils" "bin/uname")
-                 (substitute-Command "dbus-launch" "dbus" "bin/dbus-launch")
-                 (substitute-Command "git" "git" "bin/git"))
+               (let-syntax ((substitute-LookPath*
+                             (syntax-rules ()
+                               ((_ (source-text package relative-path) ...)
+                                (substitute* source-files
+                                  (((string-append "\\<exec\\.LookPath\\(\""
+                                                   source-text
+                                                   "\")"))
+                                   (string-append "\""
+                                                  (assoc-ref inputs package)
+                                                  "/" relative-path
+                                                  "\", error(nil)")) ...))))
+                            (substitute-Command*
+                             (syntax-rules ()
+                               ((_ (source-text package relative-path) ...)
+                                (substitute* source-files
+                                  (((string-append "\\<exec\\.Command\\(\""
+                                                   source-text
+                                                   "\""))
+                                   (string-append "exec.Command(\""
+                                                  (assoc-ref inputs package)
+                                                  "/" relative-path
+                                                  "\"")) ...)))))
+                 (substitute-LookPath*
+                  ("ps" "procps" "bin/ps")
+                  ("mkfs.xfs" "xfsprogs" "bin/mkfs.xfs")
+                  ("lvmdiskscan" "lvm2" "sbin/lvmdiskscan")
+                  ("pvdisplay" "lvm2" "sbin/pvdisplay")
+                  ("blkid" "util-linux" "sbin/blkid")
+                  ("unpigz" "pigz" "bin/unpigz")
+                  ("iptables" "iptables" "sbin/iptables")
+                  ("iptables-legacy" "iptables" "sbin/iptables")
+                  ("ip" "iproute2" "sbin/ip"))
+
+                 (substitute-Command*
+                  ("modprobe" "kmod" "bin/modprobe")
+                  ("pvcreate" "lvm2" "sbin/pvcreate")
+                  ("vgcreate" "lvm2" "sbin/vgcreate")
+                  ("lvcreate" "lvm2" "sbin/lvcreate")
+                  ("lvconvert" "lvm2" "sbin/lvconvert")
+                  ("lvchange" "lvm2" "sbin/lvchange")
+                  ("mkfs.xfs" "xfsprogs" "sbin/mkfs.xfs")
+                  ("xfs_growfs" "xfsprogs" "sbin/xfs_growfs")
+                  ("mkfs.ext4" "e2fsprogs" "sbin/mkfs.ext4")
+                  ("tune2fs" "e2fsprogs" "sbin/tune2fs")
+                  ("blkid" "util-linux" "sbin/blkid")
+                  ("resize2fs" "e2fsprogs" "sbin/resize2fs")
+                  ("ps" "procps" "bin/ps")
+                  ("losetup" "util-linux" "sbin/losetup")
+                  ("uname" "coreutils" "bin/uname")
+                  ("dbus-launch" "dbus" "bin/dbus-launch")
+                  ("git" "git" "bin/git")))
+               ;; docker-mountfrom ??
+               ;; docker
+               ;; docker-untar ??
+               ;; docker-applyLayer ??
+               ;; /usr/bin/uname
+               ;; grep
+               ;; apparmor_parser
+
                ;; Make compilation fail when, in future versions, Docker
                ;; invokes other programs we don't know about and thus don't
                ;; substitute.
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: 0006-gnu-docker-Patch-the-reference-to-the-docker-proxy.patch --]
[-- Type: text/x-patch, Size: 1805 bytes --]

From a2d9cbcc7ad2c86767ff77e026956d07025c5e27 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 13 Apr 2019 22:48:09 -0400
Subject: [PATCH 6/7] gnu: docker: Patch the reference to the docker proxy.

* gnu/packages/docker.scm (docker)[inputs]: Add docker-libnetwork-cmd-proxy.
* gnu/packages/docker.scm (docker)[phases]{patch-paths}: Patch proxy.go to
refer to the docker-proxy binary by its absolute path.
---
 gnu/packages/docker.scm | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 912827b79b..9dde4c6cb0 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -366,6 +366,11 @@ built-in registry server of Docker.")
                (("var defaultCommandCandidates = .*")
                 (string-append "var defaultCommandCandidates = []string{\""
                                (assoc-ref inputs "runc") "/sbin/runc\"}")))
+             (substitute* "vendor/github.com/docker/libnetwork/portmapper/proxy.go"
+               (("var userlandProxyCommandName = .*")
+                (string-append "var userlandProxyCommandName = \""
+                               (assoc-ref inputs "docker-proxy")
+                               "/bin/proxy\"\n")))
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
@@ -513,6 +518,7 @@ built-in registry server of Docker.")
        ("containerd" ,containerd)       ; for containerd-shim
        ("coreutils" ,coreutils)
        ("dbus" ,dbus)
+       ("docker-proxy" ,docker-libnetwork-cmd-proxy)
        ("e2fsprogs" ,e2fsprogs)
        ("git" ,git)
        ("iproute2" ,iproute)
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #8: 0007-gnu-docker-Refer-to-xz-by-its-absolute-path.patch --]
[-- Type: text/x-patch, Size: 1554 bytes --]

From 646c93fa6a2a75b877153da6c006fd3a17c8dd32 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 13 Apr 2019 22:58:55 -0400
Subject: [PATCH 7/7] gnu: docker: Refer to xz by its absolute path.

* gnu/packages/docker.scm (docker)[inputs]: Add xz.
[phases]{patch-paths}: Patch the reference to xz.
---
 gnu/packages/docker.scm | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 9dde4c6cb0..78bff8a323 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -371,6 +371,9 @@ built-in registry server of Docker.")
                 (string-append "var userlandProxyCommandName = \""
                                (assoc-ref inputs "docker-proxy")
                                "/bin/proxy\"\n")))
+             (substitute* "pkg/archive/archive.go"
+               (("string\\{\"xz")
+                (string-append "string{\"" (assoc-ref inputs "xz") "/bin/xz")))
              (let ((source-files (filter (lambda (name)
                                            (not (string-contains name "test")))
                                          (find-files "." "\\.go$"))))
@@ -530,7 +533,8 @@ built-in registry server of Docker.")
        ("runc" ,runc)
        ("util-linux" ,util-linux)
        ("lvm2" ,lvm2)
-       ("xfsprogs" ,xfsprogs)))
+       ("xfsprogs" ,xfsprogs)
+       ("xz" ,xz)))
     (native-inputs
      `(("eudev" ,eudev)      ; TODO: Should be propagated by lvm2 (.pc -> .pc)
        ("go" ,go)
-- 
2.20.1


^ permalink raw reply related	[relevance 81%]

* [bug#35281] [PATCH] gnu: docker: Add a couple go dependencies and enable docker-proxy.
@ 2019-04-14 23:02 88% Maxim Cournoyer
  0 siblings, 0 replies; 149+ results
From: Maxim Cournoyer @ 2019-04-14 23:02 UTC (permalink / raw)
  To: 35281


[-- Attachment #1.1: Type: text/plain, Size: 970 bytes --]

Hello Guix!

Before this change, attempting to start a docker registry such as with
the following command[0]:

--8<---------------cut here---------------start------------->8---
docker run -d -p 5000:5000 --restart=always --name registry registry:2
--8<---------------cut here---------------end--------------->8---

Would give the following error:

--8<---------------cut here---------------start------------->8---
/gnu/store/dzaijl53fcd3jhkpd70vsf4cnvv10ywj-docker-cli-18.09.3/bin/docker:
Error response from daemon: driver failed programming external
connectivity on endpoint registry
(709754084a9e208c32075e47ea9584296a6f274deeef08283d0de9c9a5161112):
exec: "docker-proxy": executable file not found in $PATH.
--8<---------------cut here---------------end--------------->8---

This series of patches adds docker-libnetwork-cmd-proxy and a few new go
packages it required.

The docker service is modified to enable (or disable) using a 'docker-proxy'.

Thanks!

Maxim


[-- Attachment #1.2: 0001-gnu-Add-go-sctp.patch --]
[-- Type: text/x-patch, Size: 2509 bytes --]

From 2e46dd6c449679ecae6a13a7a922eaf6b6947164 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 01:07:58 -0400
Subject: [PATCH 1/6] gnu: Add go-sctp.

* gnu/packages/networking.scm (go-sctp): New variable.
---
 gnu/packages/networking.scm | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 46aed1e549..5163726393 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -26,6 +26,7 @@
 ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2018 Pierre Neidhardt <mail@ambrevar.xyz>
+;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,6 +51,7 @@
   #:use-module (guix build-system cmake)
   #:use-module (guix build-system glib-or-gtk)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system perl)
   #:use-module (guix build-system python)
   #:use-module (gnu packages)
@@ -730,6 +732,31 @@ manage, and delete Internet resources from Gandi.net such as domain names,
 virtual machines, and certificates.")
     (license license:gpl3+)))
 
+(define-public go-sctp
+  ;; docker-libnetwork-cmd-proxy requires this exact commit.
+  (let ((commit "07191f837fedd2f13d1ec7b5f885f0f3ec54b1cb")
+        (revision "1"))
+    (package
+      (name "go-sctp")
+      (version (git-version "0.0.0" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://github.com/ishidawataru/sctp.git")
+                      (commit commit)))
+                (file-name (git-file-name name version))
+                (sha256
+                 (base32
+                  "1mk9ncm10gwi5pn5wcw4skbyf4qg7n5qdf1mim4gf3mrckvi6g6h"))))
+      (build-system go-build-system)
+      (arguments
+       `(#:import-path "github.com/ishidawataru/sctp"))
+      (home-page "https://github.com/ishidawataru/sctp")
+      (synopsis "SCTP library for the Go programming language")
+      (description "This library provides methods for using the stream control
+transmission protocol (SCTP) in a Go application.")
+      (license license:asl2.0))))
+
 (define-public httping
   (package
     (name "httping")
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.3: 0002-gnu-Add-go-netns.patch --]
[-- Type: text/x-patch, Size: 1954 bytes --]

From 0081c4231f9e25879c287fca54ec9db4929d1711 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 01:53:00 -0400
Subject: [PATCH 2/6] gnu: Add go-netns.

* gnu/packages/networking.scm (go-netns): New variable.
---
 gnu/packages/networking.scm | 25 +++++++++++++++++++++++++
 1 file changed, 25 insertions(+)

diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 5163726393..1407f6208e 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -732,6 +732,31 @@ manage, and delete Internet resources from Gandi.net such as domain names,
 virtual machines, and certificates.")
     (license license:gpl3+)))
 
+(define-public go-netns
+  (let ((commit "13995c7128ccc8e51e9a6bd2b551020a27180abd")
+        (revision "1"))
+    (package
+      (name "go-netns")
+      (version (git-version "0.0.0" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://github.com/vishvananda/netns.git")
+                      (commit commit)))
+                (file-name (git-file-name name version))
+                (sha256
+                 (base32
+                  "1zk6w8158qi4niva5rijchbv9ixgmijsgqshh54wdaav4xrhjshn"))))
+      (build-system go-build-system)
+      (arguments
+       `(#:import-path "github.com/vishvananda/netns"
+         #:tests? #f))                  ;tests require root privileges
+      (home-page "https://github.com/vishvananda/netns")
+      (synopsis "Simple network namespace handling for Go")
+      (description "The netns package provides a simple interface for
+handling network namespaces in Go.")
+      (license license:asl2.0))))
+
 (define-public go-sctp
   ;; docker-libnetwork-cmd-proxy requires this exact commit.
   (let ((commit "07191f837fedd2f13d1ec7b5f885f0f3ec54b1cb")
-- 
2.20.1


[-- Attachment #1.4: 0003-gnu-Add-go-netlink.patch --]
[-- Type: text/x-patch, Size: 2839 bytes --]

From 2a8b23da6fe7ef09f0931231c67f25cd4c60f24f Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 01:57:44 -0400
Subject: [PATCH 3/6] gnu: Add go-netlink.

* gnu/packages/linux.scm (go-netlink): New variable.
---
 gnu/packages/linux.scm | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index e8ee4df4f3..c8adf52ff8 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -33,6 +33,7 @@
 ;;; Copyright © 2018 Pierre Langlois <pierre.langlois@gmx.com>
 ;;; Copyright © 2018 Vasile Dumitrascu <va511e@yahoo.com>
 ;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
+;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -77,6 +78,7 @@
   #:use-module (gnu packages gcc)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages glib)
+  #:use-module (gnu packages golang)
   #:use-module (gnu packages gperf)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages libunwind)
@@ -116,6 +118,7 @@
   #:use-module (gnu packages swig)
   #:use-module (guix build-system cmake)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix build-system trivial)
   #:use-module (guix download)
@@ -5151,6 +5154,33 @@ nfnetlink_queue, nfnetlink_conntrack) and their respective users and/or
 management tools in userspace.")
     (license license:gpl2)))
 
+(define-public go-netlink
+  (package
+    (name "go-netlink")
+    (version "1.0.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/vishvananda/netlink.git")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0hpzghf1a4cwawzhkiwdzin80h6hd09fskl77d5ppgc084yvj8x0"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/vishvananda/netlink"))
+    (native-inputs
+     `(("go-golang-org-x-sys-unix" ,go-golang-org-x-sys-unix)
+       ("go-netns" ,go-netns)))
+    (home-page "https://github.com/vishvananda/netlink")
+    (synopsis "Simple netlink library for Go")
+    (description "The netlink package provides a simple netlink library for
+Go.  Netlink is the interface a user-space program in Linux uses to
+communicate with the kernel.  It can be used to add and remove interfaces, set
+IP addresses and routes, and configure IPsec.")
+    (license license:asl2.0)))
+
 (define-public xfsprogs
   (package
     (name "xfsprogs")
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.5: 0004-gnu-Add-docker-libnetwork.patch --]
[-- Type: text/x-patch, Size: 2830 bytes --]

From 721d1a93961bf653a02cccdbfaf92e0514a3ae59 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 02:32:40 -0400
Subject: [PATCH 4/6] gnu: Add docker-libnetwork.

* gnu/packages/docker.scm (docker-libnetwork): New private variable.
---
 gnu/packages/docker.scm | 41 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 41 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index a11ce266d2..df0bbca1bc 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -227,6 +227,47 @@ network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
 
+;;; Private package that shouldn't be used directly; its purposes is to be used
+;;; as a template for the various packages it contains.
+(define docker-libnetwork
+  ;; There are no recent release for libnetwork, so choose the last commit of
+  ;; the branch that Docker uses, as can be seen in the Docker source file
+  ;; 'hack/dockerfile/install/proxy.installer'.
+  (let ((commit "4725f2163fb214a6312f3beae5991f838ec36326")
+        (version "18.09")
+        (revision "1"))
+    (package
+      (name "docker-libnetwork")
+      (version (git-version version "1" commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://github.com/docker/libnetwork.git")
+                      (commit commit)))
+                (file-name (git-file-name name version))
+                (sha256
+                 (base32
+                  "1zpnxki8qfzha6ljahpwd3vkzmjhsvkmf73w6crm4ilxxw5vnpfb"))
+                ;; Delete bundled ("vendored") free software source code.
+                (modules '((guix build utils)))
+                (snippet '(begin
+                            (delete-file-recursively "vendor")
+                            #t))))
+      (build-system go-build-system)
+      (arguments
+       `(#:import-path "github.com/docker/libnetwork/"
+         ;; The tests fail with the error:
+         ;; src/github.com/docker/libnetwork/network.go:1057: Warnf format %q
+         ;; has arg n.configOnly of wrong type bool.
+         #:tests? #f))
+      (home-page "https://github.com/docker/libnetwork/")
+      (synopsis "Networking for containers")
+      (description "Libnetwork provides a native Go implementation for
+connecting containers.  The goal of @code{libnetwork} is to deliver a robust
+container network model that provides a consistent programming interface and
+the required network abstractions for applications.")
+      (license license:asl2.0))))
+
 ;; TODO: Patch out modprobes for ip_vs, nf_conntrack,
 ;; brige, nf_conntrack_netlink, aufs.
 (define-public docker
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.6: 0005-gnu-Add-docker-libnetwork-cmd-proxy.patch --]
[-- Type: text/x-patch, Size: 2035 bytes --]

From 843ecd2ff5aa5f69ea8a83f2da8e0d783be4b36a Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 02:33:38 -0400
Subject: [PATCH 5/6] gnu: Add docker-libnetwork-cmd-proxy.

* gnu/packages/docker.scm (docker-libnetwork-cmd-proxy): New variable.
---
 gnu/packages/docker.scm | 23 +++++++++++++++++++++++
 1 file changed, 23 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index df0bbca1bc..1067555296 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -36,6 +36,7 @@
   #:use-module (gnu packages glib)
   #:use-module (gnu packages golang)
   #:use-module (gnu packages linux)
+  #:use-module (gnu packages networking)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web)
@@ -268,6 +269,28 @@ container network model that provides a consistent programming interface and
 the required network abstractions for applications.")
       (license license:asl2.0))))
 
+(define-public docker-libnetwork-cmd-proxy
+  (package
+    (inherit docker-libnetwork)
+    (name "docker-libnetwork-cmd-proxy")
+    (arguments
+     `(#:import-path "github.com/docker/libnetwork/cmd/proxy"
+       #:unpack-path "github.com/docker/libnetwork"
+       #:install-source? #f))
+    (native-inputs
+     `(("go-sctp" ,go-sctp)
+       ;; For tests.
+       ("logrus" ,go-github-com-sirupsen-logrus)
+       ("go-netlink" ,go-netlink)
+       ("go-netns" ,go-netns)
+       ("go-golang-org-x-crypto-ssh-terminal"
+        ,go-golang-org-x-crypto-ssh-terminal)
+       ("go-golang-org-x-sys-unix" ,go-golang-org-x-sys-unix)))
+    (synopsis "Docker user-space proxy")
+    (description "A proxy running in the user space.  It is used by the
+built-in registry server of Docker.")
+    (license license:asl2.0)))
+
 ;; TODO: Patch out modprobes for ip_vs, nf_conntrack,
 ;; brige, nf_conntrack_netlink, aufs.
 (define-public docker
-- 
2.20.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.7: 0006-services-docker-Add-new-fields-to-support-proxy.patch --]
[-- Type: text/x-patch, Size: 2798 bytes --]

From fd1003dc333ede95a8fa2813b7e8ab2f6cfe82d2 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 5 Apr 2019 02:34:16 -0400
Subject: [PATCH 6/6] services: docker: Add new fields to support proxy.

The Docker proxy enables inter-container and outside-to-container loopback,
and is required by the Docker registry server.

* gnu/services/docker.scm (docker-configuration)[proxy,
enable-proxy?]: Add fields.
(docker-shepherd-service): Use them.
(serialize-boolean): New function.
---
 gnu/services/docker.scm | 23 ++++++++++++++++++++---
 1 file changed, 20 insertions(+), 3 deletions(-)

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 8b5edf5cb0..94a04c8996 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -31,13 +31,25 @@
   #:export (docker-configuration
             docker-service-type))
 
+;;; We're not using serialize-configuration, but we must define this because
+;;; the define-configuration macro validates it exists.
+(define (serialize-boolean field-name val)
+  "")
+
 (define-configuration docker-configuration
   (docker
    (package docker)
    "Docker daemon package.")
   (containerd
    (package containerd)
-   "containerd package."))
+   "containerd package.")
+  (proxy
+   (package docker-libnetwork-cmd-proxy)
+   "The proxy package to support inter-container and outside-container
+loop-back communications.")
+  (enable-proxy?
+   (boolean #t)
+   "Enable or disable the user-land proxy (enabled by default)."))
 
 (define %docker-accounts
   (list (user-group (name "docker") (system? #t))))
@@ -66,7 +78,9 @@
            (stop #~(make-kill-destructor)))))
 
 (define (docker-shepherd-service config)
-  (let* ((docker (docker-configuration-docker config)))
+  (let* ((docker (docker-configuration-docker config))
+         (enable-proxy? (docker-configuration-enable-proxy? config))
+         (proxy (docker-configuration-proxy config)))
     (shepherd-service
            (documentation "Docker daemon.")
            (provision '(dockerd))
@@ -83,7 +97,10 @@
                           udev))
            (start #~(make-forkexec-constructor
                      (list (string-append #$docker "/bin/dockerd")
-                           "-p" "/var/run/docker.pid")
+                           "-p" "/var/run/docker.pid"
+                           (if #$enable-proxy? "--userland-proxy" "")
+                           "--userland-proxy-path" (string-append #$proxy
+                                                                  "/bin/proxy"))
                      #:pid-file "/var/run/docker.pid"
                      #:log-file "/var/log/docker.log"))
            (stop #~(make-kill-destructor)))))
-- 
2.20.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 88%]

* [bug#35229] [PATCH] gnu: docker: Check for error on XFRM.
@ 2019-04-11 14:36 89% Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2019-04-11 14:36 UTC (permalink / raw)
  To: 35229

* gnu/packages/patches/docker-use-fewer-modprobes.patch: Check for error on
XFRM.
---
 .../patches/docker-use-fewer-modprobes.patch  | 30 +++++++++++++++----
 1 file changed, 24 insertions(+), 6 deletions(-)

diff --git a/gnu/packages/patches/docker-use-fewer-modprobes.patch b/gnu/packages/patches/docker-use-fewer-modprobes.patch
index 2779e1be5d..4e4a45b6ce 100644
--- a/gnu/packages/patches/docker-use-fewer-modprobes.patch
+++ b/gnu/packages/patches/docker-use-fewer-modprobes.patch
@@ -103,17 +103,35 @@ See <https://github.com/moby/moby/pull/38930>.
  
 --- docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/ns/init_linux.go.orig	2019-03-19 11:23:20.738316699 +0100
 +++ docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/ns/init_linux.go	2019-03-19 11:27:57.149753073 +0100
-@@ -100,12 +100,7 @@
+@@ -76,12 +76,8 @@ func NlHandle() *netlink.Handle {
+ func getSupportedNlFamilies() []int {
+ 	fams := []int{syscall.NETLINK_ROUTE}
+ 	// NETLINK_XFRM test
+-	if err := loadXfrmModules(); err != nil {
+-		if checkXfrmSocket() != nil {
+-			logrus.Warnf("Could not load necessary modules for IPSEC rules: %v", err)
+-		} else {
+-			fams = append(fams, syscall.NETLINK_XFRM)
+-		}
++	if err := checkXfrmSocket(); err != nil {
++		logrus.Warnf("Could not load necessary modules for IPSEC rules: %v", err)
+ 	} else {
+ 		fams = append(fams, syscall.NETLINK_XFRM)
+ 	}
+@@ -99,16 +95,6 @@ func getSupportedNlFamilies() []int {
+ 	return fams
  }
  
- func loadXfrmModules() error {
+-func loadXfrmModules() error {
 -	if out, err := exec.Command("modprobe", "-va", "xfrm_user").CombinedOutput(); err != nil {
 -		return fmt.Errorf("Running modprobe xfrm_user failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
 -	}
 -	if out, err := exec.Command("modprobe", "-va", "xfrm_algo").CombinedOutput(); err != nil {
 -		return fmt.Errorf("Running modprobe xfrm_algo failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
 -	}
-+	// Those are automatically loaded when someone opens the socket anyway.
- 	return nil
- }
- 
+-	return nil
+-}
+-
+ // API check on required xfrm modules (xfrm_user, xfrm_algo)
+ func checkXfrmSocket() error {
+ 	fd, err := syscall.Socket(syscall.AF_NETLINK, syscall.SOCK_RAW, syscall.NETLINK_XFRM)

^ permalink raw reply related	[relevance 89%]

* [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account>.
  @ 2019-03-22 17:27 45% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2019-03-22 17:27 UTC (permalink / raw)
  To: 34948

* gnu/system/accounts.scm (<user-account>)[home-directory]: Mark as
thunked and add a default value.
(default-home-directory): New procedure.
* doc/guix.texi (User Accounts): Remove 'home-directory' from example.
* gnu/system/examples/bare-bones.tmpl: Likewise.
* gnu/system/examples/beaglebone-black.tmpl: Likewise.
* gnu/system/examples/desktop.tmpl: Likewise.
* gnu/system/examples/docker-image.tmpl: Likewise.
* gnu/system/examples/lightweight-desktop.tmpl: Likewise.
* gnu/system/install.scm (installation-os): Likewise.
* gnu/tests.scm (%simple-os): Likewise.
* gnu/tests/install.scm (%minimal-os, %minimal-os-on-vda):
(%separate-home-os, %encrypted-root-os, %btrfs-root-os): Likewise.
* tests/accounts.scm ("allocate-passwd")
("allocate-passwd with previous state"): Likewise.
---
 doc/guix.texi                                |  1 -
 gnu/system/accounts.scm                      |  7 ++++++-
 gnu/system/examples/bare-bones.tmpl          |  3 +--
 gnu/system/examples/beaglebone-black.tmpl    |  3 +--
 gnu/system/examples/desktop.tmpl             |  3 +--
 gnu/system/examples/docker-image.tmpl        |  3 +--
 gnu/system/examples/lightweight-desktop.tmpl |  3 +--
 gnu/system/install.scm                       |  3 +--
 gnu/tests.scm                                |  5 ++---
 gnu/tests/install.scm                        | 14 ++++----------
 tests/accounts.scm                           |  4 ----
 11 files changed, 18 insertions(+), 31 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 94d7a29bdf..642232ee9c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10868,7 +10868,6 @@ this field must contain the encrypted password, as a string.  You can use the
 @example
 (user-account
   (name "charlie")
-  (home-directory "/home/charlie")
   (group "users")
 
   ;; Specify a SHA-512-hashed initial password.
diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
index eb18fb5e43..586cff1842 100644
--- a/gnu/system/accounts.scm
+++ b/gnu/system/accounts.scm
@@ -67,7 +67,8 @@
   (supplementary-groups user-account-supplementary-groups
                         (default '()))            ; list of strings
   (comment        user-account-comment (default ""))
-  (home-directory user-account-home-directory)
+  (home-directory user-account-home-directory (thunked)
+                  (default (default-home-directory this-record)))
   (create-home-directory? user-account-create-home-directory? ;Boolean
                           (default #t))
   (shell          user-account-shell              ; gexp
@@ -84,6 +85,10 @@
   (system?        user-group-system?              ; Boolean
                   (default #f)))
 
+(define (default-home-directory account)
+  "Return the default home directory for ACCOUNT."
+  (string-append "/home/" (user-account-name account)))
+
 (define (sexp->user-group sexp)
   "Take SEXP, a tuple as returned by 'user-group->gexp', and turn it into a
 user-group record."
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index a88bab034f..4f30a5b756 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -35,8 +35,7 @@
                 ;; and "video" allows the user to play sound
                 ;; and access the webcam.
                 (supplementary-groups '("wheel"
-                                        "audio" "video"))
-                (home-directory "/home/alice"))
+                                        "audio" "video")))
                %base-user-accounts))
 
   ;; Globally-installed packages.
diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl
index 11678063b2..def05e807d 100644
--- a/gnu/system/examples/beaglebone-black.tmpl
+++ b/gnu/system/examples/beaglebone-black.tmpl
@@ -38,8 +38,7 @@
                 ;; and "video" allows the user to play sound
                 ;; and access the webcam.
                 (supplementary-groups '("wheel"
-                                        "audio" "video"))
-                (home-directory "/home/alice"))
+                                        "audio" "video")))
                %base-user-accounts))
 
   ;; Globally-installed packages.
diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl
index c59bf92681..bc5cbd6e6b 100644
--- a/gnu/system/examples/desktop.tmpl
+++ b/gnu/system/examples/desktop.tmpl
@@ -42,8 +42,7 @@
                 (comment "Alice's brother")
                 (group "users")
                 (supplementary-groups '("wheel" "netdev"
-                                        "audio" "video"))
-                (home-directory "/home/bob"))
+                                        "audio" "video")))
                %base-user-accounts))
 
   ;; This is where we specify system-wide packages.
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
index 9690d651c1..ca633cc838 100644
--- a/gnu/system/examples/docker-image.tmpl
+++ b/gnu/system/examples/docker-image.tmpl
@@ -15,8 +15,7 @@
                 (comment "Bob's sister")
                 (group "users")
                 (supplementary-groups '("wheel"
-                                        "audio" "video"))
-                (home-directory "/home/alice"))
+                                        "audio" "video")))
                %base-user-accounts))
 
   ;; Globally-installed packages.
diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl
index a234badd2b..45d9bf447f 100644
--- a/gnu/system/examples/lightweight-desktop.tmpl
+++ b/gnu/system/examples/lightweight-desktop.tmpl
@@ -35,8 +35,7 @@
                 (comment "Bob's sister")
                 (group "users")
                 (supplementary-groups '("wheel" "netdev"
-                                        "audio" "video"))
-                (home-directory "/home/alice"))
+                                        "audio" "video")))
                %base-user-accounts))
 
   ;; Add a bunch of window managers; we can choose one at
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index bad318d06b..aad1deb913 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -379,8 +379,7 @@ You have been warned.  Thanks for being so brave.\x1b[0m
                   (group "users")
                   (supplementary-groups '("wheel")) ; allow use of sudo
                   (password "")
-                  (comment "Guest of GNU")
-                  (home-directory "/home/guest"))))
+                  (comment "Guest of GNU"))))
 
     (issue %issue)
     (services %installation-services)
diff --git a/gnu/tests.scm b/gnu/tests.scm
index 9e8eed7d95..0871b4c6f7 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
@@ -219,8 +219,7 @@ the system under test."
                   (name "alice")
                   (comment "Bob's sister")
                   (group "users")
-                  (supplementary-groups '("wheel" "audio" "video"))
-                  (home-directory "/home/alice"))
+                  (supplementary-groups '("wheel" "audio" "video")))
                  %base-user-accounts))))
 
 (define-syntax-rule (simple-operating-system user-services ...)
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 277908cc49..c0debbd840 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -74,8 +74,7 @@
                   (name "alice")
                   (comment "Bob's sister")
                   (group "users")
-                  (supplementary-groups '("wheel" "audio" "video"))
-                  (home-directory "/home/alice"))
+                  (supplementary-groups '("wheel" "audio" "video")))
                  %base-user-accounts))
     (services (cons (service marionette-service-type
                              (marionette-configuration
@@ -357,8 +356,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.")
                   (name "alice")
                   (comment "Bob's sister")
                   (group "users")
-                  (supplementary-groups '("wheel" "audio" "video"))
-                  (home-directory "/home/alice"))
+                  (supplementary-groups '("wheel" "audio" "video")))
                  %base-user-accounts))
     (services (cons (service marionette-service-type
                              (marionette-configuration
@@ -435,12 +433,10 @@ reboot\n")
                          %base-file-systems))
     (users (cons* (user-account
                    (name "alice")
-                   (group "users")
-                   (home-directory "/home/alice"))
+                   (group "users"))
                   (user-account
                    (name "charlie")
-                   (group "users")
-                   (home-directory "/home/charlie"))
+                   (group "users"))
                   %base-user-accounts))
     (services (cons (service marionette-service-type
                              (marionette-configuration
@@ -655,7 +651,6 @@ by 'mdadm'.")
     (users (cons (user-account
                   (name "charlie")
                   (group "users")
-                  (home-directory "/home/charlie")
                   (supplementary-groups '("wheel" "audio" "video")))
                  %base-user-accounts))
     (services (cons (service marionette-service-type
@@ -776,7 +771,6 @@ build (current-guix) and then store a couple of full system images.")
     (users (cons (user-account
                   (name "charlie")
                   (group "users")
-                  (home-directory "/home/charlie")
                   (supplementary-groups '("wheel" "audio" "video")))
                  %base-user-accounts))
     (services (cons (service marionette-service-type
diff --git a/tests/accounts.scm b/tests/accounts.scm
index 127861042d..923ba7dc83 100644
--- a/tests/accounts.scm
+++ b/tests/accounts.scm
@@ -199,12 +199,10 @@ nobody:!:0::::::\n"))
                         (directory "/var/empty")))
   (allocate-passwd (list (user-account (name "alice")
                                        (comment "Alice")
-                                       (home-directory "/home/alice")
                                        (shell "/bin/sh")
                                        (group "users"))
                          (user-account (name "bob")
                                        (comment "Bob")
-                                       (home-directory "/home/bob")
                                        (shell "/bin/gash")
                                        (group "wheel"))
                          (user-account (name "sshd") (system? #t)
@@ -234,12 +232,10 @@ nobody:!:0::::::\n"))
                         (directory "/home/charlie")))
   (allocate-passwd (list (user-account (name "alice")
                                        (comment "Alice")
-                                       (home-directory "/home/alice")
                                        (shell "/bin/sh") ;ignored
                                        (group "users"))
                          (user-account (name "charlie")
                                        (comment "Charlie")
-                                       (home-directory "/home/charlie")
                                        (shell "/bin/sh")
                                        (group "users")))
                    (list (group-entry (name "users") (gid 1000)))
-- 
2.21.0

^ permalink raw reply related	[relevance 45%]

* [bug#34917] [PATCH v2] gnu: docker: Use fewer modprobes.
  2019-03-19 18:20 93% [bug#34917] [PATCH] gnu: docker: Use fewer modprobes Danny Milosavljevic
@ 2019-03-19 18:26 71% ` Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2019-03-19 18:26 UTC (permalink / raw)
  To: 34917

Fixes <https://bugs.gnu.org/34333>.
Reported by Allan Adair <allan@adair.io>.

* gnu/packages/patches/docker-use-fewer-modprobes.patch: New file.
* gnu/local.mk (dist_patch_DATA): Add it.
* gnu/packages/docker.scm (docker)[source]: Use it.
---
 gnu/local.mk                                  |   1 +
 gnu/packages/docker.scm                       |   5 +-
 .../patches/docker-use-fewer-modprobes.patch  | 116 ++++++++++++++++++
 3 files changed, 121 insertions(+), 1 deletion(-)
 create mode 100644 gnu/packages/patches/docker-use-fewer-modprobes.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index 0a7e9bbc6..46bd83e50 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -723,6 +723,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/doc++-segfault-fix.patch			\
   %D%/packages/patches/docker-engine-test-noinstall.patch	\
   %D%/packages/patches/docker-fix-tests.patch			\
+  %D%/packages/patches/docker-use-fewer-modprobes.patch		\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/doxygen-test.patch			\
   %D%/packages/patches/dropbear-CVE-2018-15599.patch		\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 88fc7fc6e..a11ce266d 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -227,6 +227,8 @@ network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
 
+;; TODO: Patch out modprobes for ip_vs, nf_conntrack,
+;; brige, nf_conntrack_netlink, aufs.
 (define-public docker
   (package
     (name "docker")
@@ -242,7 +244,8 @@ network attachments.")
        (base32 "06yr5xwr181lalh8z1lk07nxlp7hn38aq8cyqjk617dfy4lz0ixx"))
       (patches
        (search-patches "docker-engine-test-noinstall.patch"
-                       "docker-fix-tests.patch"))))
+                       "docker-fix-tests.patch"
+                       "docker-use-fewer-modprobes.patch"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
diff --git a/gnu/packages/patches/docker-use-fewer-modprobes.patch b/gnu/packages/patches/docker-use-fewer-modprobes.patch
new file mode 100644
index 000000000..ebee83329
--- /dev/null
+++ b/gnu/packages/patches/docker-use-fewer-modprobes.patch
@@ -0,0 +1,116 @@
+This patch makes docker find out whether a filesystem type is supported
+by trying to mount a filesystem of that type rather than invoking "modprobe".
+--- docker-18.09.0-checkout/daemon/graphdriver/overlay/overlay.go.orig	1970-01-01 01:00:00.000000000 +0100
++++ docker-18.09.0-checkout/daemon/graphdriver/overlay/overlay.go	2019-03-19 09:16:03.487087490 +0100
+@@ -8,7 +8,6 @@
+ 	"io"
+ 	"io/ioutil"
+ 	"os"
+-	"os/exec"
+ 	"path"
+ 	"path/filepath"
+ 	"strconv"
+@@ -201,9 +200,16 @@
+ }
+ 
+ func supportsOverlay() error {
+-	// We can try to modprobe overlay first before looking at
+-	// proc/filesystems for when overlay is supported
+-	exec.Command("modprobe", "overlay").Run()
++	// Access overlay filesystem so that Linux loads it (if possible).
++	mountTarget, err := ioutil.TempDir("", "supportsOverlay")
++	if err != nil {
++		logrus.WithField("storage-driver", "overlay2").Error("Could not create temporary directory, so assuming that 'overlay' is not supported.")
++		return graphdriver.ErrNotSupported
++	} else {
++		/* The mounting will fail--after the module has been loaded.*/
++		defer os.RemoveAll(mountTarget)
++		unix.Mount("overlay", mountTarget, "overlay", 0, "")
++	}
+ 
+ 	f, err := os.Open("/proc/filesystems")
+ 	if err != nil {
+--- docker-18.09.0-checkout/daemon/graphdriver/overlay2/overlay.go.orig	2019-03-18 23:42:23.728525231 +0100
++++ docker-18.09.0-checkout/daemon/graphdriver/overlay2/overlay.go	2019-03-19 08:54:31.411906113 +0100
+@@ -10,7 +10,6 @@
+ 	"io"
+ 	"io/ioutil"
+ 	"os"
+-	"os/exec"
+ 	"path"
+ 	"path/filepath"
+ 	"strconv"
+@@ -261,9 +260,16 @@
+ }
+ 
+ func supportsOverlay() error {
+-	// We can try to modprobe overlay first before looking at
+-	// proc/filesystems for when overlay is supported
+-	exec.Command("modprobe", "overlay").Run()
++	// Access overlay filesystem so that Linux loads it (if possible).
++	mountTarget, err := ioutil.TempDir("", "supportsOverlay")
++	if err != nil {
++		logrus.WithField("storage-driver", "overlay2").Error("Could not create temporary directory, so assuming that 'overlay' is not supported.")
++		return graphdriver.ErrNotSupported
++	} else {
++		/* The mounting will fail--after the module has been loaded.*/
++		defer os.RemoveAll(mountTarget)
++		unix.Mount("overlay", mountTarget, "overlay", 0, "")
++	}
+ 
+ 	f, err := os.Open("/proc/filesystems")
+ 	if err != nil {
+--- docker-18.09.0-checkout/daemon/graphdriver/devmapper/deviceset.go.orig	2019-03-19 09:19:16.592844887 +0100
++++ docker-18.09.0-checkout/daemon/graphdriver/devmapper/deviceset.go	2019-03-19 09:21:18.019361761 +0100
+@@ -540,8 +539,14 @@
+ 		return err // error text is descriptive enough
+ 	}
+ 
+-	// Check if kernel supports xfs filesystem or not.
+-	exec.Command("modprobe", "xfs").Run()
++        mountTarget, err := ioutil.TempDir("", "supportsOverlay")
++        if err != nil {
++		return errors.Wrapf(err, "error checking for xfs support")
++        } else {
++                /* The mounting will fail--after the module has been loaded.*/
++                defer os.RemoveAll(mountTarget)
++                unix.Mount("none", mountTarget, "xfs", 0, "")
++        }
+ 
+ 	f, err := os.Open("/proc/filesystems")
+ 	if err != nil {
+--- docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/iptables/iptables.go.orig	2019-03-19 09:47:19.430111170 +0100
++++ docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/iptables/iptables.go	2019-03-19 10:38:01.445136177 +0100
+@@ -72,11 +71,12 @@
+ }
+ 
+ func probe() {
+-	if out, err := exec.Command("modprobe", "-va", "nf_nat").CombinedOutput(); err != nil {
+-		logrus.Warnf("Running modprobe nf_nat failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
++	path, err := exec.LookPath("iptables")
++	if err != nil {
++		return
+ 	}
+-	if out, err := exec.Command("modprobe", "-va", "xt_conntrack").CombinedOutput(); err != nil {
+-		logrus.Warnf("Running modprobe xt_conntrack failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
++	if out, err := exec.Command(path, "--wait", "-t", "nat", "-L", "-n").CombinedOutput(); err != nil {
++		logrus.Warnf("Running iptables --wait -t nat -L -n failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
+ 	}
+ }
+ 
+--- docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/ns/init_linux.go.orig	2019-03-19 11:23:20.738316699 +0100
++++ docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/ns/init_linux.go	2019-03-19 11:27:57.149753073 +0100
+@@ -100,12 +100,7 @@
+ }
+ 
+ func loadXfrmModules() error {
+-	if out, err := exec.Command("modprobe", "-va", "xfrm_user").CombinedOutput(); err != nil {
+-		return fmt.Errorf("Running modprobe xfrm_user failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
+-	}
+-	if out, err := exec.Command("modprobe", "-va", "xfrm_algo").CombinedOutput(); err != nil {
+-		return fmt.Errorf("Running modprobe xfrm_algo failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
+-	}
++	// Those are automatically loaded when someone opens the socket anyway.
+ 	return nil
+ }
+ 

^ permalink raw reply related	[relevance 71%]

* [bug#34917] [PATCH] gnu: docker: Use fewer modprobes.
@ 2019-03-19 18:20 93% Danny Milosavljevic
  2019-03-19 18:26 71% ` [bug#34917] [PATCH v2] " Danny Milosavljevic
  0 siblings, 1 reply; 149+ results
From: Danny Milosavljevic @ 2019-03-19 18:20 UTC (permalink / raw)
  To: 34917

Fixes <https://bugs.gnu.org/34333>.
Reported by Allan Adair <allan@adair.io>.

* gnu/packages/patches/docker-use-fewer-modprobes.patch: New file.
* gnu/local.mk (dist_patch_DATA): Add it.
* gnu/packages/docker.scm (docker)[source]: Use it.
---
 gnu/local.mk                                  |   1 +
 gnu/packages/docker.scm                       |   5 +-
 .../patches/docker-use-fewer-modprobes.patch  | 100 ++++++++++++++++++
 3 files changed, 105 insertions(+), 1 deletion(-)
 create mode 100644 gnu/packages/patches/docker-use-fewer-modprobes.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index 0a7e9bbc6..46bd83e50 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -723,6 +723,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/doc++-segfault-fix.patch			\
   %D%/packages/patches/docker-engine-test-noinstall.patch	\
   %D%/packages/patches/docker-fix-tests.patch			\
+  %D%/packages/patches/docker-use-fewer-modprobes.patch		\
   %D%/packages/patches/dovecot-trees-support-dovecot-2.3.patch	\
   %D%/packages/patches/doxygen-test.patch			\
   %D%/packages/patches/dropbear-CVE-2018-15599.patch		\
diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 88fc7fc6e..77605d4c0 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -227,6 +227,8 @@ network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
 
+;; TODO: Patch out modprobes for ip_vs, xfrm_user, xfrm_algo, nf_conntrack,
+;; nf_conntrack_netlink, aufs.
 (define-public docker
   (package
     (name "docker")
@@ -242,7 +244,8 @@ network attachments.")
        (base32 "06yr5xwr181lalh8z1lk07nxlp7hn38aq8cyqjk617dfy4lz0ixx"))
       (patches
        (search-patches "docker-engine-test-noinstall.patch"
-                       "docker-fix-tests.patch"))))
+                       "docker-fix-tests.patch"
+                       "docker-use-fewer-modprobes.patch"))))
     (build-system gnu-build-system)
     (arguments
      `(#:modules
diff --git a/gnu/packages/patches/docker-use-fewer-modprobes.patch b/gnu/packages/patches/docker-use-fewer-modprobes.patch
new file mode 100644
index 000000000..c631400cb
--- /dev/null
+++ b/gnu/packages/patches/docker-use-fewer-modprobes.patch
@@ -0,0 +1,100 @@
+This patch makes docker find out whether a filesystem type is supported
+by trying to mount a filesystem of that type rather than invoking "modprobe".
+--- docker-18.09.0-checkout/daemon/graphdriver/overlay/overlay.go.orig	1970-01-01 01:00:00.000000000 +0100
++++ docker-18.09.0-checkout/daemon/graphdriver/overlay/overlay.go	2019-03-19 09:16:03.487087490 +0100
+@@ -8,7 +8,6 @@
+ 	"io"
+ 	"io/ioutil"
+ 	"os"
+-	"os/exec"
+ 	"path"
+ 	"path/filepath"
+ 	"strconv"
+@@ -201,9 +200,16 @@
+ }
+ 
+ func supportsOverlay() error {
+-	// We can try to modprobe overlay first before looking at
+-	// proc/filesystems for when overlay is supported
+-	exec.Command("modprobe", "overlay").Run()
++	// Access overlay filesystem so that Linux loads it (if possible).
++	mountTarget, err := ioutil.TempDir("", "supportsOverlay")
++	if err != nil {
++		logrus.WithField("storage-driver", "overlay2").Error("Could not create temporary directory, so assuming that 'overlay' is not supported.")
++		return graphdriver.ErrNotSupported
++	} else {
++		/* The mounting will fail--after the module has been loaded.*/
++		defer os.RemoveAll(mountTarget)
++		unix.Mount("overlay", mountTarget, "overlay", 0, "")
++	}
+ 
+ 	f, err := os.Open("/proc/filesystems")
+ 	if err != nil {
+--- docker-18.09.0-checkout/daemon/graphdriver/overlay2/overlay.go.orig	2019-03-18 23:42:23.728525231 +0100
++++ docker-18.09.0-checkout/daemon/graphdriver/overlay2/overlay.go	2019-03-19 08:54:31.411906113 +0100
+@@ -10,7 +10,6 @@
+ 	"io"
+ 	"io/ioutil"
+ 	"os"
+-	"os/exec"
+ 	"path"
+ 	"path/filepath"
+ 	"strconv"
+@@ -261,9 +260,16 @@
+ }
+ 
+ func supportsOverlay() error {
+-	// We can try to modprobe overlay first before looking at
+-	// proc/filesystems for when overlay is supported
+-	exec.Command("modprobe", "overlay").Run()
++	// Access overlay filesystem so that Linux loads it (if possible).
++	mountTarget, err := ioutil.TempDir("", "supportsOverlay")
++	if err != nil {
++		logrus.WithField("storage-driver", "overlay2").Error("Could not create temporary directory, so assuming that 'overlay' is not supported.")
++		return graphdriver.ErrNotSupported
++	} else {
++		/* The mounting will fail--after the module has been loaded.*/
++		defer os.RemoveAll(mountTarget)
++		unix.Mount("overlay", mountTarget, "overlay", 0, "")
++	}
+ 
+ 	f, err := os.Open("/proc/filesystems")
+ 	if err != nil {
+--- docker-18.09.0-checkout/daemon/graphdriver/devmapper/deviceset.go.orig	2019-03-19 09:19:16.592844887 +0100
++++ docker-18.09.0-checkout/daemon/graphdriver/devmapper/deviceset.go	2019-03-19 09:21:18.019361761 +0100
+@@ -540,8 +539,14 @@
+ 		return err // error text is descriptive enough
+ 	}
+ 
+-	// Check if kernel supports xfs filesystem or not.
+-	exec.Command("modprobe", "xfs").Run()
++        mountTarget, err := ioutil.TempDir("", "supportsOverlay")
++        if err != nil {
++		return errors.Wrapf(err, "error checking for xfs support")
++        } else {
++                /* The mounting will fail--after the module has been loaded.*/
++                defer os.RemoveAll(mountTarget)
++                unix.Mount("none", mountTarget, "xfs", 0, "")
++        }
+ 
+ 	f, err := os.Open("/proc/filesystems")
+ 	if err != nil {
+--- docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/iptables/iptables.go.orig	2019-03-19 09:47:19.430111170 +0100
++++ docker-18.09.0-checkout/vendor/github.com/docker/libnetwork/iptables/iptables.go	2019-03-19 10:38:01.445136177 +0100
+@@ -72,11 +71,12 @@
+ }
+ 
+ func probe() {
+-	if out, err := exec.Command("modprobe", "-va", "nf_nat").CombinedOutput(); err != nil {
+-		logrus.Warnf("Running modprobe nf_nat failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
++	path, err := exec.LookPath("iptables")
++	if err != nil {
++		return
+ 	}
+-	if out, err := exec.Command("modprobe", "-va", "xt_conntrack").CombinedOutput(); err != nil {
+-		logrus.Warnf("Running modprobe xt_conntrack failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
++	if out, err := exec.Command(path, "--wait", "-t", "nat", "-L", "-n").CombinedOutput(); err != nil {
++		logrus.Warnf("Running iptables --wait -t nat -L -n failed with message: `%s`, error: %v", strings.TrimSpace(string(out)), err)
+ 	}
+ }
+ 

^ permalink raw reply related	[relevance 93%]

* [bug#34446] [PATCH 2/2] gnu: Docker: Update to 18.09.2.
  @ 2019-02-12  0:27 72% ` Leo Famulari
  0 siblings, 0 replies; 149+ results
From: Leo Famulari @ 2019-02-12  0:27 UTC (permalink / raw)
  To: 34446

* gnu/packages/docker.scm (%docker-version): Update to 18.09.2.
(docker, docker-cli): Adjust accordingly.
---
 gnu/packages/docker.scm | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 992eb0dcc1..5a400e6490 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -43,7 +43,7 @@
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages virtualization))
 
-(define %docker-version "18.09.0")
+(define %docker-version "18.09.2")
 
 (define-public python-docker-py
   (package
@@ -241,7 +241,7 @@ network attachments.")
       (file-name (git-file-name name version))
       (sha256
        (base32
-        "1liqbx58grqih6m8hz9y20y5waflv19pv15l3wl64skap2bsn21c"))
+        "1zfpk2n8j6gnwbrxrh6d6pj24y60dhbanpf55shrm2yxz54ka36c"))
       (patches
        (search-patches "docker-engine-test-noinstall.patch"
                        "docker-fix-tests.patch"))))
@@ -483,7 +483,7 @@ provisioning etc.")
       (file-name (git-file-name name version))
       (sha256
        (base32
-        "1ivisys20kphvbqlazc3bsg7pk0ykj9gjx5d4yg439x4n13jxwvb"))))
+        "0jzcqh1kqbfyj6ax7z67gihaqgjiz6ddz6rq6k458l68v7zn77r8"))))
     (build-system go-build-system)
     (arguments
      `(#:import-path "github.com/docker/cli"
-- 
2.20.1

^ permalink raw reply related	[relevance 72%]

* [bug#34120] [PATCH] gnu: Add cqfd.
@ 2019-01-18  5:31 69% Maxim Cournoyer
  0 siblings, 0 replies; 149+ results
From: Maxim Cournoyer @ 2019-01-18  5:31 UTC (permalink / raw)
  To: 34120

[-- Attachment #1: Type: text/plain, Size: 190 bytes --]

Hello!

Now that we have a Docker package (thanks to Danny!), this adds cqfd, a
small tool to keep track of a Docker base build environment
configuration/build commands.

Thanks :-)

Maxim


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-gnu-Add-cqfd.patch --]
[-- Type: text/x-patch, Size: 2294 bytes --]

From c94101e5126f34c613b6a6a3daca1373a90b0882 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Thu, 17 Jan 2019 22:03:47 -0500
Subject: [PATCH] gnu: Add cqfd.

* gnu/packages/docker.scm (cqfd): New variable.
---
 gnu/packages/docker.scm | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 23695a0c0..425244a48 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -528,3 +528,41 @@ provisioning etc.")
     (description "This package provides a command line interface to Docker.")
     (home-page "http://www.docker.com/")
     (license license:asl2.0)))
+
+(define-public cqfd
+  (package
+    (name "cqfd")
+    (version "5.0.1")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/savoirfairelinux/cqfd.git")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1z4v16lbpbwd5ykawizdclpryp2k006lbk2mv427a4b3nvcd9wik"))))
+    (build-system gnu-build-system)
+    (arguments
+     ;; The test suite requires a docker daemon and connectivity.
+     `(#:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (delete 'configure)
+         (delete 'build)
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out")))
+               ;; Fix the directory of the bash completion.
+               (substitute* "Makefile"
+                 (("completionsdir=.*$")
+                  (string-append "completionsdir=" out
+                                 "/etc/bash_completion.d; \\\n")))
+               (invoke "make" "install"
+                       (string-append "PREFIX=" out))))))))
+    (home-page "https://github.com/savoirfairelinux/cqfd")
+    (synopsis "Convenience wrapper for Docker")
+    (description "cqfd is a Bash script that provides a quick and convenient
+way to run commands in the ecurrent directory, but within a Docker container
+defined in a per-project configuration file.")
+    (license license:gpl3+)))
-- 
2.20.1


^ permalink raw reply related	[relevance 69%]

* [bug#34071] [PATCH v3] tests: docker: Run a guest guile inside the docker container.
  2019-01-14 14:46 60% ` [bug#34071] [PATCH v2] " Danny Milosavljevic
@ 2019-01-14 16:32 61%   ` Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2019-01-14 16:32 UTC (permalink / raw)
  To: 34071

* gnu/tests/docker.scm (run-docker-test): Add parameters.  Load and run
docker container.  Check response of guest guile.
(build-tarball&run-docker-test): New procedure.
(%test-docker): Use it.
[description]: Modify.
---
 gnu/tests/docker.scm | 80 ++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 74 insertions(+), 6 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 453ed4893..1b22bad12 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -26,11 +26,22 @@
   #: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 (guix gexp)
+  #:use-module (guix grafts)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix scripts pack)
   #:use-module (guix store)
+  #:use-module (guix tests)
+  #:use-module (guix build-system trivial)
   #:export (%test-docker))
 
+;; Globally disable grafts because they can trigger early builds.
+;(%graft? #f)
+
 (define %docker-os
   (simple-operating-system
    (service dhcp-client-service-type)
@@ -39,8 +50,9 @@
    (service elogind-service-type)
    (service docker-service-type)))
 
-(define (run-docker-test)
-  "Run tests in %DOCKER-OS."
+(define (run-docker-test docker-tarball)
+  "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
+inside %DOCKER-OS."
   (define os
     (marionette-operating-system
      %docker-os
@@ -50,8 +62,8 @@
   (define vm
     (virtual-machine
      (operating-system os)
-     (memory-size 500)
-     (disk-image-size (* 250 (expt 2 20)))
+     (memory-size 1500)
+     (disk-image-size (* 1500 (expt 2 20)))
      (port-forwardings '())))
 
   (define test
@@ -87,13 +99,69 @@
                          "version"))
              marionette))
 
+          (test-equal "Load docker image and run it"
+            "hello world"
+            (marionette-eval
+             `(begin
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (read-line port))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((raw-line (slurp ,(string-append #$docker-cli
+                                                        "/bin/docker")
+                                                        "load" "-i"
+                                                        ,#$docker-tarball))
+                       (repository&tag (string-drop raw-line
+                                                    (string-length
+                                                     "Loaded image: ")))
+                       (response (slurp
+                                  ,(string-append #$docker-cli "/bin/docker")
+                                  "run" "--entrypoint" "bin/Guile"
+                                  repository&tag
+                                  "/aa.scm")))
+                  response))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
   (gexp->derivation "docker-test" test))
 
+(define (build-tarball&run-docker-test)
+  (mlet* %store-monad
+      ((_ (set-grafting #f))
+       (guile (set-guile-for-build (default-guile)))
+       (guest-script-package ->
+        (dummy-package "guest-script"
+                       (build-system trivial-build-system)
+                       (arguments
+                        `(#:guile ,%bootstrap-guile
+                          #:builder
+                          (let ((out (assoc-ref %outputs "out")))
+                            (mkdir out)
+                            (call-with-output-file (string-append out "/a.scm")
+                              (lambda (port)
+                                (display "(display \"hello world\n\")" port)))
+                            #t)))))
+       (profile (profile-derivation (packages->manifest
+                                     (list %bootstrap-guile
+                                           guest-script-package))
+                                    #:hooks '()
+                                    #:locales? #f))
+       (tarball (docker-image "docker-pack" profile
+                              #:symlinks '(("/bin/Guile" -> "bin/guile")
+                                           ("aa.scm" -> "a.scm"))
+                              #:localstatedir? #t)))
+    (run-docker-test tarball)))
+
 (define %test-docker
   (system-test
    (name "docker")
-   (description "Connect to the running Docker service.")
-   (value (run-docker-test))))
+   (description "Test Docker container of Guix.")
+   (value (build-tarball&run-docker-test))))
+
+;; Local Variables:
+;; eval: (put 'test-assertm 'scheme-indent-function 2)
+;; End:

^ permalink raw reply related	[relevance 61%]

* [bug#34071] [PATCH v2] tests: docker: Run a guest guile inside the docker container.
  2019-01-14 14:35 80% [bug#34071] [PATCH] tests: docker: Run a guest guile inside the docker container Danny Milosavljevic
@ 2019-01-14 14:46 60% ` Danny Milosavljevic
  2019-01-14 16:32 61%   ` [bug#34071] [PATCH v3] " Danny Milosavljevic
  0 siblings, 1 reply; 149+ results
From: Danny Milosavljevic @ 2019-01-14 14:46 UTC (permalink / raw)
  To: 34071

* gnu/tests/docker.scm (run-docker-test): Add parameters.  Load and run
docker container.  Check response of guest guile.
(build-tarball&run-docker-test): New procedure.
(%test-docker): Use it.
[description]: Modify.
---
 gnu/tests/docker.scm | 82 ++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 76 insertions(+), 6 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 453ed4893..ad574b758 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -26,11 +26,24 @@
   #:use-module (gnu services networking)
   #:use-module (gnu services docker)
   #:use-module (gnu services desktop)
+  #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages docker)
+  #:use-module (guix derivations)
   #:use-module (guix gexp)
+  #:use-module (guix grafts)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix scripts pack)
   #:use-module (guix store)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix build-system trivial)
   #:export (%test-docker))
 
+;; Globally disable grafts because they can trigger early builds.
+;(%graft? #f)
+
 (define %docker-os
   (simple-operating-system
    (service dhcp-client-service-type)
@@ -39,8 +52,9 @@
    (service elogind-service-type)
    (service docker-service-type)))
 
-(define (run-docker-test)
-  "Run tests in %DOCKER-OS."
+(define (run-docker-test docker-tarball)
+  "Load the DOCKER-TARBALL as docker image and run it in a Docker container,
+inside %DOCKER-OS."
   (define os
     (marionette-operating-system
      %docker-os
@@ -50,8 +64,8 @@
   (define vm
     (virtual-machine
      (operating-system os)
-     (memory-size 500)
-     (disk-image-size (* 250 (expt 2 20)))
+     (memory-size 1500)
+     (disk-image-size (* 1500 (expt 2 20)))
      (port-forwardings '())))
 
   (define test
@@ -87,13 +101,69 @@
                          "version"))
              marionette))
 
+          (test-equal "pack guest OS as docker image, load it and run it"
+            "hello world"
+            (marionette-eval
+             `(begin
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (read-line port))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((raw-text (slurp ,(string-append #$docker-cli
+                                                        "/bin/docker")
+                                                        "load" "-i"
+                                                        ,#$docker-tarball))
+                       (repository&tag (string-drop raw-text
+                                                    (string-length
+                                                     "Loaded image: ")))
+                       (response (slurp
+                                  ,(string-append #$docker-cli "/bin/docker")
+                                  "run" "--entrypoint" "bin/Guile"
+                                  repository&tag
+                                  "/aa.scm")))
+                  response))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
   (gexp->derivation "docker-test" test))
 
+(define (build-tarball&run-docker-test)
+  (mlet* %store-monad
+      ((_      (set-grafting #f))
+       (guile   (set-guile-for-build (default-guile)))
+       (guest-script-package ->
+        (dummy-package "guest-script"
+                       (build-system trivial-build-system)
+                       (arguments
+                        `(#:guile ,%bootstrap-guile
+                          #:builder
+                          (let ((out (assoc-ref %outputs "out")))
+                            (mkdir out)
+                            (call-with-output-file (string-append out "/a.scm")
+                              (lambda (port)
+                                (display "(display \"hello world\n\")" port)))
+                            #t)))))
+       (profile (profile-derivation (packages->manifest
+                                     (list %bootstrap-guile
+                                           guest-script-package))
+                                    #:hooks '()
+                                    #:locales? #f))
+       (tarball (docker-image "docker-pack" profile
+                              #:symlinks '(("/bin/Guile" -> "bin/guile")
+                                           ("aa.scm" -> "a.scm"))
+                              #:localstatedir? #t)))
+    (run-docker-test tarball)))
+
 (define %test-docker
   (system-test
    (name "docker")
-   (description "Connect to the running Docker service.")
-   (value (run-docker-test))))
+   (description "Test Docker container of Guix.")
+   (value (build-tarball&run-docker-test))))
+
+;; Local Variables:
+;; eval: (put 'test-assertm 'scheme-indent-function 2)
+;; End:

^ permalink raw reply related	[relevance 60%]

* [bug#34071] [PATCH] tests: docker: Run a guest guile inside the docker container.
@ 2019-01-14 14:35 80% Danny Milosavljevic
  2019-01-14 14:46 60% ` [bug#34071] [PATCH v2] " Danny Milosavljevic
  0 siblings, 1 reply; 149+ results
From: Danny Milosavljevic @ 2019-01-14 14:35 UTC (permalink / raw)
  To: 34071

* gnu/tests/docker.scm (run-docker-test): Add parameters.  Load
and run docker container.  Check response of guest guile.
(build-tarball&run-docker-test): New proecedure.
(%test-docker): Use it.
[description]: Modify.
---
 gnu/tests/docker.scm | 86 ++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 79 insertions(+), 7 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 973a84c55..5c5a47210 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,4 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -26,11 +27,24 @@
   #:use-module (gnu services networking)
   #:use-module (gnu services docker)
   #:use-module (gnu services desktop)
+  #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages docker)
+  #:use-module (guix derivations)
   #:use-module (guix gexp)
+  #:use-module (guix grafts)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix scripts pack)
   #:use-module (guix store)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix build-system trivial)
   #:export (%test-docker))
 
+;; Globally disable grafts because they can trigger early builds.
+;(%graft? #f)
+
 (define %docker-os
   (simple-operating-system
    (service dhcp-client-service-type)
@@ -39,8 +53,9 @@
    (service elogind-service-type)
    (service docker-service-type)))
 
-(define (run-docker-test)
-  "Run tests in %DOCKER-OS."
+(define (run-docker-test docker-tarball)
+  "Load the DOCKER-TARBALL as docker image and run it in a Docker container,
+inside %DOCKER-OS."
   (define os
     (marionette-operating-system
      %docker-os
@@ -50,15 +65,16 @@
   (define vm
     (virtual-machine
      (operating-system os)
-     (memory-size 500)
-     (disk-image-size (* 250 (expt 2 20)))
+     (memory-size 1500)
+     (disk-image-size (* 1500 (expt 2 20)))
      (port-forwardings '())))
 
   (define test
     (with-imported-modules '((gnu build marionette))
       #~(begin
           (use-modules (srfi srfi-11) (srfi srfi-64)
-                       (gnu build marionette))
+                       (gnu build marionette)
+                       (ice-9 regex))
 
           (define marionette
             (make-marionette (list #$vm)))
@@ -87,13 +103,69 @@
                          "version"))
              marionette))
 
+          (test-equal "pack guest OS as docker image, load it and run it"
+            "hello world"
+            (marionette-eval
+             `(begin
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (read-line port))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((raw-text (slurp ,(string-append #$docker-cli
+                                                        "/bin/docker")
+                                                        "load" "-i"
+                                                        ,#$docker-tarball))
+                       (repository&tag (string-drop raw-text
+                                                    (string-length
+                                                     "Loaded image: ")))
+                       (response (slurp
+                                  ,(string-append #$docker-cli "/bin/docker")
+                                  "run" "--entrypoint" "bin/Guile"
+                                  repository&tag
+                                  "/aa.scm")))
+                  response))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
   (gexp->derivation "docker-test" test))
 
+(define (build-tarball&run-docker-test)
+  (mlet* %store-monad
+      ((_      (set-grafting #f))
+       (guile   (set-guile-for-build (default-guile)))
+       (guest-script-package ->
+        (dummy-package "guest-script"
+                       (build-system trivial-build-system)
+                       (arguments
+                        `(#:guile ,%bootstrap-guile
+                          #:builder
+                          (let ((out (assoc-ref %outputs "out")))
+                            (mkdir out)
+                            (call-with-output-file (string-append out "/a.scm")
+                              (lambda (port)
+                                (display "(display \"hello world\n\")" port)))
+                            #t)))))
+       (profile (profile-derivation (packages->manifest
+                                     (list %bootstrap-guile
+                                           guest-script-package))
+                                    #:hooks '()
+                                    #:locales? #f))
+       (tarball (docker-image "docker-pack" profile
+                              #:symlinks '(("/bin/Guile" -> "bin/guile")
+                                           ("aa.scm" -> "a.scm"))
+                              #:localstatedir? #t)))
+    (run-docker-test tarball)))
+
 (define %test-docker
   (system-test
    (name "docker")
-   (description "Connect to the running Docker service.")
-   (value (run-docker-test))))
+   (description "Test Docker container of Guix.")
+   (value (build-tarball&run-docker-test))))
+
+;; Local Variables:
+;; eval: (put 'test-assertm 'scheme-indent-function 2)
+;; End:

^ permalink raw reply related	[relevance 80%]

* [bug#34039] [WIP] tests: Make docker system test more comprehensive.
@ 2019-01-10 21:58 88% Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2019-01-10 21:58 UTC (permalink / raw)
  To: 34039

This system test fails with the error message "Read-only store".

* gnu/tests/docker.scm (run-docker-test): Add test
"pack guest OS as docker image, load it and run it".
(%test-docker)[description]: Modify.
---
 gnu/tests/docker.scm | 35 +++++++++++++++++++++++++++++++++--
 1 file changed, 33 insertions(+), 2 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 973a84c55..32fae82a8 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,4 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -27,6 +28,7 @@
   #:use-module (gnu services docker)
   #:use-module (gnu services desktop)
   #:use-module (gnu packages docker)
+  #:use-module (gnu packages package-management)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:export (%test-docker))
@@ -79,7 +81,7 @@
                      ((pid) (number? pid))))))
              marionette))
 
-          (test-eq "fetch version"
+          (test-eq "fetch docker version"
             0
             (marionette-eval
              `(begin
@@ -87,6 +89,35 @@
                          "version"))
              marionette))
 
+          (test-eq "pack guest OS as docker image, load it and run it"
+            0
+            (marionette-eval
+             `(begin
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (read-line port))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((tar-name (slurp ,(string-append #$guix "/bin/guix")
+                                        "system" "docker-image"
+                                        ,(string-append #$guix
+                                                        ; MISSING "/share/guile/site/2.2/gnu/system/examples/docker-image.tmpl"
+                                                        "/share/guile/site/2.2/gnu/system/examples/bare-bones.tmpl")))
+                       (_ (write tar-name))
+                       (image-id (slurp ,(string-append #$docker-cli
+                                                        "/bin/docker")
+                                        "load" "-i" tar-name))
+                       (_ (write image-id)))
+                (system* ,(string-append #$docker-cli "/bin/docker")
+                         "run" "-e"
+                         "GUIX_NEW_SYSTEM=/var/guix/profiles/system"
+                         "--entrypoint"
+                         "/var/guix/profiles/system/profile/bin/guile"
+                         image-id
+                         "/var/guix/profiles/system/boot")))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
@@ -95,5 +126,5 @@
 (define %test-docker
   (system-test
    (name "docker")
-   (description "Connect to the running Docker service.")
+   (description "Test the Docker service.")
    (value (run-docker-test))))

^ permalink raw reply related	[relevance 88%]

* [bug#33893] [PATCH v5 3/4] services: Add docker.
    2018-12-30 23:39 64%         ` [bug#33893] [PATCH v5 1/4] gnu: Add containerd Danny Milosavljevic
  2018-12-30 23:39 51%         ` [bug#33893] [PATCH v5 2/4] gnu: Add docker-engine Danny Milosavljevic
@ 2018-12-30 23:39 57%         ` Danny Milosavljevic
  2018-12-30 23:39 65%         ` [bug#33893] [PATCH v5 4/4] gnu: Add docker-cli Danny Milosavljevic
  3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 23:39 UTC (permalink / raw)
  To: 33893

* gnu/services/docker.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* doc/guix.texi (Miscellaneous Services): Document the service.
---
 doc/guix.texi           | 10 +++++
 gnu/local.mk            |  1 +
 gnu/services/docker.scm | 93 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 104 insertions(+)
 create mode 100644 gnu/services/docker.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index fcb5b8c08..b129b1bd1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -22115,6 +22115,16 @@ The following is an example @code{dicod-service} configuration.
                     %dicod-database:gcide))))
 @end example
 
+@cindex docker
+@subsubheading Docker Service
+
+The @code{(gnu services docker)} module provides the following service.
+
+@defvr {Scheme Variable} docker-service-type
+
+This is a service that runs @url{http://www.docker.com,Docker}, a daemon that
+provides container functionality.
+
 @node Setuid Programs
 @subsection Setuid Programs
 
diff --git a/gnu/local.mk b/gnu/local.mk
index 925d955a6..f6c91dcc7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -482,6 +482,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/desktop.scm			\
   %D%/services/dict.scm				\
   %D%/services/dns.scm				\
+  %D%/services/docker.scm			\
   %D%/services/authentication.scm		\
   %D%/services/games.scm			\
   %D%/services/kerberos.scm			\
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
new file mode 100644
index 000000000..19d7e598f
--- /dev/null
+++ b/gnu/services/docker.scm
@@ -0,0 +1,93 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services docker)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages docker)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+
+  #:export (docker-configuration
+            docker-service-type))
+
+(define-configuration docker-configuration
+  (docker
+   (package docker-engine)
+   "Docker daemon package.")
+  (containerd
+   (package containerd)
+   "containerd package."))
+
+(define %docker-accounts
+  (list (user-group (name "docker") (system? #t))))
+
+(define (%containerd-activation config)
+  (let ((state-dir "/var/lib/containerd"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+(define (%docker-activation config)
+  (%containerd-activation config)
+  (let ((state-dir "/var/lib/docker"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+;; TODO: Refactor out into its own module?  How to depend on it then?
+(define (containerd-shepherd-service config)
+  (let* ((package (docker-configuration-containerd config)))
+    (shepherd-service
+           (documentation "containerd daemon.")
+           (provision '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$package "/bin/containerd"))))
+           (stop #~(make-kill-destructor)))))
+
+(define (docker-shepherd-service config)
+  (let* ((docker (docker-configuration-docker config)))
+    (shepherd-service
+           (documentation "Docker daemon.")
+           (provision '(dockerd))
+           (requirement '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$docker "/bin/dockerd")
+                           "-p" "/var/run/docker.pid")
+                     #:pid-file "/var/run/docker.pid"
+                     #:log-file "/var/log/docker.log"))
+           (stop #~(make-kill-destructor)))))
+
+(define docker-service-type
+  (service-type (name 'docker)
+		(extensions
+                 (list
+                  (service-extension activation-service-type
+                                     %docker-activation)
+                  (service-extension shepherd-root-service-type
+                                     (lambda args
+                                       (list (apply containerd-shepherd-service args)
+                                             (apply docker-shepherd-service args))))
+                  (service-extension account-service-type
+                                     (const %docker-accounts))))
+                (default-value (docker-configuration))))

^ permalink raw reply related	[relevance 57%]

* [bug#33893] [PATCH v5 2/4] gnu: Add docker-engine.
    2018-12-30 23:39 64%         ` [bug#33893] [PATCH v5 1/4] gnu: Add containerd Danny Milosavljevic
@ 2018-12-30 23:39 51%         ` Danny Milosavljevic
  2018-12-30 23:39 57%         ` [bug#33893] [PATCH v5 3/4] services: Add docker Danny Milosavljevic
  2018-12-30 23:39 65%         ` [bug#33893] [PATCH v5 4/4] gnu: Add docker-cli Danny Milosavljevic
  3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 23:39 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-engine): New variable.
(%docker-version): New variable.
---
 gnu/packages/docker.scm | 168 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 167 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 877800042..a3510529a 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,15 +23,20 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
-  #:use-module (gnu packages python-web))
+  #:use-module (gnu packages python-web)
+  #:use-module (gnu packages virtualization))
+
+(define %docker-version "18.09.0")
 
 (define-public python-docker-py
   (package
@@ -210,3 +215,164 @@ It includes image transfer and storage, container execution and supervision,
 network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
+
+(define-public docker-engine
+  (package
+    (name "docker-engine")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/engine.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1liqbx58grqih6m8hz9y20y5waflv19pv15l3wl64skap2bsn21c"))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:modules
+       ((guix build gnu-build-system)
+        ((guix build go-build-system) #:prefix go:)
+        (guix build utils))
+       #:imported-modules
+       (,@%gnu-build-system-modules
+        (guix build go-build-system))
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'patch-paths
+           (lambda* (#:key inputs #:allow-other-keys)
+             ;(substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+             ; (("") ""))
+             (substitute* "builder/builder-next/executor_unix.go"
+              (("CommandCandidates:.*runc.*")
+               (string-append "CommandCandidates: []string{\""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"},\n")))
+             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+              (("DefaultCommand = .*")
+               (string-append "DefaultCommand = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "vendor/github.com/containerd/containerd/runtime/v1/linux/runtime.go"
+              (("defaultRuntime[ \t]*=.*")
+               (string-append "defaultRuntime = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n"))
+              (("defaultShim[ \t]*=.*")
+               (string-append "defaultShim = \""
+                              (assoc-ref inputs "containerd")
+                              "/bin/containerd-shim\"\n")))
+             (substitute* "daemon/daemon_unix.go"
+              (("DefaultShimBinary = .*")
+               (string-append "DefaultShimBinary = \""
+                              (assoc-ref inputs "containerd")
+                              "/bin/containerd-shim\"\n"))
+              (("DefaultRuntimeBinary = .*")
+               (string-append "DefaultRuntimeBinary = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n"))
+              (("DefaultRuntimeName = .*")
+               (string-append "DefaultRuntimeName = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "daemon/config/config.go"
+              (("StockRuntimeName = .*")
+               (string-append "StockRuntimeName = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             ; TODO DefaultInitBinary
+
+             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+              (("var defaultCommandCandidates = .*")
+               (string-append "var defaultCommandCandidates = []string{\""
+                              (assoc-ref inputs "runc") "/sbin/runc\"}")))
+             (let ((source-files (filter (lambda (name)
+                                    (not (string-contains name "test")))
+                                  (find-files "." "\\.go$"))))
+               (let-syntax ((substitute-LookPath
+                             (lambda (x)
+                               (syntax-case x ()
+                                 ((substitute-LookPath source-text package
+                                                       relative-path)
+                                  #`(substitute* source-files
+                                     ((#,(string-append "exec\\.LookPath\\(\""
+                                                        (syntax->datum
+                                                         #'source-text)
+                                                        "\")"))
+                                      (string-append "\""
+                                                     (assoc-ref inputs package)
+                                                     relative-path
+                                                     "\", error(nil)"))))))))
+                 (substitute-LookPath "ps" "procps" "/bin/ps")
+                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
+                 (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
+                 (substitute-LookPath "pvdisplay" "lvm2" "/sbin/pvdisplay")
+                 (substitute-LookPath "blkid" "util-linux" "/sbin/blkid")
+                 (substitute-LookPath "unpigz" "pigz" "/bin/unpigz")
+                 (substitute-LookPath "iptables" "iptables" "/sbin/iptables")
+                 (substitute-LookPath "ip" "iproute2" "/sbin/ip")
+                 ; TODO: zfs ?
+; TODO: getPlatformContainerdDaemonOpts ./cmd/dockerd/daemon_unix.go
+; TODO: --init-path for docker-init [./cmd/dockerd/config_unix.go InitPath];
+              ;(("LookPath") "Guix_doesnt_want_LookPath")
+             ))
+             #t))
+         (replace 'configure
+           (lambda _
+             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
+             (setenv "AUTO_GOPATH" "1")
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+             #t))
+         (add-before 'build 'setup-environment
+           (assoc-ref go:%standard-phases 'setup-environment))
+         (replace 'build
+           (lambda _
+             ;(invoke "hack/make.sh" "binary")
+             ; FIXME: bash -c 'hack/validate/default && hack/make.sh'
+             ;; Our LD doesn't like the statically linked relocatable things
+             ;; that go produces, so install the dynamic version of
+             ;; dockerd instead.
+             (invoke "hack/make.sh" "dynbinary")))
+         (replace 'check
+           (lambda _
+             ; FIXME: Those don't find any of the go packages
+             ; needed.  Probably GOPATH/GOROOT related.
+             ;(invoke "hack/test/unit")
+             #t))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+               (install-file "bundles/dynbinary-daemon/dockerd-dev" out-bin))
+             ;(setenv "DOCKER_MAKE_INSTALL_PREFIX" (assoc-ref outputs "out"))
+             ; TODO: KEEPBUNDLE=1
+             ;./source/bundles/dynbinary-daemon/dockerd
+             ;(invoke "hack/make.sh" "install-binary")
+             #t)))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("containerd" ,containerd) ; for containerd-shim
+       ("runc" ,runc)
+       ("iproute2" ,iproute)
+       ("iptables" ,iptables)
+       ("pigz" ,pigz)
+       ("procps" ,procps)
+       ("util-linux" ,util-linux)
+       ("lvm2" ,lvm2)
+       ("xfsprogs" ,xfsprogs)))
+    (native-inputs
+     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+       ("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Docker container component library")
+    (description "This package provides a framework to assemble specialized
+container systems.  It includes components for orchestration, image
+management, secret management, configuration management, networking,
+provisioning etc.")
+    (home-page "https://mobyproject.org/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 51%]

* [bug#33893] [PATCH v5 4/4] gnu: Add docker-cli.
                             ` (2 preceding siblings ...)
  2018-12-30 23:39 57%         ` [bug#33893] [PATCH v5 3/4] services: Add docker Danny Milosavljevic
@ 2018-12-30 23:39 65%         ` Danny Milosavljevic
  3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 23:39 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-cli): New variable.
---
 gnu/packages/docker.scm | 63 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index a3510529a..19b4d504f 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -27,6 +27,7 @@
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
+  #:use-module (gnu packages autotools)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
@@ -376,3 +377,65 @@ management, secret management, configuration management, networking,
 provisioning etc.")
     (home-page "https://mobyproject.org/")
     (license license:asl2.0)))
+
+(define-public docker-cli
+  (package
+    (name "docker-cli")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/cli.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1ivisys20kphvbqlazc3bsg7pk0ykj9gjx5d4yg439x4n13jxwvb"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/docker/cli"
+       ;; TODO: Tests require a running Docker daemon.
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'setup-environment-2
+           (lambda _
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+
+             ;; Make build reproducible.
+             (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
+             (symlink "src/github.com/docker/cli/scripts" "./scripts")
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
+             #t))
+         (replace 'build
+           (lambda _
+             (invoke "./scripts/build/dynbinary")))
+         (replace 'check
+           (lambda* (#:key make-flags tests? #:allow-other-keys)
+             (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
+             (if tests?
+                 ;; Use the newly-built docker client for the tests.
+                 (with-directory-excursion "src/github.com/docker/cli"
+                   ;; TODO: Run test-e2e as well?
+                   (apply invoke "make" "-f" "docker.Makefile" "test-unit"
+                          (or make-flags '())))
+                 #t)))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (chdir "build")
+               (install-file (readlink "docker") out-bin)
+               (install-file "docker" out-bin)
+               #t))))))
+    (native-inputs
+     `(("go" ,go)
+       ("libltdl" ,libltdl)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Command line interface to Docker")
+    (description "This package provides a command line interface to Docker.")
+    (home-page "http://www.docker.com/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 65%]

* [bug#33893] [PATCH v5 1/4] gnu: Add containerd.
  @ 2018-12-30 23:39 64%         ` Danny Milosavljevic
  2018-12-30 23:39 51%         ` [bug#33893] [PATCH v5 2/4] gnu: Add docker-engine Danny Milosavljevic
                           ` (2 subsequent siblings)
  3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 23:39 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (containerd): New variable.
---
 gnu/packages/docker.scm | 68 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 68 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index c58f3f3ca..877800042 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,9 +23,13 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web))
 
@@ -142,3 +146,67 @@ created and all the services are started as specified in the configuration.")
 store API.  It allows programmers to interact with a Docker registry using
 Python without keeping their credentials in a Docker configuration file.")
     (license license:asl2.0)))
+
+(define-public containerd
+  (package
+    (name "containerd")
+    (version "1.2.1")
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/containerd/containerd.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "16zn6p1ky3yrgn53z8h9wza53ch91fj47wj5xgz6w4c57j30f66p"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/containerd/containerd"
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'chdir
+           (lambda _
+             (chdir "src/github.com/containerd/containerd")
+             #t))
+         (add-after 'chdir 'patch-paths
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+             ;; TODO: Patch "socat", "unpigz".
+             (substitute* "./runtime/v1/linux/runtime.go"
+              (("defaultRuntime[ \t]*=.*")
+               (string-append "defaultRuntime = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n"))
+              (("defaultShim[ \t]*=.*")
+               (string-append "defaultShim = \""
+                              (assoc-ref outputs "out")
+                              "/bin/containerd-shim\"\n")))
+            (substitute* "./vendor/github.com/containerd/go-runc/runc.go"
+              (("DefaultCommand[ \t]*=.*")
+               (string-append "DefaultCommand = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             #t))
+         (replace 'build
+           (lambda* (#:key (make-flags '()) #:allow-other-keys)
+             (apply invoke "make" make-flags)))
+         (replace 'install
+           (lambda* (#:key outputs (make-flags '()) #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out")))
+               (apply invoke "make" (string-append "DESTDIR=" out) "install"
+                      make-flags)))))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("libseccomp" ,libseccomp)
+       ("runc" ,runc)))
+    (native-inputs
+     `(("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Container runtime")
+    (description "This package provides the container daemon for Docker.
+It includes image transfer and storage, container execution and supervision,
+network attachments.")
+    (home-page "http://containerd.io/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 64%]

* [bug#33893] [PATCH v4 4/4] gnu: Add docker-cli.
                           ` (2 preceding siblings ...)
  2018-12-30 12:17 57%       ` [bug#33893] [PATCH v4 3/4] services: Add docker Danny Milosavljevic
@ 2018-12-30 12:17 65%       ` Danny Milosavljevic
    4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 12:17 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-cli): New variable.
---
 gnu/packages/docker.scm | 63 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3b6f00834..81e79c42d 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -27,6 +27,7 @@
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
+  #:use-module (gnu packages autotools)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
@@ -338,3 +339,65 @@ management, secret management, configuration management, networking,
 provisioning etc.")
     (home-page "https://mobyproject.org/")
     (license license:asl2.0)))
+
+(define-public docker-cli
+  (package
+    (name "docker-cli")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/cli.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1ivisys20kphvbqlazc3bsg7pk0ykj9gjx5d4yg439x4n13jxwvb"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/docker/cli"
+       ;; TODO: Tests require a running Docker daemon.
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'setup-environment-2
+           (lambda _
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+
+             ;; Make build reproducible.
+             (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
+             (symlink "src/github.com/docker/cli/scripts" "./scripts")
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
+             #t))
+         (replace 'build
+           (lambda _
+             (invoke "./scripts/build/dynbinary")))
+         (replace 'check
+           (lambda* (#:key make-flags tests? #:allow-other-keys)
+             (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
+             (if tests?
+                 ;; Use the newly-built docker client for the tests.
+                 (with-directory-excursion "src/github.com/docker/cli"
+                   ;; TODO: Run test-e2e as well?
+                   (apply invoke "make" "-f" "docker.Makefile" "test-unit"
+                          (or make-flags '())))
+                 #t)))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (chdir "build")
+               (install-file (readlink "docker") out-bin)
+               (install-file "docker" out-bin)
+               #t))))))
+    (native-inputs
+     `(("go" ,go)
+       ("libltdl" ,libltdl)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Command line interface to Docker")
+    (description "This package provides a command line interface to Docker.")
+    (home-page "http://www.docker.com/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 65%]

* [bug#33893] [PATCH v4 2/4] gnu: Add docker-engine.
    2018-12-30 12:17 67%       ` [bug#33893] [PATCH v4 1/4] gnu: Add containerd Danny Milosavljevic
@ 2018-12-30 12:17 53%       ` Danny Milosavljevic
  2018-12-30 12:17 57%       ` [bug#33893] [PATCH v4 3/4] services: Add docker Danny Milosavljevic
                         ` (2 subsequent siblings)
  4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 12:17 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-engine): New variable.
(%docker-version): New variable.
---
 gnu/packages/docker.scm | 149 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 148 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index f4e676a9f..3b6f00834 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,15 +23,20 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
-  #:use-module (gnu packages python-web))
+  #:use-module (gnu packages python-web)
+  #:use-module (gnu packages virtualization))
+
+(define %docker-version "18.09.0")
 
 (define-public python-docker-py
   (package
@@ -191,3 +196,145 @@ It includes image transfer and storage, container execution and supervision,
 network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
+
+(define-public docker-engine
+  (package
+    (name "docker-engine")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/engine.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1liqbx58grqih6m8hz9y20y5waflv19pv15l3wl64skap2bsn21c"))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:modules
+       ((guix build gnu-build-system)
+        ((guix build go-build-system) #:prefix go:)
+        (guix build utils))
+       #:imported-modules
+       (,@%gnu-build-system-modules
+        (guix build go-build-system))
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'patch-paths
+           (lambda* (#:key inputs #:allow-other-keys)
+             ;(substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+             ; (("") ""))
+             (substitute* "builder/builder-next/executor_unix.go"
+              (("CommandCandidates:.*runc.*")
+               (string-append "CommandCandidates: []string{\""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"},\n")))
+             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+              (("DefaultCommand = .*")
+               (string-append "DefaultCommand = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "daemon/daemon_unix.go"
+              (("DefaultShimBinary = .*")
+               (string-append "DefaultShimBinary = \""
+                              (assoc-ref inputs "containerd")
+                              "/bin/containerd-shim\"\n"))
+              (("DefaultRuntimeBinary = .*")
+               (string-append "DefaultRuntimeBinary = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+              (("var defaultCommandCandidates = .*")
+               (string-append "var defaultCommandCandidates = []string{\""
+                              (assoc-ref inputs "runc") "/sbin/runc\"}")))
+             (let ((source-files (filter (lambda (name)
+                                    (not (string-contains name "test")))
+                                  (find-files "." "\\.go$"))))
+               (let-syntax ((substitute-LookPath
+                             (lambda (x)
+                               (syntax-case x ()
+                                 ((substitute-LookPath source-text package
+                                                       relative-path)
+                                  #`(substitute* source-files
+                                     ((#,(string-append "exec\\.LookPath\\(\""
+                                                        (syntax->datum
+                                                         #'source-text)
+                                                        "\")"))
+                                      (string-append "\""
+                                                     (assoc-ref inputs package)
+                                                     relative-path
+                                                     "\", error(nil)"))))))))
+                 (substitute-LookPath "ps" "procps" "/bin/ps")
+                 (substitute-LookPath "mkfs.xfs" "xfsprogs" "/bin/mkfs.xfs")
+                 (substitute-LookPath "lvmdiskscan" "lvm2" "/sbin/lvmdiskscan")
+                 (substitute-LookPath "pvdisplay" "lvm2" "/sbin/pvdisplay")
+                 (substitute-LookPath "blkid" "util-linux" "/sbin/blkid")
+                 (substitute-LookPath "unpigz" "pigz" "/bin/unpigz")
+                 (substitute-LookPath "iptables" "iptables" "/sbin/iptables")
+                 (substitute-LookPath "ip" "iproute2" "/sbin/ip")
+                 ; TODO: zfs ?
+; TODO: getPlatformContainerdDaemonOpts ./cmd/dockerd/daemon_unix.go
+; TODO: --init-path for docker-init [./cmd/dockerd/config_unix.go InitPath];
+; ./daemon/config/config.go DefaultInitBinary
+              ;(("LookPath") "Guix_doesnt_want_LookPath")
+             ))
+             #t))
+         (replace 'configure
+           (lambda _
+             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
+             (setenv "AUTO_GOPATH" "1")
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+             #t))
+         (add-before 'build 'setup-environment
+           (assoc-ref go:%standard-phases 'setup-environment))
+         (replace 'build
+           (lambda _
+             ;(invoke "hack/make.sh" "binary")
+             ; FIXME: bash -c 'hack/validate/default && hack/make.sh'
+             ;; Our LD doesn't like the statically linked relocatable things
+             ;; that go produces, so install the dynamic version of
+             ;; dockerd instead.
+             (invoke "hack/make.sh" "dynbinary")))
+         (replace 'check
+           (lambda _
+             ; FIXME: Those don't find any of the go packages
+             ; needed.  Probably GOPATH/GOROOT related.
+             ;(invoke "hack/test/unit")
+             #t))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+               (install-file "bundles/dynbinary-daemon/dockerd-dev" out-bin))
+             ;(setenv "DOCKER_MAKE_INSTALL_PREFIX" (assoc-ref outputs "out"))
+             ; TODO: KEEPBUNDLE=1
+             ;./source/bundles/dynbinary-daemon/dockerd
+             ;(invoke "hack/make.sh" "install-binary")
+             #t)))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("containerd" ,containerd) ; for containerd-shim
+       ("runc" ,runc)
+       ("iproute2" ,iproute)
+       ("iptables" ,iptables)
+       ("pigz" ,pigz)
+       ("procps" ,procps)
+       ("util-linux" ,util-linux)
+       ("lvm2" ,lvm2)
+       ("xfsprogs" ,xfsprogs)))
+    (native-inputs
+     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+       ("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Docker container component library")
+    (description "This package provides a framework to assemble specialized
+container systems.  It includes components for orchestration, image
+management, secret management, configuration management, networking,
+provisioning etc.")
+    (home-page "https://mobyproject.org/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 53%]

* [bug#33893] [PATCH v4 1/4] gnu: Add containerd.
  @ 2018-12-30 12:17 67%       ` Danny Milosavljevic
  2018-12-30 12:17 53%       ` [bug#33893] [PATCH v4 2/4] gnu: Add docker-engine Danny Milosavljevic
                         ` (3 subsequent siblings)
  4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 12:17 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (containerd): New variable.
---
 gnu/packages/docker.scm | 49 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index c58f3f3ca..f4e676a9f 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,9 +23,13 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web))
 
@@ -142,3 +146,48 @@ created and all the services are started as specified in the configuration.")
 store API.  It allows programmers to interact with a Docker registry using
 Python without keeping their credentials in a Docker configuration file.")
     (license license:asl2.0)))
+
+(define-public containerd
+  (package
+    (name "containerd")
+    (version "1.2.1")
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/containerd/containerd.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "16zn6p1ky3yrgn53z8h9wza53ch91fj47wj5xgz6w4c57j30f66p"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/containerd/containerd"
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'chdir
+           (lambda _
+             (chdir "src/github.com/containerd/containerd")
+             #t))
+         (replace 'build
+           (lambda* (#:key (make-flags '()) #:allow-other-keys)
+             (apply invoke "make" make-flags)))
+         (replace 'install
+           (lambda* (#:key outputs (make-flags '()) #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out")))
+               (apply invoke "make" (string-append "DESTDIR=" out) "install"
+                      make-flags)))))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("libseccomp" ,libseccomp)))
+    (native-inputs
+     `(("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Container runtime")
+    (description "This package provides the container daemon for Docker.
+It includes image transfer and storage, container execution and supervision,
+network attachments.")
+    (home-page "http://containerd.io/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 67%]

* [bug#33893] [PATCH v4 3/4] services: Add docker.
    2018-12-30 12:17 67%       ` [bug#33893] [PATCH v4 1/4] gnu: Add containerd Danny Milosavljevic
  2018-12-30 12:17 53%       ` [bug#33893] [PATCH v4 2/4] gnu: Add docker-engine Danny Milosavljevic
@ 2018-12-30 12:17 57%       ` Danny Milosavljevic
  2018-12-30 12:17 65%       ` [bug#33893] [PATCH v4 4/4] gnu: Add docker-cli Danny Milosavljevic
    4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30 12:17 UTC (permalink / raw)
  To: 33893

* gnu/services/docker.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* doc/guix.texi (Miscellaneous Services): Document the service.
---
 doc/guix.texi           | 10 +++++
 gnu/local.mk            |  1 +
 gnu/services/docker.scm | 93 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 104 insertions(+)
 create mode 100644 gnu/services/docker.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index fcb5b8c08..b129b1bd1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -22115,6 +22115,16 @@ The following is an example @code{dicod-service} configuration.
                     %dicod-database:gcide))))
 @end example
 
+@cindex docker
+@subsubheading Docker Service
+
+The @code{(gnu services docker)} module provides the following service.
+
+@defvr {Scheme Variable} docker-service-type
+
+This is a service that runs @url{http://www.docker.com,Docker}, a daemon that
+provides container functionality.
+
 @node Setuid Programs
 @subsection Setuid Programs
 
diff --git a/gnu/local.mk b/gnu/local.mk
index 925d955a6..f6c91dcc7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -482,6 +482,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/desktop.scm			\
   %D%/services/dict.scm				\
   %D%/services/dns.scm				\
+  %D%/services/docker.scm			\
   %D%/services/authentication.scm		\
   %D%/services/games.scm			\
   %D%/services/kerberos.scm			\
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
new file mode 100644
index 000000000..19d7e598f
--- /dev/null
+++ b/gnu/services/docker.scm
@@ -0,0 +1,93 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services docker)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages docker)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+
+  #:export (docker-configuration
+            docker-service-type))
+
+(define-configuration docker-configuration
+  (docker
+   (package docker-engine)
+   "Docker daemon package.")
+  (containerd
+   (package containerd)
+   "containerd package."))
+
+(define %docker-accounts
+  (list (user-group (name "docker") (system? #t))))
+
+(define (%containerd-activation config)
+  (let ((state-dir "/var/lib/containerd"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+(define (%docker-activation config)
+  (%containerd-activation config)
+  (let ((state-dir "/var/lib/docker"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+;; TODO: Refactor out into its own module?  How to depend on it then?
+(define (containerd-shepherd-service config)
+  (let* ((package (docker-configuration-containerd config)))
+    (shepherd-service
+           (documentation "containerd daemon.")
+           (provision '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$package "/bin/containerd"))))
+           (stop #~(make-kill-destructor)))))
+
+(define (docker-shepherd-service config)
+  (let* ((docker (docker-configuration-docker config)))
+    (shepherd-service
+           (documentation "Docker daemon.")
+           (provision '(dockerd))
+           (requirement '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$docker "/bin/dockerd")
+                           "-p" "/var/run/docker.pid")
+                     #:pid-file "/var/run/docker.pid"
+                     #:log-file "/var/log/docker.log"))
+           (stop #~(make-kill-destructor)))))
+
+(define docker-service-type
+  (service-type (name 'docker)
+		(extensions
+                 (list
+                  (service-extension activation-service-type
+                                     %docker-activation)
+                  (service-extension shepherd-root-service-type
+                                     (lambda args
+                                       (list (apply containerd-shepherd-service args)
+                                             (apply docker-shepherd-service args))))
+                  (service-extension account-service-type
+                                     (const %docker-accounts))))
+                (default-value (docker-configuration))))

^ permalink raw reply related	[relevance 57%]

* [bug#33893] [PATCH v3 3/4] services: Add docker.
  2018-12-29  1:39 60%     ` [bug#33893] [PATCH v3 3/4] services: Add docker Danny Milosavljevic
@ 2018-12-30  9:50 92%       ` Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-30  9:50 UTC (permalink / raw)
  To: 33893

[-- Attachment #1: Type: text/plain, Size: 738 bytes --]

Better with this additional patch:

diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index e592185f8..19d7e598f 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -72,7 +72,10 @@
            (provision '(dockerd))
            (requirement '(containerd))
            (start #~(make-forkexec-constructor
-                     (list (string-append #$docker "/bin/dockerd"))))
+                     (list (string-append #$docker "/bin/dockerd")
+                           "-p" "/var/run/docker.pid")
+                     #:pid-file "/var/run/docker.pid"
+                     #:log-file "/var/log/docker.log"))
            (stop #~(make-kill-destructor)))))
 
 (define docker-service-type

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]

^ permalink raw reply related	[relevance 92%]

* [bug#33893] [PATCH v3 2/4] gnu: Add docker-engine.
    2018-12-29  1:39 67%     ` [bug#33893] [PATCH v3 1/4] gnu: Add containerd Danny Milosavljevic
@ 2018-12-29  1:39 53%     ` Danny Milosavljevic
  2018-12-29  1:39 60%     ` [bug#33893] [PATCH v3 3/4] services: Add docker Danny Milosavljevic
                       ` (2 subsequent siblings)
  4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:39 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-engine): New variable.
(%docker-version): New variable.
---
 gnu/packages/docker.scm | 152 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 151 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index f4e676a9f..3ca2fadfd 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,15 +23,20 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
-  #:use-module (gnu packages python-web))
+  #:use-module (gnu packages python-web)
+  #:use-module (gnu packages virtualization))
+
+(define %docker-version "18.09.0")
 
 (define-public python-docker-py
   (package
@@ -191,3 +196,148 @@ It includes image transfer and storage, container execution and supervision,
 network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
+
+(define-public docker-engine
+  (package
+    (name "docker-engine")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/engine.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1liqbx58grqih6m8hz9y20y5waflv19pv15l3wl64skap2bsn21c"))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:modules
+       ((guix build gnu-build-system)
+        ((guix build go-build-system) #:prefix go:)
+        (guix build utils))
+       #:imported-modules
+       (,@%gnu-build-system-modules
+        (guix build go-build-system))
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'patch-paths
+           (lambda* (#:key inputs #:allow-other-keys)
+             ;(substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+             ; (("") ""))
+             (substitute* "builder/builder-next/executor_unix.go"
+              (("CommandCandidates:.*runc.*")
+               (string-append "CommandCandidates: []string{\""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"},\n")))
+             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+              (("DefaultCommand = .*")
+               (string-append "DefaultCommand = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "daemon/daemon_unix.go"
+              (("DefaultShimBinary = .*")
+               (string-append "DefaultShimBinary = \""
+                              (assoc-ref inputs "containerd")
+                              "/bin/containerd-shim\"\n"))
+              (("DefaultRuntimeBinary = .*")
+               (string-append "DefaultRuntimeBinary = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+              (("var defaultCommandCandidates = .*")
+               (string-append "var defaultCommandCandidates = []string{\""
+                              (assoc-ref inputs "runc") "/sbin/runc\"}")))
+             (substitute* (filter (lambda (name)
+                                    (not (string-contains name "test")))
+                                  (find-files "\\.go$"))
+              (("\"ps\"")
+               (string-append "\"" (assoc-ref inputs "procps") "/bin/ps\""))
+              ; TODO: zfs ?
+;getPlatformContainerdDaemonOpts ./cmd/dockerd/daemon_unix.go
+; TODO --init-path for docker-init
+; ./cmd/dockerd/config_unix.go InitPath
+;./daemon/config/config.go DefaultInitBinary
+              (("exec\\.LookPath\\(\"mkfs\\.xfs\"\\)")
+               (string-append "\"" (assoc-ref inputs "xfsprogs")
+                              "/bin/mkfs.xfs\""))
+              (("exec\\.LookPath\\(\"lvmdiskscan\"\\)")
+               (string-append "\"" (assoc-ref inputs "lvm2")
+                              "/sbin/lvmdiskscan\""))
+              (("exec\\.LookPath\\(\"pvdisplay\"\\)")
+               (string-append "\"" (assoc-ref inputs "lvm2")
+                              "/sbin/pvdisplay\""))
+              (("exec\\.LookPath\\(\"blkid\"\\)")
+               (string-append "\"" (assoc-ref inputs "util-linux")
+                              "/sbin/blkid\""))
+              (("exec\\.LookPath\\(\"unpigz\"\\)")
+               (string-append "\"" (assoc-ref inputs "pigz")
+                              "/bin/unpigz\""))
+              (("exec\\.LookPath\\(\"iptables\"\\)")
+               (string-append "\"" (assoc-ref inputs "iptables")
+                              "/sbin/iptables\""))
+              (("exec\\.LookPath\\(\"ip\"\\)")
+               (string-append "\"" (assoc-ref inputs "iproute2")
+                              "/sbin/ip\""))
+              ;(("LookPath") "Guix_doesnt_want_LookPath")
+             )
+             #t))
+         (replace 'configure
+           (lambda _
+             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
+             (setenv "AUTO_GOPATH" "1")
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+             ;; Our LD doesn't like the statically linked relocatable things
+             ;; that go produces, so install the dynamic version of
+             ;; dockerd instead.
+             ;(substitute* "hack/make/install-binary"
+             ; (("/binary-daemon") "/dynbinary-daemon"))
+             #t))
+         (add-before 'build 'setup-environment
+           (assoc-ref go:%standard-phases 'setup-environment))
+         (replace 'build
+           (lambda _
+             ;(invoke "hack/make.sh" "binary")
+             ; FIXME: bash -c 'hack/validate/default && hack/make.sh'
+             (invoke "hack/make.sh" "dynbinary")))
+         (replace 'check
+           (lambda _
+             ; FIXME: Those don't find any of the go packages
+             ; needed.  Probably GOPATH/GOROOT related.
+             ;(invoke "hack/test/unit")
+             #t))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+               (install-file "bundles/dynbinary-daemon/dockerd-dev" out-bin))
+             ;(setenv "DOCKER_MAKE_INSTALL_PREFIX" (assoc-ref outputs "out"))
+             ; TODO: KEEPBUNDLE=1
+             ;./source/bundles/dynbinary-daemon/dockerd
+             ;(invoke "hack/make.sh" "install-binary")
+             #t)))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("containerd" ,containerd) ; for containerd-shim
+       ("runc" ,runc)
+       ("iproute2" ,iproute)
+       ("iptables" ,iptables)
+       ("pigz" ,pigz)
+       ("procps" ,procps)
+       ("util-linux" ,util-linux)
+       ("lvm2" ,lvm2)))
+    (native-inputs
+     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+       ("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Docker container component library")
+    (description "This package provides a framework to assemble specialized
+container systems.  It includes components for orchestration, image
+management, secret management, configuration management, networking,
+provisioning etc.")
+    (home-page "https://mobyproject.org/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 53%]

* [bug#33893] [PATCH v3 1/4] gnu: Add containerd.
  @ 2018-12-29  1:39 67%     ` Danny Milosavljevic
  2018-12-29  1:39 53%     ` [bug#33893] [PATCH v3 2/4] gnu: Add docker-engine Danny Milosavljevic
                       ` (3 subsequent siblings)
  4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:39 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (containerd): New variable.
---
 gnu/packages/docker.scm | 49 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index c58f3f3ca..f4e676a9f 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,9 +23,13 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web))
 
@@ -142,3 +146,48 @@ created and all the services are started as specified in the configuration.")
 store API.  It allows programmers to interact with a Docker registry using
 Python without keeping their credentials in a Docker configuration file.")
     (license license:asl2.0)))
+
+(define-public containerd
+  (package
+    (name "containerd")
+    (version "1.2.1")
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/containerd/containerd.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "16zn6p1ky3yrgn53z8h9wza53ch91fj47wj5xgz6w4c57j30f66p"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/containerd/containerd"
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'chdir
+           (lambda _
+             (chdir "src/github.com/containerd/containerd")
+             #t))
+         (replace 'build
+           (lambda* (#:key (make-flags '()) #:allow-other-keys)
+             (apply invoke "make" make-flags)))
+         (replace 'install
+           (lambda* (#:key outputs (make-flags '()) #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out")))
+               (apply invoke "make" (string-append "DESTDIR=" out) "install"
+                      make-flags)))))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("libseccomp" ,libseccomp)))
+    (native-inputs
+     `(("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Container runtime")
+    (description "This package provides the container daemon for Docker.
+It includes image transfer and storage, container execution and supervision,
+network attachments.")
+    (home-page "http://containerd.io/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 67%]

* [bug#33893] [PATCH v3 4/4] gnu: Add docker-cli.
                         ` (2 preceding siblings ...)
  2018-12-29  1:39 60%     ` [bug#33893] [PATCH v3 3/4] services: Add docker Danny Milosavljevic
@ 2018-12-29  1:39 65%     ` Danny Milosavljevic
    4 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:39 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-cli): New variable.
---
 gnu/packages/docker.scm | 63 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3ca2fadfd..cbf84aecf 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -27,6 +27,7 @@
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
+  #:use-module (gnu packages autotools)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
@@ -341,3 +342,65 @@ management, secret management, configuration management, networking,
 provisioning etc.")
     (home-page "https://mobyproject.org/")
     (license license:asl2.0)))
+
+(define-public docker-cli
+  (package
+    (name "docker-cli")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/cli.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1ivisys20kphvbqlazc3bsg7pk0ykj9gjx5d4yg439x4n13jxwvb"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/docker/cli"
+       ;; TODO: Tests require a running Docker daemon.
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'setup-environment-2
+           (lambda _
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+
+             ;; Make build reproducible.
+             (setenv "BUILDTIME" "1970-01-01 00:00:01.000000000+00:00")
+             (symlink "src/github.com/docker/cli/scripts" "./scripts")
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
+             #t))
+         (replace 'build
+           (lambda _
+             (invoke "./scripts/build/dynbinary")))
+         (replace 'check
+           (lambda* (#:key make-flags tests? #:allow-other-keys)
+             (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
+             (if tests?
+                 ;; Use the newly-built docker client for the tests.
+                 (with-directory-excursion "src/github.com/docker/cli"
+                   ;; TODO: Run test-e2e as well?
+                   (apply invoke "make" "-f" "docker.Makefile" "test-unit"
+                          (or make-flags '())))
+                 #t)))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (chdir "build")
+               (install-file (readlink "docker") out-bin)
+               (install-file "docker" out-bin)
+               #t))))))
+    (native-inputs
+     `(("go" ,go)
+       ("libltdl" ,libltdl)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Command line interface to Docker")
+    (description "This package provides a command line interface to Docker.")
+    (home-page "http://www.docker.com/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 65%]

* [bug#33893] [PATCH v3 3/4] services: Add docker.
    2018-12-29  1:39 67%     ` [bug#33893] [PATCH v3 1/4] gnu: Add containerd Danny Milosavljevic
  2018-12-29  1:39 53%     ` [bug#33893] [PATCH v3 2/4] gnu: Add docker-engine Danny Milosavljevic
@ 2018-12-29  1:39 60%     ` Danny Milosavljevic
  2018-12-30  9:50 92%       ` Danny Milosavljevic
  2018-12-29  1:39 65%     ` [bug#33893] [PATCH v3 4/4] gnu: Add docker-cli Danny Milosavljevic
    4 siblings, 1 reply; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:39 UTC (permalink / raw)
  To: 33893

* gnu/services/docker.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk            |  1 +
 gnu/services/docker.scm | 90 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 91 insertions(+)
 create mode 100644 gnu/services/docker.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 925d955a6..f6c91dcc7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -482,6 +482,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/desktop.scm			\
   %D%/services/dict.scm				\
   %D%/services/dns.scm				\
+  %D%/services/docker.scm			\
   %D%/services/authentication.scm		\
   %D%/services/games.scm			\
   %D%/services/kerberos.scm			\
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
new file mode 100644
index 000000000..e592185f8
--- /dev/null
+++ b/gnu/services/docker.scm
@@ -0,0 +1,90 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services docker)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages docker)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+
+  #:export (docker-configuration
+            docker-service-type))
+
+(define-configuration docker-configuration
+  (docker
+   (package docker-engine)
+   "Docker daemon package.")
+  (containerd
+   (package containerd)
+   "containerd package."))
+
+(define %docker-accounts
+  (list (user-group (name "docker") (system? #t))))
+
+(define (%containerd-activation config)
+  (let ((state-dir "/var/lib/containerd"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+(define (%docker-activation config)
+  (%containerd-activation config)
+  (let ((state-dir "/var/lib/docker"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+;; TODO: Refactor out into its own module?  How to depend on it then?
+(define (containerd-shepherd-service config)
+  (let* ((package (docker-configuration-containerd config)))
+    (shepherd-service
+           (documentation "containerd daemon.")
+           (provision '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$package "/bin/containerd"))))
+           (stop #~(make-kill-destructor)))))
+
+(define (docker-shepherd-service config)
+  (let* ((docker (docker-configuration-docker config)))
+    (shepherd-service
+           (documentation "Docker daemon.")
+           (provision '(dockerd))
+           (requirement '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$docker "/bin/dockerd"))))
+           (stop #~(make-kill-destructor)))))
+
+(define docker-service-type
+  (service-type (name 'docker)
+		(extensions
+                 (list
+                  (service-extension activation-service-type
+                                     %docker-activation)
+                  (service-extension shepherd-root-service-type
+                                     (lambda args
+                                       (list (apply containerd-shepherd-service args)
+                                             (apply docker-shepherd-service args))))
+                  (service-extension account-service-type
+                                     (const %docker-accounts))))
+                (default-value (docker-configuration))))

^ permalink raw reply related	[relevance 60%]

* [bug#33893] [PATCH v2 1/3] gnu: Add containerd.
  @ 2018-12-29  1:32 67%   ` Danny Milosavljevic
  2018-12-29  1:32 53%   ` [bug#33893] [PATCH v2 2/3] gnu: Add docker-engine Danny Milosavljevic
                     ` (2 subsequent siblings)
  3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:32 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (containerd): New variable.
---
 gnu/packages/docker.scm | 49 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index c58f3f3ca..f4e676a9f 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,9 +23,13 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web))
 
@@ -142,3 +146,48 @@ created and all the services are started as specified in the configuration.")
 store API.  It allows programmers to interact with a Docker registry using
 Python without keeping their credentials in a Docker configuration file.")
     (license license:asl2.0)))
+
+(define-public containerd
+  (package
+    (name "containerd")
+    (version "1.2.1")
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/containerd/containerd.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "16zn6p1ky3yrgn53z8h9wza53ch91fj47wj5xgz6w4c57j30f66p"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/containerd/containerd"
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'chdir
+           (lambda _
+             (chdir "src/github.com/containerd/containerd")
+             #t))
+         (replace 'build
+           (lambda* (#:key (make-flags '()) #:allow-other-keys)
+             (apply invoke "make" make-flags)))
+         (replace 'install
+           (lambda* (#:key outputs (make-flags '()) #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out")))
+               (apply invoke "make" (string-append "DESTDIR=" out) "install"
+                      make-flags)))))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("libseccomp" ,libseccomp)))
+    (native-inputs
+     `(("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Container runtime")
+    (description "This package provides the container daemon for Docker.
+It includes image transfer and storage, container execution and supervision,
+network attachments.")
+    (home-page "http://containerd.io/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 67%]

* [bug#33893] [PATCH v2 2/3] gnu: Add docker-engine.
    2018-12-29  1:32 67%   ` [bug#33893] [PATCH v2 1/3] gnu: Add containerd Danny Milosavljevic
@ 2018-12-29  1:32 53%   ` Danny Milosavljevic
  2018-12-29  1:32 60%   ` [bug#33893] [PATCH v2 3/3] services: Add docker Danny Milosavljevic
    3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:32 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-engine): New variable.
(%docker-version): New variable.
---
 gnu/packages/docker.scm | 152 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 151 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index f4e676a9f..3ca2fadfd 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,15 +23,20 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages golang)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
-  #:use-module (gnu packages python-web))
+  #:use-module (gnu packages python-web)
+  #:use-module (gnu packages virtualization))
+
+(define %docker-version "18.09.0")
 
 (define-public python-docker-py
   (package
@@ -191,3 +196,148 @@ It includes image transfer and storage, container execution and supervision,
 network attachments.")
     (home-page "http://containerd.io/")
     (license license:asl2.0)))
+
+(define-public docker-engine
+  (package
+    (name "docker-engine")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/engine.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1liqbx58grqih6m8hz9y20y5waflv19pv15l3wl64skap2bsn21c"))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:modules
+       ((guix build gnu-build-system)
+        ((guix build go-build-system) #:prefix go:)
+        (guix build utils))
+       #:imported-modules
+       (,@%gnu-build-system-modules
+        (guix build go-build-system))
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'patch-paths
+           (lambda* (#:key inputs #:allow-other-keys)
+             ;(substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+             ; (("") ""))
+             (substitute* "builder/builder-next/executor_unix.go"
+              (("CommandCandidates:.*runc.*")
+               (string-append "CommandCandidates: []string{\""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"},\n")))
+             (substitute* "vendor/github.com/containerd/go-runc/runc.go"
+              (("DefaultCommand = .*")
+               (string-append "DefaultCommand = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "daemon/daemon_unix.go"
+              (("DefaultShimBinary = .*")
+               (string-append "DefaultShimBinary = \""
+                              (assoc-ref inputs "containerd")
+                              "/bin/containerd-shim\"\n"))
+              (("DefaultRuntimeBinary = .*")
+               (string-append "DefaultRuntimeBinary = \""
+                              (assoc-ref inputs "runc")
+                              "/sbin/runc\"\n")))
+             (substitute* "vendor/github.com/moby/buildkit/executor/runcexecutor/executor.go"
+              (("var defaultCommandCandidates = .*")
+               (string-append "var defaultCommandCandidates = []string{\""
+                              (assoc-ref inputs "runc") "/sbin/runc\"}")))
+             (substitute* (filter (lambda (name)
+                                    (not (string-contains name "test")))
+                                  (find-files "\\.go$"))
+              (("\"ps\"")
+               (string-append "\"" (assoc-ref inputs "procps") "/bin/ps\""))
+              ; TODO: zfs ?
+;getPlatformContainerdDaemonOpts ./cmd/dockerd/daemon_unix.go
+; TODO --init-path for docker-init
+; ./cmd/dockerd/config_unix.go InitPath
+;./daemon/config/config.go DefaultInitBinary
+              (("exec\\.LookPath\\(\"mkfs\\.xfs\"\\)")
+               (string-append "\"" (assoc-ref inputs "xfsprogs")
+                              "/bin/mkfs.xfs\""))
+              (("exec\\.LookPath\\(\"lvmdiskscan\"\\)")
+               (string-append "\"" (assoc-ref inputs "lvm2")
+                              "/sbin/lvmdiskscan\""))
+              (("exec\\.LookPath\\(\"pvdisplay\"\\)")
+               (string-append "\"" (assoc-ref inputs "lvm2")
+                              "/sbin/pvdisplay\""))
+              (("exec\\.LookPath\\(\"blkid\"\\)")
+               (string-append "\"" (assoc-ref inputs "util-linux")
+                              "/sbin/blkid\""))
+              (("exec\\.LookPath\\(\"unpigz\"\\)")
+               (string-append "\"" (assoc-ref inputs "pigz")
+                              "/bin/unpigz\""))
+              (("exec\\.LookPath\\(\"iptables\"\\)")
+               (string-append "\"" (assoc-ref inputs "iptables")
+                              "/sbin/iptables\""))
+              (("exec\\.LookPath\\(\"ip\"\\)")
+               (string-append "\"" (assoc-ref inputs "iproute2")
+                              "/sbin/ip\""))
+              ;(("LookPath") "Guix_doesnt_want_LookPath")
+             )
+             #t))
+         (replace 'configure
+           (lambda _
+             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
+             (setenv "AUTO_GOPATH" "1")
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+             ;; Our LD doesn't like the statically linked relocatable things
+             ;; that go produces, so install the dynamic version of
+             ;; dockerd instead.
+             ;(substitute* "hack/make/install-binary"
+             ; (("/binary-daemon") "/dynbinary-daemon"))
+             #t))
+         (add-before 'build 'setup-environment
+           (assoc-ref go:%standard-phases 'setup-environment))
+         (replace 'build
+           (lambda _
+             ;(invoke "hack/make.sh" "binary")
+             ; FIXME: bash -c 'hack/validate/default && hack/make.sh'
+             (invoke "hack/make.sh" "dynbinary")))
+         (replace 'check
+           (lambda _
+             ; FIXME: Those don't find any of the go packages
+             ; needed.  Probably GOPATH/GOROOT related.
+             ;(invoke "hack/test/unit")
+             #t))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+               (install-file "bundles/dynbinary-daemon/dockerd-dev" out-bin))
+             ;(setenv "DOCKER_MAKE_INSTALL_PREFIX" (assoc-ref outputs "out"))
+             ; TODO: KEEPBUNDLE=1
+             ;./source/bundles/dynbinary-daemon/dockerd
+             ;(invoke "hack/make.sh" "install-binary")
+             #t)))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)
+       ("containerd" ,containerd) ; for containerd-shim
+       ("runc" ,runc)
+       ("iproute2" ,iproute)
+       ("iptables" ,iptables)
+       ("pigz" ,pigz)
+       ("procps" ,procps)
+       ("util-linux" ,util-linux)
+       ("lvm2" ,lvm2)))
+    (native-inputs
+     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+       ("go" ,go)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Docker container component library")
+    (description "This package provides a framework to assemble specialized
+container systems.  It includes components for orchestration, image
+management, secret management, configuration management, networking,
+provisioning etc.")
+    (home-page "https://mobyproject.org/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 53%]

* [bug#33893] [PATCH v2 3/3] services: Add docker.
    2018-12-29  1:32 67%   ` [bug#33893] [PATCH v2 1/3] gnu: Add containerd Danny Milosavljevic
  2018-12-29  1:32 53%   ` [bug#33893] [PATCH v2 2/3] gnu: Add docker-engine Danny Milosavljevic
@ 2018-12-29  1:32 60%   ` Danny Milosavljevic
    3 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-29  1:32 UTC (permalink / raw)
  To: 33893

* gnu/services/docker.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk            |  1 +
 gnu/services/docker.scm | 90 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 91 insertions(+)
 create mode 100644 gnu/services/docker.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 925d955a6..f6c91dcc7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -482,6 +482,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/desktop.scm			\
   %D%/services/dict.scm				\
   %D%/services/dns.scm				\
+  %D%/services/docker.scm			\
   %D%/services/authentication.scm		\
   %D%/services/games.scm			\
   %D%/services/kerberos.scm			\
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
new file mode 100644
index 000000000..e592185f8
--- /dev/null
+++ b/gnu/services/docker.scm
@@ -0,0 +1,90 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services docker)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages docker)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+
+  #:export (docker-configuration
+            docker-service-type))
+
+(define-configuration docker-configuration
+  (docker
+   (package docker-engine)
+   "Docker daemon package.")
+  (containerd
+   (package containerd)
+   "containerd package."))
+
+(define %docker-accounts
+  (list (user-group (name "docker") (system? #t))))
+
+(define (%containerd-activation config)
+  (let ((state-dir "/var/lib/containerd"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+(define (%docker-activation config)
+  (%containerd-activation config)
+  (let ((state-dir "/var/lib/docker"))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$state-dir))))
+
+;; TODO: Refactor out into its own module?  How to depend on it then?
+(define (containerd-shepherd-service config)
+  (let* ((package (docker-configuration-containerd config)))
+    (shepherd-service
+           (documentation "containerd daemon.")
+           (provision '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$package "/bin/containerd"))))
+           (stop #~(make-kill-destructor)))))
+
+(define (docker-shepherd-service config)
+  (let* ((docker (docker-configuration-docker config)))
+    (shepherd-service
+           (documentation "Docker daemon.")
+           (provision '(dockerd))
+           (requirement '(containerd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$docker "/bin/dockerd"))))
+           (stop #~(make-kill-destructor)))))
+
+(define docker-service-type
+  (service-type (name 'docker)
+		(extensions
+                 (list
+                  (service-extension activation-service-type
+                                     %docker-activation)
+                  (service-extension shepherd-root-service-type
+                                     (lambda args
+                                       (list (apply containerd-shepherd-service args)
+                                             (apply docker-shepherd-service args))))
+                  (service-extension account-service-type
+                                     (const %docker-accounts))))
+                (default-value (docker-configuration))))

^ permalink raw reply related	[relevance 60%]

* [bug#33893] [PATCH 1/2] gnu: Add docker-engine.
  @ 2018-12-28 10:17 60% ` Danny Milosavljevic
  2018-12-28 10:17 65%   ` [bug#33893] [PATCH 2/2] gnu: Add docker-cli Danny Milosavljevic
    1 sibling, 1 reply; 149+ results
From: Danny Milosavljevic @ 2018-12-28 10:17 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (%docker-version): New variable.
(docker-engine): New variable.  Export it.
---
 gnu/packages/docker.scm | 83 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index c58f3f3ca..3d1a90fc7 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -23,12 +23,18 @@
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
+  #:use-module (guix build-system gnu)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
   #:use-module (gnu packages check)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web))
 
+(define %docker-version "18.09.0")
+
 (define-public python-docker-py
   (package
     (name "python-docker-py")
@@ -142,3 +148,80 @@ created and all the services are started as specified in the configuration.")
 store API.  It allows programmers to interact with a Docker registry using
 Python without keeping their credentials in a Docker configuration file.")
     (license license:asl2.0)))
+
+(define-public docker-engine
+  (package
+    (name "docker-engine")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/engine.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1liqbx58grqih6m8hz9y20y5waflv19pv15l3wl64skap2bsn21c"))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:modules
+       ((guix build gnu-build-system)
+        ((guix build go-build-system) #:prefix go:)
+        (guix build utils))
+       #:imported-modules
+       (,@%gnu-build-system-modules
+        (guix build go-build-system))
+       #:phases
+       (modify-phases %standard-phases
+         (replace 'configure
+           (lambda _
+             (setenv "DOCKER_GITCOMMIT" (string-append "v" ,%docker-version))
+             (setenv "AUTO_GOPATH" "1")
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+             ;; Our LD doesn't like the statically linked relocatable things
+             ;; that go produces, so install the dynamic version of
+             ;; dockerd instead.
+             ;(substitute* "hack/make/install-binary"
+             ; (("/binary-daemon") "/dynbinary-daemon"))
+             #t))
+         (add-before 'build 'setup-environment
+           (assoc-ref go:%standard-phases 'setup-environment))
+         (replace 'build
+           (lambda _
+             ;(invoke "hack/make.sh" "binary")
+             ; FIXME: bash -c 'hack/validate/default && hack/make.sh'
+             (invoke "hack/make.sh" "dynbinary")))
+         (replace 'check
+           (lambda _
+             ; FIXME: Those don't find any of the go packages
+             ; needed.  Probably GOPATH/GOROOT related.
+             ;(invoke "hack/test/unit")
+             #t))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (install-file "bundles/dynbinary-daemon/dockerd" out-bin)
+               (install-file "bundles/dynbinary-daemon/dockerd-dev" out-bin))
+             ;(setenv "DOCKER_MAKE_INSTALL_PREFIX" (assoc-ref outputs "out"))
+             ; TODO: KEEPBUNDLE=1
+             ;./source/bundles/dynbinary-daemon/dockerd
+             ;(invoke "hack/make.sh" "install-binary")
+             #t)))))
+    (inputs
+     `(("btrfs-progs" ,btrfs-progs)))
+    (native-inputs
+     `(("eudev" ,eudev) ; TODO: Should be propagated by lvm2 (.pc -> .pc)
+       ("go" ,go)
+       ("lvm2" ,lvm2)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Docker container component library")
+    (description "This package provides a framework to assemble specialized
+container systems.  It includes components for orchestration, image
+management, secret management, configuration management, networking,
+provisioning etc.")
+    (home-page "https://mobyproject.org/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 60%]

* [bug#33893] [PATCH 2/2] gnu: Add docker-cli.
  2018-12-28 10:17 60% ` [bug#33893] [PATCH 1/2] gnu: Add docker-engine Danny Milosavljevic
@ 2018-12-28 10:17 65%   ` Danny Milosavljevic
  0 siblings, 0 replies; 149+ results
From: Danny Milosavljevic @ 2018-12-28 10:17 UTC (permalink / raw)
  To: 33893

* gnu/packages/docker.scm (docker-cli): New variable.  Export it.
---
 gnu/packages/docker.scm | 61 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 61 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 3d1a90fc7..caf70cbc9 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -24,8 +24,10 @@
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build-system go)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
+  #:use-module (gnu packages autotools)
   #:use-module (gnu packages check)
   #:use-module (gnu packages golang)
   #:use-module (gnu packages linux)
@@ -225,3 +227,62 @@ management, secret management, configuration management, networking,
 provisioning etc.")
     (home-page "https://mobyproject.org/")
     (license license:asl2.0)))
+
+(define-public docker-cli
+  (package
+    (name "docker-cli")
+    (version %docker-version)
+    (source
+     (origin
+      (method git-fetch)
+      (uri (git-reference
+            (url "https://github.com/docker/cli.git")
+            (commit (string-append "v" version))))
+      (file-name (git-file-name name version))
+      (sha256
+       (base32
+        "1ivisys20kphvbqlazc3bsg7pk0ykj9gjx5d4yg439x4n13jxwvb"))))
+    (build-system go-build-system)
+    (arguments
+     `(#:import-path "github.com/docker/cli"
+       ;; TODO: Tests require a running Docker daemon.
+       #:tests? #f
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'setup-environment-2
+           (lambda _
+             ;; Respectively, strip the symbol table and debug
+             ;; information, and the DWARF symbol table.
+             (setenv "LDFLAGS" "-s -w")
+             (symlink "src/github.com/docker/cli/scripts" "./scripts")
+             (symlink "src/github.com/docker/cli/docker.Makefile" "./docker.Makefile")
+             #t))
+         (replace 'build
+           (lambda _
+             (invoke "./scripts/build/dynbinary")))
+         (replace 'check
+           (lambda* (#:key make-flags tests? #:allow-other-keys)
+             (setenv "PATH" (string-append (getcwd) "/build:" (getenv "PATH")))
+             (if tests?
+                 ;; Use the newly-built docker client for the tests.
+                 (with-directory-excursion "src/github.com/docker/cli"
+                   ;; TODO: Run test-e2e as well?
+                   (apply invoke "make" "-f" "docker.Makefile" "test-unit"
+                          (or make-flags '())))
+                 #t)))
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out"))
+                    (out-bin (string-append out "/bin")))
+               (chdir "build")
+               (install-file (readlink "docker") out-bin)
+               (install-file "docker" out-bin)
+               #t))))))
+    (native-inputs
+     `(("go" ,go)
+       ("libltdl" ,libltdl)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Command line interface to Docker")
+    (description "This package provides a command line interface to Docker.")
+    (home-page "http://www.docker.com/")
+    (license license:asl2.0)))

^ permalink raw reply related	[relevance 65%]

* [bug#33259] [PATCH 4/8] pack: Docker backend now honors '--localstatedir'.
  @ 2018-11-04 22:10 51% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2018-11-04 22:10 UTC (permalink / raw)
  To: 33259

* guix/docker.scm (build-docker-image): Add #:database parameter.
Create /var/guix/db, /var/guix/profiles, etc. when DATABASE is true.
* guix/scripts/pack.scm (docker-image): Export.  Remove #:deduplicate?
parameter.  Define 'database' and pass it to 'docker-image'.
* tests/pack.scm (test-assertm): Recompile the derivation of
%BOOTSTRAP-GUILE.
("docker-image + localstatedir"): New test.
---
 guix/docker.scm       | 16 ++++++++++++-
 guix/scripts/pack.scm |  9 +++++++-
 tests/pack.scm        | 53 +++++++++++++++++++++++++++++++++++++++++--
 3 files changed, 74 insertions(+), 4 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 0757d3356f..c19a24d45c 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -26,6 +26,7 @@
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -108,11 +109,15 @@ return \"a\"."
                              (symlinks '())
                              (transformations '())
                              (system (utsname:machine (uname)))
+                             database
                              compressor
                              (creation-time (current-time time-utc)))
   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
 must be a store path that is a prefix of any store paths in PATHS.
 
+When DATABASE is true, copy it to /var/guix/db in the image and create
+/var/guix/gcroots and friends.
+
 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
@@ -188,10 +193,15 @@ SRFI-19 time-utc object, as the creation time in metadata."
                                 source))))
                   symlinks)
 
+        (when database
+          ;; Initialize /var/guix, assuming PREFIX points to a profile.
+          (install-database-and-gc-roots "." database prefix))
+
         (apply invoke "tar" "-cf" "layer.tar"
                `(,@transformation-options
                  ,@%tar-determinism-options
                  ,@paths
+                 ,@(if database '("var") '())
                  ,@(map symlink-source symlinks)))
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -203,7 +213,11 @@ SRFI-19 time-utc object, as the creation time in metadata."
         (system* "tar" "--delete" "/" "-f" "layer.tar")
         (for-each delete-file-recursively
                   (map (compose topmost-component symlink-source)
-                       symlinks)))
+                       symlinks))
+
+        ;; Delete /var/guix.
+        (when database
+          (delete-file-recursively "var")))
 
       (with-output-to-file "config.json"
         (lambda ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 3e6430bcce..09fc88988a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -52,6 +52,8 @@
   #:export (compressor?
             lookup-compressor
             self-contained-tarball
+            docker-image
+
             guix-pack))
 
 ;; Type of a compression tool.
@@ -360,7 +362,6 @@ added to the pack."
 
 (define* (docker-image name profile
                        #:key target
-                       deduplicate?
                        (compressor (first %compressors))
                        localstatedir?
                        (symlinks '())
@@ -370,6 +371,11 @@ 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."
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (define defmod 'define-module)                  ;trick Geiser
 
   (define build
@@ -388,6 +394,7 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
+                                #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
diff --git a/tests/pack.scm b/tests/pack.scm
index 6bd18bdee2..e8d4f9f18d 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -22,6 +22,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix profiles)
+  #:use-module (guix packages)                    ;XXX: debugging
   #:use-module (guix monads)
   #:use-module (guix grafts)
   #:use-module (guix tests)
@@ -37,8 +38,9 @@
 
 (define-syntax-rule (test-assertm name store exp)
   (test-assert name
-    (run-with-store store exp
-                    #:guile-for-build (%guile-for-build))))
+    (let ((guile (package-derivation store %bootstrap-guile)))
+      (run-with-store store exp
+                      #:guile-for-build guile))))
 
 (define %gzip-compressor
   ;; Compressor that uses the bootstrap 'gzip'.
@@ -79,6 +81,53 @@
                                      (readlink "bin/Guile"))))))))
     (built-derivations (list check))))
 
+;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
+;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes.  Thus,
+;; run it on the user's store, if it's available, on the grounds that these
+;; dependencies may be already there, or we can get substitutes or build them
+;; quite inexpensively; see <https://bugs.gnu.org/32184>.
+
+(with-external-store store
+  (unless store (test-skip 1))
+  (test-assertm "docker-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile (profile-derivation (packages->manifest
+                                       (list %bootstrap-guile))
+                                      #:hooks '()
+                                      #:locales? #f))
+         (tarball (docker-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #:localstatedir? #t))
+         (check   (gexp->derivation
+                   "check-tarball"
+                   (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils)
+                                      (ice-9 match))
+
+                         (define bin
+                           (string-append "." #$profile "/bin"))
+
+                         (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
+                         (mkdir "base")
+                         (with-directory-excursion "base"
+                           (invoke "tar" "xvf" #$tarball))
+
+                         (match (find-files "base" "layer.tar")
+                           ((layer)
+                            (invoke "tar" "xvf" layer)))
+
+                         (when
+                          (and (file-exists? (string-append bin "/guile"))
+                               (file-exists? "var/guix/db/db.sqlite")
+                               (string=? (string-append #$%bootstrap-guile "/bin")
+                                         (pk 'binlink (readlink bin)))
+                               (string=? (string-append #$profile "/bin/guile")
+                                         (pk 'guilelink (readlink "bin/Guile"))))
+                          (mkdir #$output)))))))
+      (built-derivations (list check)))))
+
 (test-end)
 
 ;; Local Variables:
-- 
2.19.1

^ permalink raw reply related	[relevance 51%]

* [bug#32606] [PATCH 1/1] Switch to Guile-Gcrypt.
  @ 2018-09-01 22:26  9% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2018-09-01 22:26 UTC (permalink / raw)
  To: 32606

This removes (guix hash) and (guix pk-crypto), which now live as part of
Guile-Gcrypt (version 0.1.0.)

* guix/gcrypt.scm, guix/hash.scm, guix/pk-crypto.scm,
tests/hash.scm, tests/pk-crypto.scm: Remove.
* configure.ac: Test for Guile-Gcrypt.  Remove LIBGCRYPT and
LIBGCRYPT_LIBDIR assignments.
* m4/guix.m4 (GUIX_ASSERT_LIBGCRYPT_USABLE): Remove.
* README: Add Guile-Gcrypt to the dependencies; move libgcrypt as
"required unless --disable-daemon".
* doc/guix.texi (Requirements): Likewise.
* gnu/packages/bash.scm, guix/derivations.scm, guix/docker.scm,
guix/git.scm, guix/http-client.scm, guix/import/cpan.scm,
guix/import/cran.scm, guix/import/crate.scm, guix/import/elpa.scm,
guix/import/gnu.scm, guix/import/hackage.scm,
guix/import/texlive.scm, guix/import/utils.scm, guix/nar.scm,
guix/pki.scm, guix/scripts/archive.scm,
guix/scripts/authenticate.scm, guix/scripts/download.scm,
guix/scripts/hash.scm, guix/scripts/pack.scm,
guix/scripts/publish.scm, guix/scripts/refresh.scm,
guix/scripts/substitute.scm, guix/store.scm,
guix/store/deduplication.scm, guix/tests.scm, tests/base32.scm,
tests/builders.scm, tests/challenge.scm, tests/cpan.scm,
tests/crate.scm, tests/derivations.scm, tests/gem.scm,
tests/nar.scm, tests/opam.scm, tests/pki.scm,
tests/publish.scm, tests/pypi.scm, tests/store-deduplication.scm,
tests/store.scm, tests/substitute.scm: Adjust imports.
* gnu/system/vm.scm: Likewise.
(guile-sqlite3&co): Rename to...
(gcrypt-sqlite3&co): ... this.  Add GUILE-GCRYPT.
(expression->derivation-in-linux-vm)[config]: Remove.
(iso9660-image)[config]: Remove.
(qemu-image)[config]: Remove.
(system-docker-image)[config]: Remove.
* guix/scripts/pack.scm: Adjust imports.
(guile-sqlite3&co): Rename to...
(gcrypt-sqlite3&co): ... this.  Add GUILE-GCRYPT.
(self-contained-tarball)[build]: Call 'make-config.scm' without
 #:libgcrypt argument.
(squashfs-image)[libgcrypt]: Remove.
[build]: Call 'make-config.scm' without #:libgcrypt.
(docker-image)[config, json]: Remove.
[build]: Add GUILE-GCRYPT to the extensions  Remove (guix config) from
the imported modules.
* guix/self.scm (specification->package): Remove "libgcrypt", add
"guile-gcrypt".
(compiled-guix): Remove #:libgcrypt.
[guile-gcrypt]: New variable.
[dependencies]: Add it.
[*core-modules*]: Remove #:libgcrypt from 'make-config.scm' call.
Add #:extensions.
[*config*]: Remove #:libgcrypt from 'make-config.scm' call.
(%dependency-variables): Remove %libgcrypt.
(make-config.scm): Remove #:libgcrypt.
* build-aux/build-self.scm (guile-gcrypt): New variable.
(make-config.scm): Remove #:libgcrypt.
(build-program)[fake-gcrypt-hash]: New variable.
Add (gcrypt hash) to the imported modules.  Adjust load path
assignments.
---
 Makefile.am                   |   5 -
 README                        |   3 +-
 build-aux/build-self.scm      |  81 ++++++-
 configure.ac                  |  13 +-
 doc/guix.texi                 |   4 +-
 gnu/packages/bash.scm         |   2 +-
 gnu/system/vm.scm             |  48 ++--
 guix/derivations.scm          |   2 +-
 guix/docker.scm               |   2 +-
 guix/gcrypt.scm               |  49 ----
 guix/git.scm                  |   2 +-
 guix/hash.scm                 | 184 ---------------
 guix/http-client.scm          |   2 +-
 guix/import/cpan.scm          |   2 +-
 guix/import/cran.scm          |   2 +-
 guix/import/crate.scm         |   2 +-
 guix/import/elpa.scm          |   2 +-
 guix/import/gnu.scm           |   2 +-
 guix/import/hackage.scm       |   2 +-
 guix/import/texlive.scm       |   2 +-
 guix/import/utils.scm         |   2 +-
 guix/nar.scm                  |   4 +-
 guix/pk-crypto.scm            | 407 ----------------------------------
 guix/pki.scm                  |   2 +-
 guix/scripts/archive.scm      |   2 +-
 guix/scripts/authenticate.scm |   2 +-
 guix/scripts/download.scm     |   2 +-
 guix/scripts/hash.scm         |   6 +-
 guix/scripts/pack.scm         |  60 ++---
 guix/scripts/publish.scm      |   4 +-
 guix/scripts/refresh.scm      |   2 +-
 guix/scripts/substitute.scm   |   4 +-
 guix/self.scm                 |  26 +--
 guix/store.scm                |   2 +-
 guix/store/deduplication.scm  |   2 +-
 guix/tests.scm                |   2 +-
 m4/guix.m4                    |  18 --
 tests/base32.scm              |   2 +-
 tests/builders.scm            |   2 +-
 tests/challenge.scm           |   2 +-
 tests/cpan.scm                |   2 +-
 tests/crate.scm               |   2 +-
 tests/derivations.scm         |   2 +-
 tests/gem.scm                 |   2 +-
 tests/hash.scm                | 128 -----------
 tests/nar.scm                 |   2 +-
 tests/opam.scm                |   2 +-
 tests/packages.scm            |   2 +-
 tests/pk-crypto.scm           | 290 ------------------------
 tests/pki.scm                 |   4 +-
 tests/publish.scm             |   4 +-
 tests/pypi.scm                |   2 +-
 tests/store-deduplication.scm |   2 +-
 tests/store.scm               |   2 +-
 tests/substitute.scm          |   4 +-
 55 files changed, 175 insertions(+), 1239 deletions(-)
 delete mode 100644 guix/gcrypt.scm
 delete mode 100644 guix/hash.scm
 delete mode 100644 guix/pk-crypto.scm
 delete mode 100644 tests/hash.scm
 delete mode 100644 tests/pk-crypto.scm

diff --git a/Makefile.am b/Makefile.am
index 324674a60..8ffee98c4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -63,9 +63,6 @@ MODULES =					\
   guix/base64.scm				\
   guix/cpio.scm					\
   guix/records.scm				\
-  guix/gcrypt.scm				\
-  guix/hash.scm					\
-  guix/pk-crypto.scm				\
   guix/pki.scm					\
   guix/progress.scm				\
   guix/combinators.scm				\
@@ -329,8 +326,6 @@ SCM_TESTS =					\
   tests/base32.scm				\
   tests/base64.scm				\
   tests/cpio.scm				\
-  tests/hash.scm				\
-  tests/pk-crypto.scm				\
   tests/pki.scm					\
   tests/print.scm				\
   tests/sets.scm				\
diff --git a/README b/README
index 348a7ada5..4c76c4bc4 100644
--- a/README
+++ b/README
@@ -21,7 +21,7 @@ Guix is based on the [[https://nixos.org/nix/][Nix]] package manager.
 GNU Guix currently depends on the following packages:
 
   - [[https://gnu.org/software/guile/][GNU Guile 2.2.x or 2.0.x]], version 2.0.13 or later
-  - [[https://gnupg.org/][GNU libgcrypt]]
+  - [[https://notabug.org/cwebber/guile-gcrypt][Guile-Gcrypt]] 0.1.0 or later
   - [[https://www.gnu.org/software/make/][GNU Make]]
   - [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled
   - [[https://notabug.org/civodul/guile-sqlite3][Guile-SQLite3]], version 0.1.0 or later
@@ -31,6 +31,7 @@ GNU Guix currently depends on the following packages:
 
 Unless `--disable-daemon' was passed, the following packages are needed:
 
+  - [[https://gnupg.org/][GNU libgcrypt]]
   - [[https://sqlite.org/][SQLite 3]]
   - [[https://gcc.gnu.org][GCC's g++]]
   - optionally [[http://www.bzip.org][libbz2]]
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 3ecdc931a..f472724f1 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -22,6 +22,7 @@
   #:use-module (guix ui)
   #:use-module (guix config)
   #:use-module (guix modules)
+  #:use-module (guix build-system gnu)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (rnrs io ports)
@@ -72,7 +73,7 @@
                                       (variables rest ...))))))
     (variables %localstatedir %storedir %sysconfdir %system)))
 
-(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
+(define* (make-config.scm #:key zlib gzip xz bzip2
                           (package-name "GNU Guix")
                           (package-version "0")
                           (bug-report-address "bug-guix@gnu.org")
@@ -92,7 +93,6 @@
                                %state-directory
                                %store-database-directory
                                %config-directory
-                               %libgcrypt
                                %libz
                                %gzip
                                %bzip2
@@ -137,9 +137,6 @@
                      (define %xz
                        #+(and xz (file-append xz "/bin/xz")))
 
-                     (define %libgcrypt
-                       #+(and libgcrypt
-                              (file-append libgcrypt "/lib/libgcrypt")))
                      (define %libz
                        #+(and zlib
                               (file-append zlib "/lib/libz")))))))
@@ -200,6 +197,44 @@ person's version identifier."
   ;; XXX: Replace with a Git commit id.
   (date->string (current-date 0) "~Y~m~d.~H"))
 
+(define guile-gcrypt
+  ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
+  ;; August 2018.  If it has it, it's at least version 0.1.0, which is good
+  ;; enough.  If it doesn't, specify our own package because the target Guix
+  ;; requires it.
+  (match (find-best-packages-by-name "guile-gcrypt" #f)
+    (()
+     (package
+       (name "guile-gcrypt")
+       (version "0.1.0")
+       (home-page "https://notabug.org/cwebber/guile-gcrypt")
+       (source (origin
+                 (method url-fetch)
+                 (uri (string-append home-page "/archive/v" version ".tar.gz"))
+                 (sha256
+                  (base32
+                   "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
+                 (file-name (string-append name "-" version ".tar.gz"))))
+       (build-system gnu-build-system)
+       (native-inputs
+        `(("pkg-config" ,(specification->package "pkg-config"))
+          ("autoconf" ,(specification->package "autoconf"))
+          ("automake" ,(specification->package "automake"))
+          ("texinfo" ,(specification->package "texinfo"))))
+       (inputs
+        `(("guile" ,(specification->package "guile"))
+          ("libgcrypt" ,(specification->package "libgcrypt"))))
+       (synopsis "Cryptography library for Guile using Libgcrypt")
+       (description
+        "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
+GNU Libgcrypt crytographic library.  It provides modules for cryptographic
+hash functions, message authentication codes (MAC), public-key cryptography,
+strong randomness, and more.  It is implemented using the foreign function
+interface (FFI) of Guile.")
+       (license #f)))                             ;license:gpl3+
+    ((package . _)
+     package)))
+
 (define* (build-program source version
                         #:optional (guile-version (effective-version))
                         #:key (pull-version 0))
@@ -212,10 +247,21 @@ person's version identifier."
       (('gnu _ ...)    #t)
       (_               #f)))
 
+  (define fake-gcrypt-hash
+    ;; Fake (gcrypt hash) module; see below.
+    (scheme-file "hash.scm"
+                 #~(define-module (gcrypt hash)
+                     #:export (sha1 sha256))))
+
   (with-imported-modules `(((guix config)
-                            => ,(make-config.scm
-                                 #:libgcrypt
-                                 (specification->package "libgcrypt")))
+                            => ,(make-config.scm))
+
+                           ;; To avoid relying on 'with-extensions', which was
+                           ;; introduced in 0.15.0, provide a fake (gcrypt
+                           ;; hash) just so that we can build modules, and
+                           ;; adjust %LOAD-PATH later on.
+                           ((gcrypt hash) => ,fake-gcrypt-hash)
+
                            ,@(source-module-closure `((guix store)
                                                       (guix self)
                                                       (guix derivations)
@@ -237,13 +283,24 @@ person's version identifier."
                            (match %load-path
                              ((front _ ...)
                               (unless (string=? front source) ;already done?
-                                (set! %load-path (list source front)))))))
+                                (set! %load-path
+                                  (list source
+                                        (string-append #$guile-gcrypt
+                                                       "/share/guile/site/"
+                                                       (effective-version))
+                                        front)))))))
 
-                        ;; Only load our own modules or those of Guile.
+                        ;; Only load Guile-Gcrypt, our own modules, or those
+                        ;; of Guile.
                         (match %load-compiled-path
                           ((front _ ... sys1 sys2)
-                           (set! %load-compiled-path
-                             (list front sys1 sys2)))))
+                           (unless (string-prefix? #$guile-gcrypt front)
+                             (set! %load-compiled-path
+                               (list (string-append #$guile-gcrypt
+                                                    "/lib/guile/"
+                                                    (effective-version)
+                                                    "/site-ccache")
+                                     front sys1 sys2))))))
 
                       (use-modules (guix store)
                                    (guix self)
diff --git a/configure.ac b/configure.ac
index b34f15a77..c83d4d8a2 100644
--- a/configure.ac
+++ b/configure.ac
@@ -130,6 +130,11 @@ if test "x$guix_cv_have_recent_guile_sqlite3" != "xyes"; then
   AC_MSG_ERROR([A recent Guile-SQLite3 could not be found; please install it.])
 fi
 
+GUILE_MODULE_AVAILABLE([have_guile_gcrypt], [(gcrypt hash)])
+if test "x$have_guile_gcrypt" != "xyes"; then
+  AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
+fi
+
 dnl Make sure we have a full-fledged Guile.
 GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
 
@@ -213,16 +218,10 @@ AC_ARG_WITH([libgcrypt-libdir],
    esac])
 
 dnl If none of the --with-libgcrypt-* options was used, try to determine the
-dnl absolute file name of libgcrypt.so.
+dnl the library directory.
 case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in
   xnono)
     GUIX_LIBGCRYPT_LIBDIR([LIBGCRYPT_LIBDIR])
-    if test "x$LIBGCRYPT_LIBDIR" != x; then
-      LIBGCRYPT="$LIBGCRYPT_LIBDIR/libgcrypt"
-    else
-      dnl 'config-daemon.ac' expects "no" in this case.
-      LIBGCRYPT_LIBDIR="no"
-    fi
     ;;
 esac
 
diff --git a/doc/guix.texi b/doc/guix.texi
index 861105979..313e12387 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -619,7 +619,8 @@ GNU Guix depends on the following packages:
 @itemize
 @item @url{http://gnu.org/software/guile/, GNU Guile}, version 2.0.13 or
 later, including 2.2.x;
-@item @url{http://gnupg.org/, GNU libgcrypt};
+@item @url{https://notabug.org/cwebber/guile-gcrypt, Guile-Gcrypt}, version
+0.1.0 or later;
 @item
 @uref{http://gnutls.org/, GnuTLS}, specifically its Guile bindings
 (@pxref{Guile Preparations, how to install the GnuTLS bindings for
@@ -661,6 +662,7 @@ Unless @code{--disable-daemon} was passed to @command{configure}, the
 following packages are also needed:
 
 @itemize
+@item @url{http://gnupg.org/, GNU libgcrypt};
 @item @url{http://sqlite.org, SQLite 3};
 @item @url{http://gcc.gnu.org, GCC's g++}, with support for the
 C++11 standard.
diff --git a/gnu/packages/bash.scm b/gnu/packages/bash.scm
index 64f7782f5..121a459fa 100644
--- a/gnu/packages/bash.scm
+++ b/gnu/packages/bash.scm
@@ -36,7 +36,7 @@
   #:use-module (guix store)
   #:use-module (guix build-system gnu)
   #:autoload   (guix gnupg) (gnupg-verify*)
-  #:autoload   (guix hash) (port-sha256)
+  #:autoload   (gcrypt hash) (port-sha256)
   #:autoload   (guix base32) (bytevector->nix-base32-string)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b505b0cf6..3898872a4 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -32,7 +32,7 @@
   #:use-module (guix modules)
   #:use-module (guix scripts pack)
   #:use-module (guix utils)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module ((guix self) #:select (make-config.scm))
 
@@ -43,7 +43,7 @@
   #:use-module (gnu packages cdrom)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
-  #:autoload   (gnu packages gnupg) (libgcrypt)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -124,10 +124,12 @@
     (('gnu rest ...) #t)
     (rest #f)))
 
-(define guile-sqlite3&co
-  ;; Guile-SQLite3 and its propagated inputs.
-  (cons guile-sqlite3
-        (package-transitive-propagated-inputs guile-sqlite3)))
+(define gcrypt-sqlite3&co
+  ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+  (append-map (lambda (package)
+                (cons package
+                      (package-transitive-propagated-inputs package)))
+              (list guile-gcrypt guile-sqlite3)))
 
 (define* (expression->derivation-in-linux-vm name exp
                                              #:key
@@ -164,10 +166,6 @@ based on the size of the closure of REFERENCES-GRAPHS.
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs, as for `derivation'.  The files containing the reference graphs are
 made available under the /xchg CIFS share."
-  (define config
-    ;; (guix config) module for consumption by (guix gcrypt).
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define user-builder
     (program-file "builder-in-linux-vm" exp))
 
@@ -195,12 +193,14 @@ made available under the /xchg CIFS share."
 
     (define builder
       ;; Code that launches the VM that evaluates EXP.
-      (with-extensions guile-sqlite3&co
+      (with-extensions gcrypt-sqlite3&co
         (with-imported-modules `(,@(source-module-closure
                                     '((guix build utils)
                                       (gnu build vm))
                                     #:select? not-config?)
-                                 ((guix config) => ,config))
+
+                                 ;; For consumption by (gnu store database).
+                                 ((guix config) => ,(make-config.scm)))
           #~(begin
               (use-modules (guix build utils)
                            (gnu build vm))
@@ -255,9 +255,6 @@ made available under the /xchg CIFS share."
   "Return a bootable, stand-alone iso9660 image.
 
 INPUTS is a list of inputs (as for packages)."
-  (define config
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -265,12 +262,12 @@ INPUTS is a list of inputs (as for packages)."
 
   (expression->derivation-in-linux-vm
    name
-   (with-extensions guile-sqlite3&co
+   (with-extensions gcrypt-sqlite3&co
      (with-imported-modules `(,@(source-module-closure '((gnu build vm)
                                                          (guix store database)
                                                          (guix build utils))
                                                        #:select? not-config?)
-                              ((guix config) => ,config))
+                              ((guix config) => ,(make-config.scm)))
        #~(begin
            (use-modules (gnu build vm)
                         (guix store database)
@@ -347,9 +344,6 @@ INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
 the image."
-  (define config
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -357,13 +351,13 @@ the image."
 
   (expression->derivation-in-linux-vm
    name
-   (with-extensions guile-sqlite3&co
+   (with-extensions gcrypt-sqlite3&co
      (with-imported-modules `(,@(source-module-closure '((gnu build vm)
                                                          (gnu build bootloader)
                                                          (guix store database)
                                                          (guix build utils))
                                                        #:select? not-config?)
-                              ((guix config) => ,config))
+                              ((guix config) => ,(make-config.scm)))
        #~(begin
            (use-modules (gnu build bootloader)
                         (gnu build vm)
@@ -462,10 +456,6 @@ makes sense when you want to build a GuixSD Docker image that has Guix
 installed inside of it.  If you don't need Guix (e.g., your GuixSD Docker
 image just contains a web server that is started by the Shepherd), then you
 should set REGISTER-CLOSURES? to #f."
-  (define config
-    ;; (guix config) module for consumption by (guix gcrypt).
-    (make-config.scm #:libgcrypt libgcrypt))
-
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -475,8 +465,8 @@ should set REGISTER-CLOSURES? to #f."
                       (name -> (string-append name ".tar.gz"))
                       (graph -> "system-graph"))
     (define build
-      (with-extensions (cons guile-json          ;for (guix docker)
-                             guile-sqlite3&co)   ;for (guix store database)
+      (with-extensions (cons guile-json           ;for (guix docker)
+                             gcrypt-sqlite3&co)   ;for (guix store database)
         (with-imported-modules `(,@(source-module-closure
                                     '((guix docker)
                                       (guix store database)
@@ -484,7 +474,7 @@ should set REGISTER-CLOSURES? to #f."
                                       (guix build store-copy)
                                       (gnu build vm))
                                     #:select? not-config?)
-                                 ((guix config) => ,config))
+                                 ((guix config) => ,(make-config.scm)))
           #~(begin
               (use-modules (guix docker)
                            (guix build utils)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index da686e89e..7afecb10c 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -35,7 +35,7 @@
   #:use-module (guix memoization)
   #:use-module (guix combinators)
   #:use-module (guix monads)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix records)
   #:use-module (guix sets)
diff --git a/guix/docker.scm b/guix/docker.scm
index b86990159..0757d3356 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -19,7 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix docker)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base16)
   #:use-module ((guix build utils)
                 #:select (mkdir-p
diff --git a/guix/gcrypt.scm b/guix/gcrypt.scm
deleted file mode 100644
index 151750175..000000000
--- a/guix/gcrypt.scm
+++ /dev/null
@@ -1,49 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix gcrypt)
-  #:use-module (guix config)
-  #:use-module (system foreign)
-  #:export (gcrypt-version
-            libgcrypt-func))
-
-;;; Commentary:
-;;;
-;;; Common code for the GNU Libgcrypt bindings.  Loading this module
-;;; initializes Libgcrypt as a side effect.
-;;;
-;;; Code:
-
-(define libgcrypt-func
-  (let ((lib (dynamic-link %libgcrypt)))
-    (lambda (func)
-      "Return a pointer to symbol FUNC in libgcrypt."
-      (dynamic-func func lib))))
-
-(define gcrypt-version
-  ;; According to the manual, this function must be called before any other,
-  ;; and it's not clear whether it can be called more than once.  So call it
-  ;; right here from the top level.
-  (let* ((ptr     (libgcrypt-func "gcry_check_version"))
-         (proc    (pointer->procedure '* ptr '(*)))
-         (version (pointer->string (proc %null-pointer))))
-    (lambda ()
-      "Return the version number of libgcrypt as a string."
-      version)))
-
-;;; gcrypt.scm ends here
diff --git a/guix/git.scm b/guix/git.scm
index 193e2df11..c577eba5e 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -21,7 +21,7 @@
   #:use-module (git)
   #:use-module (git object)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module (guix store)
   #:use-module (guix utils)
diff --git a/guix/hash.scm b/guix/hash.scm
deleted file mode 100644
index 8d7ba2142..000000000
--- a/guix/hash.scm
+++ /dev/null
@@ -1,184 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix hash)
-  #:use-module (guix gcrypt)
-  #:use-module (rnrs bytevectors)
-  #:use-module (ice-9 binary-ports)
-  #:use-module (system foreign)
-  #:use-module ((guix build utils) #:select (dump-port))
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
-  #:export (sha1
-            sha256
-            open-sha256-port
-            port-sha256
-            file-sha256
-            open-sha256-input-port))
-
-;;; Commentary:
-;;;
-;;; Cryptographic hashes.
-;;;
-;;; Code:
-
-\f
-;;;
-;;; Hash.
-;;;
-
-(define-syntax GCRY_MD_SHA256
-  ;; Value as of Libgcrypt 1.5.2.
-  (identifier-syntax 8))
-
-(define-syntax GCRY_MD_SHA1
-  (identifier-syntax 2))
-
-(define bytevector-hash
-  (let ((hash (pointer->procedure void
-                                  (libgcrypt-func "gcry_md_hash_buffer")
-                                  `(,int * * ,size_t))))
-    (lambda (bv type size)
-      "Return the hash TYPE, of SIZE bytes, of BV as a bytevector."
-      (let ((digest (make-bytevector size)))
-        (hash type (bytevector->pointer digest)
-              (bytevector->pointer bv) (bytevector-length bv))
-        digest))))
-
-(define sha1
-  (cut bytevector-hash <> GCRY_MD_SHA1 20))
-
-(define sha256
-  (cut bytevector-hash <> GCRY_MD_SHA256 (/ 256 8)))
-
-(define open-sha256-md
-  (let ((open (pointer->procedure int
-                                  (libgcrypt-func "gcry_md_open")
-                                  `(* ,int ,unsigned-int))))
-    (lambda ()
-      (let* ((md  (bytevector->pointer (make-bytevector (sizeof '*))))
-             (err (open md GCRY_MD_SHA256 0)))
-        (if (zero? err)
-            (dereference-pointer md)
-            (throw 'gcrypt-error err))))))
-
-(define md-write
-  (pointer->procedure void
-                      (libgcrypt-func "gcry_md_write")
-                      `(* * ,size_t)))
-
-(define md-read
-  (pointer->procedure '*
-                      (libgcrypt-func "gcry_md_read")
-                      `(* ,int)))
-
-(define md-close
-  (pointer->procedure void
-                      (libgcrypt-func "gcry_md_close")
-                      '(*)))
-
-
-(define (open-sha256-port)
-  "Return two values: an output port, and a thunk.  When the thunk is called,
-it returns the SHA256 hash (a bytevector) of all the data written to the
-output port."
-  (define sha256-md
-    (open-sha256-md))
-
-  (define digest #f)
-  (define position 0)
-
-  (define (finalize!)
-    (let ((ptr (md-read sha256-md 0)))
-      (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
-      (md-close sha256-md)))
-
-  (define (write! bv offset len)
-    (if (zero? len)
-        (begin
-          (finalize!)
-          0)
-        (let ((ptr (bytevector->pointer bv offset)))
-          (md-write sha256-md ptr len)
-          (set! position (+ position len))
-          len)))
-
-  (define (get-position)
-    position)
-
-  (define (close)
-    (unless digest
-      (finalize!)))
-
-  (values (make-custom-binary-output-port "sha256"
-                                          write! get-position #f
-                                          close)
-          (lambda ()
-            (unless digest
-              (finalize!))
-            digest)))
-
-(define (port-sha256 port)
-  "Return the SHA256 hash (a bytevector) of all the data drained from PORT."
-  (let-values (((out get)
-                (open-sha256-port)))
-    (dump-port port out)
-    (close-port out)
-    (get)))
-
-(define (file-sha256 file)
-  "Return the SHA256 hash (a bytevector) of FILE."
-  (call-with-input-file file port-sha256))
-
-(define (open-sha256-input-port port)
-  "Return an input port that wraps PORT and a thunk to get the hash of all the
-data read from PORT.  The thunk always returns the same value."
-  (define md
-    (open-sha256-md))
-
-  (define (read! bv start count)
-    (let ((n (get-bytevector-n! port bv start count)))
-      (if (eof-object? n)
-          0
-          (begin
-            (unless digest
-              (let ((ptr (bytevector->pointer bv start)))
-                (md-write md ptr n)))
-            n))))
-
-  (define digest #f)
-
-  (define (finalize!)
-    (let ((ptr (md-read md 0)))
-      (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
-      (md-close md)))
-
-  (define (get-hash)
-    (unless digest
-      (finalize!))
-    digest)
-
-  (define (unbuffered port)
-    ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
-    (setvbuf port _IONBF)
-    port)
-
-  (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f))
-          get-hash))
-
-;;; hash.scm ends here
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 3b34d4ffb..07360e610 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -34,7 +34,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix base64)
-  #:autoload   (guix hash) (sha256)
+  #:autoload   (gcrypt hash) (sha256)
   #:use-module ((guix build utils)
                 #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index d0ff64ed0..d4bea8435 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -27,7 +27,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (json)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix base32)
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index a5203fe78..89c84f703 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -29,7 +29,7 @@
   #:use-module (web uri)
   #:use-module (guix memoization)
   #:use-module (guix http-client)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module ((guix download) #:select (download-to-store))
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 3724a457a..e0b400d05 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -20,7 +20,7 @@
   #:use-module (guix base32)
   #:use-module (guix build-system cargo)
   #:use-module ((guix download) #:prefix download:)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix http-client)
   #:use-module (guix import json)
   #:use-module (guix import utils)
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index c37afaf8e..83354d3f0 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -32,7 +32,7 @@
   #:use-module (guix http-client)
   #:use-module (guix store)
   #:use-module (guix ui)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix upstream)
   #:use-module (guix packages)
diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm
index bbb17047f..29324d755 100644
--- a/guix/import/gnu.scm
+++ b/guix/import/gnu.scm
@@ -21,7 +21,7 @@
   #:use-module (guix import utils)
   #:use-module (guix utils)
   #:use-module (guix store)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix upstream)
   #:use-module (srfi srfi-1)
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 54301de2e..766a0b53f 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -33,7 +33,7 @@
   #:use-module ((guix import utils) #:select (factorize-uri recursive-import))
   #:use-module (guix import cabal)
   #:use-module (guix store)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix memoization)
   #:use-module (guix upstream)
diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index d4c371436..791b51448 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -26,7 +26,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (web uri)
   #:use-module (guix http-client)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix memoization)
   #:use-module (guix store)
   #:use-module (guix base32)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 0dc8fd585..516c0cfaa 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -23,7 +23,7 @@
 (define-module (guix import utils)
   #:use-module (guix base32)
   #:use-module ((guix build download) #:prefix build:)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix http-client)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix utils)
diff --git a/guix/nar.scm b/guix/nar.scm
index 3556de137..0495b4a40 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -25,9 +25,9 @@
   #:use-module (guix store)
   #:use-module (guix store database)
   #:use-module (guix ui)                          ; for '_'
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix pki)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm
deleted file mode 100644
index 55ba7b1bb..000000000
--- a/guix/pk-crypto.scm
+++ /dev/null
@@ -1,407 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix pk-crypto)
-  #:use-module (guix base16)
-  #:use-module (guix gcrypt)
-
-  #:use-module (system foreign)
-  #:use-module (rnrs bytevectors)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 rdelim)
-  #:export (canonical-sexp?
-            error-source
-            error-string
-            string->canonical-sexp
-            canonical-sexp->string
-            read-file-sexp
-            number->canonical-sexp
-            canonical-sexp-car
-            canonical-sexp-cdr
-            canonical-sexp-nth
-            canonical-sexp-nth-data
-            canonical-sexp-length
-            canonical-sexp-null?
-            canonical-sexp-list?
-            bytevector->hash-data
-            hash-data->bytevector
-            key-type
-            sign
-            verify
-            generate-key
-            find-sexp-token
-            canonical-sexp->sexp
-            sexp->canonical-sexp)
-  #:re-export (gcrypt-version))
-
-\f
-;;; Commentary:
-;;;
-;;; Public key cryptographic routines from GNU Libgcrypt.
-;;;;
-;;; Libgcrypt uses "canonical s-expressions" to represent key material,
-;;; parameters, and data.  We keep it as an opaque object to map them to
-;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
-;;; memory, and (2) the read syntax is different.
-;;;
-;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
-;;; cases where it is safe to move data out of Libgcrypt---e.g., when
-;;; processing ACL entries, public keys, etc.
-;;;
-;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
-;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
-;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
-;;;
-;;; Code:
-
-;; Libgcrypt "s-expressions".
-(define-wrapped-pointer-type <canonical-sexp>
-  canonical-sexp?
-  naked-pointer->canonical-sexp
-  canonical-sexp->pointer
-  (lambda (obj port)
-    ;; Don't print OBJ's external representation: we don't want key material
-    ;; to leak in backtraces and such.
-    (format port "#<canonical-sexp ~a | ~a>"
-            (number->string (object-address obj) 16)
-            (number->string (pointer-address (canonical-sexp->pointer obj))
-                            16))))
-
-(define finalize-canonical-sexp!
-  (libgcrypt-func "gcry_sexp_release"))
-
-(define-inlinable (pointer->canonical-sexp ptr)
-  "Return a <canonical-sexp> that wraps PTR."
-  (let* ((sexp (naked-pointer->canonical-sexp ptr))
-         (ptr* (canonical-sexp->pointer sexp)))
-    ;; Did we already have a <canonical-sexp> object for PTR?
-    (when (equal? ptr ptr*)
-      ;; No, so we can safely add a finalizer (in Guile 2.0.9
-      ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
-      ;; existing one.)
-      (set-pointer-finalizer! ptr finalize-canonical-sexp!))
-    sexp))
-
-(define error-source
-  (let* ((ptr  (libgcrypt-func "gcry_strsource"))
-         (proc (pointer->procedure '* ptr (list int))))
-    (lambda (err)
-      "Return the error source (a string) for ERR, an error code as thrown
-along with 'gcry-error'."
-      (pointer->string (proc err)))))
-
-(define error-string
-  (let* ((ptr  (libgcrypt-func "gcry_strerror"))
-         (proc (pointer->procedure '* ptr (list int))))
-    (lambda (err)
-      "Return the error description (a string) for ERR, an error code as
-thrown along with 'gcry-error'."
-      (pointer->string (proc err)))))
-
-(define string->canonical-sexp
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_new"))
-         (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
-    (lambda (str)
-      "Parse STR and return the corresponding gcrypt s-expression."
-
-      ;; When STR comes from 'canonical-sexp->string', it may contain
-      ;; characters that are really meant to be interpreted as bytes as in a C
-      ;; 'char *'.  Thus, convert STR to ISO-8859-1 so the byte values of the
-      ;; characters are preserved.
-      (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
-             (err  (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
-        (if (= 0 err)
-            (pointer->canonical-sexp (dereference-pointer sexp))
-            (throw 'gcry-error 'string->canonical-sexp err))))))
-
-(define-syntax GCRYSEXP_FMT_ADVANCED
-  (identifier-syntax 3))
-
-(define canonical-sexp->string
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_sprint"))
-         (proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
-    (lambda (sexp)
-      "Return a textual representation of SEXP."
-      (let loop ((len 1024))
-        (let* ((buf  (bytevector->pointer (make-bytevector len)))
-               (size (proc (canonical-sexp->pointer sexp)
-                           GCRYSEXP_FMT_ADVANCED buf len)))
-          (if (zero? size)
-              (loop (* len 2))
-              (pointer->string buf size "ISO-8859-1")))))))
-
-(define (read-file-sexp file)
-  "Return the canonical sexp read from FILE."
-  (call-with-input-file file
-    (compose string->canonical-sexp
-             read-string)))
-
-(define canonical-sexp-car
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_car"))
-         (proc (pointer->procedure '* ptr '(*))))
-    (lambda (lst)
-      "Return the first element of LST, an sexp, if that element is a list;
-return #f if LST or its first element is not a list (this is different from
-the usual Lisp 'car'.)"
-      (let ((result (proc (canonical-sexp->pointer lst))))
-        (if (null-pointer? result)
-            #f
-            (pointer->canonical-sexp result))))))
-
-(define canonical-sexp-cdr
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_cdr"))
-         (proc (pointer->procedure '* ptr '(*))))
-    (lambda (lst)
-      "Return the tail of LST, an sexp, or #f if LST is not a list."
-      (let ((result (proc (canonical-sexp->pointer lst))))
-        (if (null-pointer? result)
-            #f
-            (pointer->canonical-sexp result))))))
-
-(define canonical-sexp-nth
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_nth"))
-         (proc (pointer->procedure '* ptr `(* ,int))))
-    (lambda (lst index)
-      "Return the INDEXth nested element of LST, an s-expression.  Return #f
-if that element does not exist, or if it's an atom.  (Note: this is obviously
-different from Scheme's 'list-ref'.)"
-      (let ((result (proc (canonical-sexp->pointer lst) index)))
-        (if (null-pointer? result)
-            #f
-            (pointer->canonical-sexp result))))))
-
-(define (dereference-size_t p)
-  "Return the size_t value pointed to by P."
-  (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
-                       0 (native-endianness)
-                       (sizeof size_t)))
-
-(define canonical-sexp-length
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_length"))
-         (proc (pointer->procedure int ptr '(*))))
-    (lambda (sexp)
-      "Return the length of SEXP if it's a list (including the empty list);
-return zero if SEXP is an atom."
-      (proc (canonical-sexp->pointer sexp)))))
-
-(define token-string?
-  (let ((token-cs (char-set-union char-set:digit
-                                  char-set:letter
-                                  (char-set #\- #\. #\/ #\_
-                                            #\: #\* #\+ #\=))))
-    (lambda (str)
-      "Return #t if STR is a token as per Section 4.3 of
-<http://people.csail.mit.edu/rivest/Sexp.txt>."
-      (and (not (string-null? str))
-           (string-every token-cs str)
-           (not (char-set-contains? char-set:digit (string-ref str 0)))))))
-
-(define canonical-sexp-nth-data
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_nth_data"))
-         (proc (pointer->procedure '* ptr `(* ,int *))))
-    (lambda (lst index)
-      "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
-\"octet string\") the INDEXth data element (atom) of LST, an s-expression.
-Return #f if that element does not exist, or if it's a list."
-      (let* ((size*  (bytevector->pointer (make-bytevector (sizeof '*))))
-             (result (proc (canonical-sexp->pointer lst) index size*)))
-        (if (null-pointer? result)
-            #f
-            (let* ((len (dereference-size_t size*))
-                   (str (pointer->string result len "ISO-8859-1")))
-              ;; The sexp spec speaks of "tokens" and "octet strings".
-              ;; Sometimes these octet strings are actual strings (text),
-              ;; sometimes they're bytevectors, and sometimes they're
-              ;; multi-precision integers (MPIs).  Only the application knows.
-              ;; However, for convenience, we return a symbol when a token is
-              ;; encountered since tokens are frequent (at least in the 'car'
-              ;; of each sexp.)
-              (if (token-string? str)
-                  (string->symbol str)   ; an sexp "token"
-                  (bytevector-copy       ; application data, textual or binary
-                   (pointer->bytevector result len)))))))))
-
-(define (number->canonical-sexp number)
-  "Return an s-expression representing NUMBER."
-  (string->canonical-sexp (string-append "#" (number->string number 16) "#")))
-
-(define* (bytevector->hash-data bv
-                                #:optional
-                                (hash-algo "sha256")
-                                #:key (key-type 'ecc))
-  "Given BV, a bytevector containing a hash of type HASH-ALGO, return an
-s-expression suitable for use as the 'data' argument for 'sign'.  KEY-TYPE
-must be a symbol: 'dsa, 'ecc, or 'rsa."
-  (string->canonical-sexp
-   (format #f "(data (flags ~a) (hash \"~a\" #~a#))"
-           (case key-type
-             ((ecc dsa) "rfc6979")
-             ((rsa)     "pkcs1")
-             (else (error "unknown key type" key-type)))
-           hash-algo
-           (bytevector->base16-string bv))))
-
-(define (key-type sexp)
-  "Return a symbol denoting the type of public or private key represented by
-SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key."
-  (case (canonical-sexp-nth-data sexp 0)
-    ((public-key private-key)
-     (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
-    (else #f)))
-
-(define* (hash-data->bytevector data)
-  "Return two values: the hash value (a bytevector), and the hash algorithm (a
-string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
-Return #f if DATA does not conform."
-  (let ((hash (find-sexp-token data 'hash)))
-    (if hash
-        (let ((algo  (canonical-sexp-nth-data hash 1))
-              (value (canonical-sexp-nth-data hash 2)))
-          (values value (symbol->string algo)))
-        (values #f #f))))
-
-(define sign
-  (let* ((ptr  (libgcrypt-func "gcry_pk_sign"))
-         (proc (pointer->procedure int ptr '(* * *))))
-    (lambda (data secret-key)
-      "Sign DATA, a canonical s-expression representing a suitable hash, with
-SECRET-KEY (a canonical s-expression whose car is 'private-key'.)  Note that
-DATA must be a 'data' s-expression, as returned by
-'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")."
-      (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
-             (err (proc sig (canonical-sexp->pointer data)
-                        (canonical-sexp->pointer secret-key))))
-        (if (= 0 err)
-            (pointer->canonical-sexp (dereference-pointer sig))
-            (throw 'gcry-error 'sign err))))))
-
-(define verify
-  (let* ((ptr  (libgcrypt-func "gcry_pk_verify"))
-         (proc (pointer->procedure int ptr '(* * *))))
-    (lambda (signature data public-key)
-      "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
-which are gcrypt s-expressions."
-      (zero? (proc (canonical-sexp->pointer signature)
-                   (canonical-sexp->pointer data)
-                   (canonical-sexp->pointer public-key))))))
-
-(define generate-key
-  (let* ((ptr  (libgcrypt-func "gcry_pk_genkey"))
-         (proc (pointer->procedure int ptr '(* *))))
-    (lambda (params)
-      "Return as an s-expression a new key pair for PARAMS.  PARAMS must be an
-s-expression like: (genkey (rsa (nbits 4:2048)))."
-      (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
-             (err (proc key (canonical-sexp->pointer params))))
-        (if (zero? err)
-            (pointer->canonical-sexp (dereference-pointer key))
-            (throw 'gcry-error 'generate-key err))))))
-
-(define find-sexp-token
-  (let* ((ptr  (libgcrypt-func "gcry_sexp_find_token"))
-         (proc (pointer->procedure '* ptr `(* * ,size_t))))
-    (lambda (sexp token)
-      "Find in SEXP the first element whose 'car' is TOKEN and return it;
-return #f if not found."
-      (let* ((token (string->pointer (symbol->string token)))
-             (res   (proc (canonical-sexp->pointer sexp) token 0)))
-        (if (null-pointer? res)
-            #f
-            (pointer->canonical-sexp res))))))
-
-(define-inlinable (canonical-sexp-null? sexp)
-  "Return #t if SEXP is the empty-list sexp."
-  (null-pointer? (canonical-sexp->pointer sexp)))
-
-(define (canonical-sexp-list? sexp)
-  "Return #t if SEXP is a list."
-  (or (canonical-sexp-null? sexp)
-      (> (canonical-sexp-length sexp) 0)))
-
-(define (canonical-sexp-fold proc seed sexp)
-  "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
-  (if (canonical-sexp-list? sexp)
-      (let ((len (canonical-sexp-length sexp)))
-        (let loop ((index  0)
-                   (result seed))
-          (if (= index len)
-              result
-              (loop (+ 1 index)
-                    ;; XXX: Call 'nth-data' *before* 'nth' to work around
-                    ;; <https://bugs.g10code.com/gnupg/issue1594>, which
-                    ;; affects 1.6.0 and earlier versions.
-                    (proc (or (canonical-sexp-nth-data sexp index)
-                              (canonical-sexp-nth sexp index))
-                          result)))))
-      (error "sexp is not a list" sexp)))
-
-(define (canonical-sexp->sexp sexp)
-  "Return a Scheme sexp corresponding to SEXP.  This is particularly useful to
-compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
-use pattern matching."
-  (if (canonical-sexp-list? sexp)
-      (reverse
-       (canonical-sexp-fold (lambda (item result)
-                              (cons (if (canonical-sexp? item)
-                                        (canonical-sexp->sexp item)
-                                        item)
-                                    result))
-                            '()
-                            sexp))
-
-      ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
-      ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
-      (let ((sexp (string->canonical-sexp
-                   (string-append "(" (canonical-sexp->string sexp)
-                                  ")"))))
-        (or (canonical-sexp-nth-data sexp 0)
-            (canonical-sexp-nth sexp 0)))))
-
-(define (sexp->canonical-sexp sexp)
-  "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
-'canonical-sexp->sexp'."
-  ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
-  ;; much better.
-  (string->canonical-sexp
-    (call-with-output-string
-     (lambda (port)
-       (define (write item)
-         (cond ((list? item)
-                (display "(" port)
-                (for-each write item)
-                (display ")" port))
-               ((symbol? item)
-                (format port " ~a" item))
-               ((bytevector? item)
-                (format port " #~a#"
-                        (bytevector->base16-string item)))
-               (else
-                (error "unsupported sexp item type" item))))
-
-       (write sexp)))))
-
-(define (gcrypt-error-printer port key args default-printer)
-  "Print the gcrypt error specified by ARGS."
-  (match args
-    ((proc err)
-     (format port "In procedure ~a: ~a: ~a"
-             proc (error-source err) (error-string err)))))
-
-(set-exception-printer! 'gcry-error gcrypt-error-printer)
-
-;;; pk-crypto.scm ends here
diff --git a/guix/pki.scm b/guix/pki.scm
index 1551425c3..6326e065e 100644
--- a/guix/pki.scm
+++ b/guix/pki.scm
@@ -18,7 +18,7 @@
 
 (define-module (guix pki)
   #:use-module (guix config)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module ((guix utils) #:select (with-atomic-file-output))
   #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module (ice-9 match)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index a359f405f..fb2f61ce3 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -29,7 +29,7 @@
   #:use-module (guix monads)
   #:use-module (guix ui)
   #:use-module (guix pki)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index 8b19dc871..f1fd8ee89 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -19,7 +19,7 @@
 (define-module (guix scripts authenticate)
   #:use-module (guix config)
   #:use-module (guix base16)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (guix pki)
   #:use-module (guix ui)
   #:use-module (ice-9 binary-ports)
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 1b99bc62c..b9162d344 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -20,7 +20,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix store)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base16)
   #:use-module (guix base32)
   #:use-module ((guix download) #:hide (url-fetch))
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index cae5d6bcd..2bd2ac4a0 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -20,7 +20,7 @@
 
 (define-module (guix scripts hash)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix serialization)
   #:use-module (guix ui)
   #:use-module (guix scripts)
@@ -44,7 +44,7 @@
   `((format . ,bytevector->nix-base32-string)))
 
 (define (show-help)
-  (display (G_ "Usage: guix hash [OPTION] FILE
+  (display (G_ "Usage: gcrypt hash [OPTION] FILE
 Return the cryptographic hash of FILE.
 
 Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex'
@@ -93,7 +93,7 @@ and 'hexadecimal' can be used as well).\n"))
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
-                  (show-version-and-exit "guix hash")))))
+                  (show-version-and-exit "gcrypt hash")))))
 
 
 \f
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index fb0677de2..1916f3b9d 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -41,7 +41,7 @@
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
   #:autoload   (gnu packages package-management) (guix)
-  #:autoload   (gnu packages gnupg) (libgcrypt)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -95,10 +95,12 @@ found."
     (('gnu _ ...) #t)
     (_ #f)))
 
-(define guile-sqlite3&co
-  ;; Guile-SQLite3 and its propagated inputs.
-  (cons guile-sqlite3
-        (package-transitive-propagated-inputs guile-sqlite3)))
+(define gcrypt-sqlite3&co
+  ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+  (append-map (lambda (package)
+                (cons package
+                      (package-transitive-propagated-inputs package)))
+              (list guile-gcrypt guile-sqlite3)))
 
 (define* (self-contained-tarball name profile
                                  #:key target
@@ -124,16 +126,14 @@ added to the pack."
                                   "guix/store/schema.sql"))))
 
   (define build
-    (with-imported-modules `(((guix config)
-                              => ,(make-config.scm
-                                   #:libgcrypt libgcrypt))
+    (with-imported-modules `(((guix config) => ,(make-config.scm))
                              ,@(source-module-closure
                                 `((guix build utils)
                                   (guix build union)
                                   (guix build store-copy)
                                   (gnu build install))
                                 #:select? not-config?))
-      (with-extensions guile-sqlite3&co
+      (with-extensions gcrypt-sqlite3&co
         #~(begin
             (use-modules (guix build utils)
                          ((guix build union) #:select (relative-file-name))
@@ -251,22 +251,14 @@ points for virtual file systems (like procfs), and optional symlinks.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
-  (define libgcrypt
-    ;; XXX: Not strictly needed, but pulled by (guix store database).
-    (module-ref (resolve-interface '(gnu packages gnupg))
-                'libgcrypt))
-
-
   (define build
-    (with-imported-modules `(((guix config)
-                              => ,(make-config.scm
-                                   #:libgcrypt libgcrypt))
+    (with-imported-modules `(((guix config) => ,(make-config.scm))
                              ,@(source-module-closure
                                 '((guix build utils)
                                   (guix build store-copy)
                                   (gnu build install))
                                 #:select? not-config?))
-      (with-extensions guile-sqlite3&co
+      (with-extensions gcrypt-sqlite3&co
         #~(begin
             (use-modules (guix build utils)
                          (gnu build install)
@@ -349,32 +341,12 @@ must a be a GNU triplet and it is used to derive the architecture metadata in
 the image."
   (define defmod 'define-module)                  ;trick Geiser
 
-  (define config
-    ;; (guix config) module for consumption by (guix gcrypt).
-    (scheme-file "gcrypt-config.scm"
-                 #~(begin
-                     (#$defmod (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 json
-    ;; Pick the guile-json package that corresponds to the Guile used to build
-    ;; derivations.
-    (if (string-prefix? "2.0" (package-version (default-guile)))
-        guile2.0-json
-        guile-json))
-
   (define build
-    ;; Guile-JSON is required by (guix docker).
-    (with-extensions (list json)
-      (with-imported-modules `(,@(source-module-closure '((guix docker)
-                                                          (guix build store-copy))
-                                                        #:select? not-config?)
-                               ((guix config) => ,config))
+    ;; 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?)
         #~(begin
             (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index b5dfdab32..c5326b33d 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -44,9 +44,9 @@
   #:use-module (guix base64)
   #:use-module (guix config)
   #:use-module (guix derivations)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix pki)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (guix workers)
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index a8fe993e3..bcc23bd39 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -23,7 +23,7 @@
 
 (define-module (guix scripts refresh)
   #:use-module (guix ui)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (guix utils)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 7634bb37f..cd300195d 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -26,11 +26,11 @@
   #:use-module (guix config)
   #:use-module (guix records)
   #:use-module ((guix serialization) #:select (restore-file))
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix base64)
   #:use-module (guix cache)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (guix pki)
   #:use-module ((guix build utils) #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
diff --git a/guix/self.scm b/guix/self.scm
index 90649db17..f270a065b 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -83,8 +83,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
       ("guile-ssh"  (ref '(gnu packages ssh)   'guile-ssh))
       ("guile-git"  (ref '(gnu packages guile) 'guile-git))
       ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
+      ("guile-gcrypt"  (ref '(gnu packages gnupg) 'guile-gcrypt))
       ("gnutls"     (ref '(gnu packages tls) 'gnutls))
-      ("libgcrypt"  (ref '(gnu packages gnupg) 'libgcrypt))
       ("zlib"       (ref '(gnu packages compression) 'zlib))
       ("gzip"       (ref '(gnu packages compression) 'gzip))
       ("bzip2"      (ref '(gnu packages compression) 'bzip2))
@@ -461,7 +461,6 @@ assumed to be part of MODULES."
                         (name (string-append "guix-" version))
                         (guile-version (effective-version))
                         (guile-for-build (guile-for-build guile-version))
-                        (libgcrypt (specification->package "libgcrypt"))
                         (zlib (specification->package "zlib"))
                         (gzip (specification->package "gzip"))
                         (bzip2 (specification->package "bzip2"))
@@ -488,6 +487,10 @@ assumed to be part of MODULES."
                        "guile-sqlite3"
                        "guile2.0-sqlite3"))
 
+  (define guile-gcrypt
+    (package-for-guile guile-version
+                       "guile-gcrypt"))
+
   (define gnutls
     (package-for-guile guile-version
                        "gnutls" "guile2.0-gnutls"))
@@ -496,7 +499,7 @@ assumed to be part of MODULES."
     (match (append-map (lambda (package)
                          (cons (list "x" package)
                                (package-transitive-propagated-inputs package)))
-                       (list gnutls guile-git guile-json
+                       (list guile-gcrypt gnutls guile-git guile-json
                              guile-ssh guile-sqlite3))
       (((labels packages _ ...) ...)
        packages)))
@@ -520,10 +523,7 @@ assumed to be part of MODULES."
                  ;; rebuilt when the version changes, which in turn means we
                  ;; can have substitutes for it.
                  #:extra-modules
-                 `(((guix config)
-                    => ,(make-config.scm #:libgcrypt
-                                         (specification->package
-                                          "libgcrypt"))))
+                 `(((guix config) => ,(make-config.scm)))
 
                  ;; (guix man-db) is needed at build-time by (guix profiles)
                  ;; but we don't need to compile it; not compiling it allows
@@ -533,6 +533,7 @@ assumed to be part of MODULES."
                    ("guix/store/schema.sql"
                     ,(local-file "../guix/store/schema.sql")))
 
+                 #:extensions (list guile-gcrypt)
                  #:guile-for-build guile-for-build))
 
   (define *extra-modules*
@@ -607,8 +608,7 @@ assumed to be part of MODULES."
                  '()
                  #:extra-modules
                  `(((guix config)
-                    => ,(make-config.scm #:libgcrypt libgcrypt
-                                         #:zlib zlib
+                    => ,(make-config.scm #:zlib zlib
                                          #:gzip gzip
                                          #:bzip2 bzip2
                                          #:xz xz
@@ -691,7 +691,7 @@ assumed to be part of MODULES."
 
 (define %dependency-variables
   ;; (guix config) variables corresponding to dependencies.
-  '(%libgcrypt %libz %xz %gzip %bzip2))
+  '(%libz %xz %gzip %bzip2))
 
 (define %persona-variables
   ;; (guix config) variables that define Guix's persona.
@@ -710,7 +710,7 @@ assumed to be part of MODULES."
                                       (variables rest ...))))))
     (variables %localstatedir %storedir %sysconfdir %system)))
 
-(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
+(define* (make-config.scm #:key zlib gzip xz bzip2
                           (package-name "GNU Guix")
                           (package-version "0")
                           (bug-report-address "bug-guix@gnu.org")
@@ -730,7 +730,6 @@ assumed to be part of MODULES."
                                %state-directory
                                %store-database-directory
                                %config-directory
-                               %libgcrypt
                                %libz
                                %gzip
                                %bzip2
@@ -773,9 +772,6 @@ assumed to be part of MODULES."
                    (define %xz
                      #+(and xz (file-append xz "/bin/xz")))
 
-                   (define %libgcrypt
-                     #+(and libgcrypt
-                            (file-append libgcrypt "/lib/libgcrypt")))
                    (define %libz
                      #+(and zlib
                             (file-append zlib "/lib/libz"))))
diff --git a/guix/store.scm b/guix/store.scm
index f41a1e269..af7f6980c 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -25,7 +25,7 @@
   #:use-module (guix monads)
   #:use-module (guix base16)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix profiling)
   #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module (rnrs bytevectors)
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 8c19d7309..53810c680 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -21,7 +21,7 @@
 ;;; timestamps, deduplicating, etc.
 
 (define-module (guix store deduplication)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix build utils)
   #:use-module (guix base16)
   #:use-module (srfi srfi-11)
diff --git a/guix/tests.scm b/guix/tests.scm
index 34e3e0fc2..06e9f8da0 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -22,7 +22,7 @@
   #:use-module (guix packages)
   #:use-module (guix base32)
   #:use-module (guix serialization)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
diff --git a/m4/guix.m4 b/m4/guix.m4
index a6897be96..da3c65f8f 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -18,24 +18,6 @@ dnl
 dnl You should have received a copy of the GNU General Public License
 dnl along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-dnl GUIX_ASSERT_LIBGCRYPT_USABLE
-dnl
-dnl Assert that GNU libgcrypt is usable from Guile.
-AC_DEFUN([GUIX_ASSERT_LIBGCRYPT_USABLE],
-  [AC_CACHE_CHECK([whether $LIBGCRYPT can be dynamically loaded],
-    [guix_cv_libgcrypt_usable_p],
-    [GUILE_CHECK([retval],
-      [(dynamic-func \"gcry_md_hash_buffer\" (dynamic-link \"$LIBGCRYPT\"))])
-     if test "$retval" = 0; then
-       guix_cv_libgcrypt_usable_p="yes"
-     else
-       guix_cv_libgcrypt_usable_p="no"
-     fi])
-
-   if test "x$guix_cv_libgcrypt_usable_p" != "xyes"; then
-     AC_MSG_ERROR([GNU libgcrypt does not appear to be usable; see `--with-libgcrypt-prefix' and `README'.])
-   fi])
-
 dnl GUIX_SYSTEM_TYPE
 dnl
 dnl Determine the Guix host system type, and store it in the
diff --git a/tests/base32.scm b/tests/base32.scm
index 194f8da96..134e57863 100644
--- a/tests/base32.scm
+++ b/tests/base32.scm
@@ -17,7 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
diff --git a/tests/builders.scm b/tests/builders.scm
index bb9e0fa85..8b8ef013e 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
@@ -25,7 +25,7 @@
   #:use-module (guix utils)
   #:use-module (guix base32)
   #:use-module (guix derivations)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module ((guix packages)
                 #:select (package-derivation package-native-search-paths))
diff --git a/tests/challenge.scm b/tests/challenge.scm
index 387d205a6..4b13ec278 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -18,7 +18,7 @@
 
 (define-module (test-challenge)
   #:use-module (guix tests)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix derivations)
diff --git a/tests/cpan.scm b/tests/cpan.scm
index 396744e52..189dd027e 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -20,7 +20,7 @@
 (define-module (test-cpan)
   #:use-module (guix import cpan)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module (guix grafts)
   #:use-module (srfi srfi-64)
diff --git a/tests/crate.scm b/tests/crate.scm
index eb93822bb..a1dcfd5e5 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -21,7 +21,7 @@
   #:use-module (guix import crate)
   #:use-module (guix base32)
   #:use-module (guix build-system cargo)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 match)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 5d8352918..159a6971b 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -23,7 +23,7 @@
   #:use-module (guix grafts)
   #:use-module (guix store)
   #:use-module (guix utils)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix tests)
   #:use-module (guix tests http)
diff --git a/tests/gem.scm b/tests/gem.scm
index 4220170ff..a12edb294 100644
--- a/tests/gem.scm
+++ b/tests/gem.scm
@@ -21,7 +21,7 @@
 (define-module (test-gem)
   #:use-module (guix import gem)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module ((guix build utils) #:select (delete-file-recursively))
   #:use-module (srfi srfi-41)
diff --git a/tests/hash.scm b/tests/hash.scm
deleted file mode 100644
index 47dff3915..000000000
--- a/tests/hash.scm
+++ /dev/null
@@ -1,128 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (test-hash)
-  #:use-module (guix hash)
-  #:use-module (guix base16)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-64)
-  #:use-module (rnrs bytevectors)
-  #:use-module (rnrs io ports))
-
-;; Test the (guix hash) module.
-
-(define %empty-sha256
-  ;; SHA256 hash of the empty string.
-  (base16-string->bytevector
-   "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"))
-
-(define %hello-sha256
-  ;; SHA256 hash of "hello world"
-  (base16-string->bytevector
-   "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9"))
-
-\f
-(test-begin "hash")
-
-(test-equal "sha1, empty"
-  (base16-string->bytevector "da39a3ee5e6b4b0d3255bfef95601890afd80709")
-  (sha1 #vu8()))
-
-(test-equal "sha1, hello"
-  (base16-string->bytevector "2aae6c35c94fcfb415dbe95f408b9ce91ee846ed")
-  (sha1 (string->utf8 "hello world")))
-
-(test-equal "sha256, empty"
-  %empty-sha256
-  (sha256 #vu8()))
-
-(test-equal "sha256, hello"
-  %hello-sha256
-  (sha256 (string->utf8 "hello world")))
-
-(test-equal "open-sha256-port, empty"
-  %empty-sha256
-  (let-values (((port get)
-                (open-sha256-port)))
-    (close-port port)
-    (get)))
-
-(test-equal "open-sha256-port, hello"
-  (list %hello-sha256 (string-length "hello world"))
-  (let-values (((port get)
-                (open-sha256-port)))
-    (put-bytevector port (string->utf8 "hello world"))
-    (force-output port)
-    (list (get) (port-position port))))
-
-(test-assert "port-sha256"
-  (let* ((file     (search-path %load-path "ice-9/psyntax.scm"))
-         (size     (stat:size (stat file)))
-         (contents (call-with-input-file file get-bytevector-all)))
-    (equal? (sha256 contents)
-            (call-with-input-file file port-sha256))))
-
-(test-equal "open-sha256-input-port, empty"
-  `("" ,%empty-sha256)
-  (let-values (((port get)
-                (open-sha256-input-port (open-string-input-port ""))))
-    (let ((str (get-string-all port)))
-      (list str (get)))))
-
-(test-equal "open-sha256-input-port, hello"
-  `("hello world" ,%hello-sha256)
-  (let-values (((port get)
-                (open-sha256-input-port
-                 (open-bytevector-input-port
-                  (string->utf8 "hello world")))))
-    (let ((str (get-string-all port)))
-      (list str (get)))))
-
-(test-equal "open-sha256-input-port, hello, one two"
-  (list (string->utf8 "hel") (string->utf8 "lo")
-        (base16-string->bytevector                ; echo -n hello | sha256sum
-         "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
-        " world")
-  (let-values (((port get)
-                (open-sha256-input-port
-                 (open-bytevector-input-port (string->utf8 "hello world")))))
-    (let* ((one   (get-bytevector-n port 3))
-           (two   (get-bytevector-n port 2))
-           (hash  (get))
-           (three (get-string-all port)))
-      (list one two hash three))))
-
-(test-equal "open-sha256-input-port, hello, read from wrapped port"
-  (list (string->utf8 "hello")
-        (base16-string->bytevector                ; echo -n hello | sha256sum
-         "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
-        " world")
-  (let*-values (((wrapped)
-                 (open-bytevector-input-port (string->utf8 "hello world")))
-                ((port get)
-                 (open-sha256-input-port wrapped)))
-    (let* ((hello (get-bytevector-n port 5))
-           (hash  (get))
-
-           ;; Now read from WRAPPED to make sure its current position is
-           ;; correct.
-           (world (get-string-all wrapped)))
-      (list hello hash world))))
-
-(test-end)
diff --git a/tests/nar.scm b/tests/nar.scm
index 9b5fb984b..d610ea53f 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -21,7 +21,7 @@
   #:use-module (guix nar)
   #:use-module (guix serialization)
   #:use-module (guix store)
-  #:use-module ((guix hash)
+  #:use-module ((gcrypt hash)
                 #:select (open-sha256-port open-sha256-input-port))
   #:use-module ((guix packages)
                 #:select (base32))
diff --git a/tests/opam.scm b/tests/opam.scm
index 26832174a..a1320abfd 100644
--- a/tests/opam.scm
+++ b/tests/opam.scm
@@ -19,7 +19,7 @@
 (define-module (test-opam)
   #:use-module (guix import opam)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
   #:use-module (srfi srfi-64)
diff --git a/tests/packages.scm b/tests/packages.scm
index 65ccb1488..237feb7ab 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -28,7 +28,7 @@
                 #:renamer (lambda (name)
                             (cond ((eq? name 'location) 'make-location)
                                   (else name))))
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix grafts)
diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm
deleted file mode 100644
index fe33a6f7b..000000000
--- a/tests/pk-crypto.scm
+++ /dev/null
@@ -1,290 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (test-pk-crypto)
-  #:use-module (guix pk-crypto)
-  #:use-module (guix utils)
-  #:use-module (guix base16)
-  #:use-module (guix hash)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-64)
-  #:use-module (rnrs bytevectors)
-  #:use-module (rnrs io ports)
-  #:use-module (ice-9 match))
-
-;; Test the (guix pk-crypto) module.
-
-(define %key-pair
-  ;; RSA key pair that was generated with:
-  ;;   (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))"))
-  ;; which takes a bit of time.
-  "(key-data
-    (public-key
-     (rsa
-      (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
-      (e #010001#)))
-    (private-key
-     (rsa
-      (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#)
-      (e #010001#)
-      (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#)
-      (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#)
-      (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#)
-      (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))))")
-
-(define %ecc-key-pair
-  ;; Ed25519 key pair generated with:
-  ;;   (generate-key (string->canonical-sexp "(genkey (ecdsa (curve Ed25519) (flags rfc6979 transient)))"))
-  "(key-data
-      (public-key
-        (ecc
-          (curve Ed25519)
-          (q #94869C1B9E69DB8DD910B7F7F4D6E56A63A964A59AE8F90F6703ACDDF6F50C81#)))
-      (private-key
-        (ecc
-          (curve Ed25519)
-          (q #94869C1B9E69DB8DD910B7F7F4D6E56A63A964A59AE8F90F6703ACDDF6F50C81#)
-          (d #6EFB32D0B4EC6B3237B523539F1979379B82726AAA605EB2FBA6775B2B777B78#))))")
-
-(test-begin "pk-crypto")
-
-(test-assert "version"
-  (gcrypt-version))
-
-(let ((sexps '("(foo bar)"
-
-               ;; In Libgcrypt 1.5.3 the following integer is rendered as
-               ;; binary, whereas in 1.6.0 it's rendered as is (hexadecimal.)
-               ;;"#C0FFEE#"
-
-               "(genkey \n (rsa \n  (nbits \"1024\")\n  )\n )")))
-  (test-equal "string->canonical-sexp->string"
-    sexps
-    (let ((sexps (map string->canonical-sexp sexps)))
-      (and (every canonical-sexp? sexps)
-           (map (compose string-trim-both canonical-sexp->string) sexps)))))
-
-(gc)                                              ; stress test!
-
-(let ((sexps `(("(foo bar)" foo -> "(foo bar)")
-               ("(foo (bar (baz 3:123)))" baz -> "(baz \"123\")")
-               ("(foo (bar 3:123))" baz -> #f))))
-  (test-equal "find-sexp-token"
-    (map (match-lambda
-          ((_ _ '-> expected)
-           expected))
-         sexps)
-    (map (match-lambda
-          ((input token '-> _)
-           (let ((sexp (find-sexp-token (string->canonical-sexp input) token)))
-             (and sexp
-                  (string-trim-both (canonical-sexp->string sexp))))))
-         sexps)))
-
-(gc)
-
-(test-equal "canonical-sexp-length"
-  '(0 1 2 4 0 0)
-  (map (compose canonical-sexp-length string->canonical-sexp)
-       '("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#")))
-
-(test-equal "canonical-sexp-list?"
-  '(#t #f #t #f)
-  (map (compose canonical-sexp-list? string->canonical-sexp)
-       '("()" "\"abc\"" "(a b c)" "#123456#")))
-
-(gc)
-
-(test-equal "canonical-sexp-car + cdr"
-  '("(b \n (c xyz)\n )")
-  (let ((lst (string->canonical-sexp "(a (b (c xyz)))")))
-    (map (lambda (sexp)
-           (and sexp (string-trim-both (canonical-sexp->string sexp))))
-         ;; Note: 'car' returns #f when the first element is an atom.
-         (list (canonical-sexp-car (canonical-sexp-cdr lst))))))
-
-(gc)
-
-(test-equal "canonical-sexp-nth"
-  '("(b pqr)" "(c \"456\")" "(d xyz)" #f #f)
-
-  (let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))")))
-    ;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in
-    ;; 1.6.0 it returns #f.
-    (map (lambda (sexp)
-           (and sexp (string-trim-both (canonical-sexp->string sexp))))
-         (unfold (cut > <> 5)
-                 (cut canonical-sexp-nth lst <>)
-                 1+
-                 1))))
-
-(gc)
-
-(test-equal "canonical-sexp-nth-data"
-  `(Name Otto Meier #f ,(base16-string->bytevector "123456") #f)
-  (let ((lst (string->canonical-sexp
-              "(Name Otto Meier (address Burgplatz) #123456#)")))
-    (unfold (cut > <> 5)
-            (cut canonical-sexp-nth-data lst <>)
-            1+
-            0)))
-
-(let ((bv (base16-string->bytevector
-           "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c")))
-  (test-equal "hash corrupt due to restrictive locale encoding"
-    bv
-
-    ;; In Guix up to 0.6 included this test would fail because at some point
-    ;; the hash value would be cropped to ASCII.  In practice 'guix
-    ;; authenticate' would produce invalid signatures that would fail
-    ;; signature verification.  See <http://bugs.gnu.org/17312>.
-    (let ((locale (setlocale LC_ALL)))
-     (dynamic-wind
-       (lambda ()
-         (setlocale LC_ALL "C"))
-       (lambda ()
-         (hash-data->bytevector
-          (string->canonical-sexp
-           (canonical-sexp->string
-            (bytevector->hash-data bv "sha256")))))
-       (lambda ()
-         (setlocale LC_ALL locale))))))
-
-(gc)
-
-;; XXX: The test below is typically too long as it needs to gather enough entropy.
-
-;; (test-assert "generate-key"
-;;   (let ((key (generate-key (string->canonical-sexp
-;;                             "(genkey (rsa (nbits 3:128)))"))))
-;;     (and (canonical-sexp? key)
-;;          (find-sexp-token key 'key-data)
-;;          (find-sexp-token key 'public-key)
-;;          (find-sexp-token key 'private-key))))
-
-(test-assert "bytevector->hash-data->bytevector"
-  (let* ((bv   (sha256 (string->utf8 "Hello, world.")))
-         (data (bytevector->hash-data bv "sha256")))
-    (and (canonical-sexp? data)
-         (let-values (((value algo) (hash-data->bytevector data)))
-           (and (string=? algo "sha256")
-                (bytevector=? value bv))))))
-
-(test-equal "key-type"
-  '(rsa ecc)
-  (map (compose key-type
-                (cut find-sexp-token <> 'public-key)
-                string->canonical-sexp)
-       (list %key-pair %ecc-key-pair)))
-
-(test-assert "sign + verify"
-  (let* ((pair   (string->canonical-sexp %key-pair))
-         (secret (find-sexp-token pair 'private-key))
-         (public (find-sexp-token pair 'public-key))
-         (data   (bytevector->hash-data
-                  (sha256 (string->utf8 "Hello, world."))
-                  #:key-type (key-type public)))
-         (sig    (sign data secret)))
-    (and (verify sig data public)
-         (not (verify sig
-                      (bytevector->hash-data
-                       (sha256 (string->utf8 "Hi!"))
-                       #:key-type (key-type public))
-                      public)))))
-
-;; Ed25519 appeared in libgcrypt 1.6.0.
-(test-skip (if (version>? (gcrypt-version) "1.6.0") 0 1))
-(test-assert "sign + verify, Ed25519"
-  (let* ((pair   (string->canonical-sexp %ecc-key-pair))
-         (secret (find-sexp-token pair 'private-key))
-         (public (find-sexp-token pair 'public-key))
-         (data   (bytevector->hash-data
-                  (sha256 (string->utf8 "Hello, world."))))
-         (sig    (sign data secret)))
-    (and (verify sig data public)
-         (not (verify sig
-                      (bytevector->hash-data
-                       (sha256 (string->utf8 "Hi!")))
-                      public)))))
-
-(gc)
-
-(test-equal "canonical-sexp->sexp"
-  `((data
-     (flags pkcs1)
-     (hash sha256
-           ,(base16-string->bytevector
-             "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
-
-    (public-key
-     (rsa
-      (n ,(base16-string->bytevector
-           (string-downcase
-            "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
-      (e ,(base16-string->bytevector
-           "010001")))))
-
-  (list (canonical-sexp->sexp
-         (string->canonical-sexp
-          "(data
-             (flags pkcs1)
-             (hash \"sha256\"
-                   #2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))"))
-
-        (canonical-sexp->sexp
-         (find-sexp-token (string->canonical-sexp %key-pair)
-                          'public-key))))
-
-
-(let ((lst
-       `((data
-          (flags pkcs1)
-          (hash sha256
-                ,(base16-string->bytevector
-                  "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))
-
-         (public-key
-          (rsa
-           (n ,(base16-string->bytevector
-                (string-downcase
-                 "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45")))
-           (e ,(base16-string->bytevector
-                "010001"))))
-
-         ,(base16-string->bytevector
-           "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))))
-  (test-equal "sexp->canonical-sexp->sexp"
-    lst
-    (map (compose canonical-sexp->sexp sexp->canonical-sexp)
-         lst)))
-
-(let ((sexp `(signature
-              (public-key
-               (rsa
-                (n ,(make-bytevector 1024 1))
-                (e ,(base16-string->bytevector "010001")))))))
-  (test-equal "https://bugs.g10code.com/gnupg/issue1594"
-    ;; The gcrypt bug above was primarily affecting our uses in
-    ;; 'canonical-sexp->sexp', typically when applied to a signature sexp (in
-    ;; 'guix authenticate -verify') with a "big" RSA key, such as 4096 bits.
-    sexp
-    (canonical-sexp->sexp (sexp->canonical-sexp sexp))))
-
-(test-end)
diff --git a/tests/pki.scm b/tests/pki.scm
index 876ad98d7..d6a6b476c 100644
--- a/tests/pki.scm
+++ b/tests/pki.scm
@@ -18,8 +18,8 @@
 
 (define-module (test-pki)
   #:use-module (guix pki)
-  #:use-module (guix pk-crypto)
-  #:use-module (guix hash)
+  #:use-module (gcrypt pk-crypto)
+  #:use-module (gcrypt hash)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-64))
 
diff --git a/tests/publish.scm b/tests/publish.scm
index 1ed830807..0e793c1ee 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -25,7 +25,7 @@
   #:use-module (guix tests)
   #:use-module (guix config)
   #:use-module (guix utils)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix gexp)
@@ -33,7 +33,7 @@
   #:use-module (guix base64)
   #:use-module ((guix records) #:select (recutils->alist))
   #:use-module ((guix serialization) #:select (restore-file))
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
   #:use-module (guix zlib)
   #:use-module (web uri)
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 310c6c8f2..616ec191f 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -20,7 +20,7 @@
 (define-module (test-pypi)
   #:use-module (guix import pypi)
   #:use-module (guix base32)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module (guix build-system python)
   #:use-module ((guix build utils) #:select (delete-file-recursively which))
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index 4ca2ec0f6..e438aa84c 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -19,7 +19,7 @@
 (define-module (test-store-deduplication)
   #:use-module (guix tests)
   #:use-module (guix store deduplication)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (guix build utils)
   #:use-module (rnrs bytevectors)
diff --git a/tests/store.scm b/tests/store.scm
index 47fab0df1..71ac57580 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -21,7 +21,7 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix monads)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix packages)
   #:use-module (guix derivations)
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 0ad624795..964a57f30 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -20,9 +20,9 @@
 (define-module (test-substitute)
   #:use-module (guix scripts substitute)
   #:use-module (guix base64)
-  #:use-module (guix hash)
+  #:use-module (gcrypt hash)
   #:use-module (guix serialization)
-  #:use-module (guix pk-crypto)
+  #:use-module (gcrypt pk-crypto)
   #:use-module (guix pki)
   #:use-module (guix config)
   #:use-module (guix base32)
-- 
2.18.0

^ permalink raw reply related	[relevance 9%]

* [bug#32263] [PATCH 7/8] gnu: python-docker-py: Update to 1.10.6.
  2018-07-24 18:51 69% ` [bug#32263] [PATCH 1/8] gnu: Add python-docker-pycreds Efraim Flashner
@ 2018-07-24 18:51 72%   ` Efraim Flashner
  0 siblings, 0 replies; 149+ results
From: Efraim Flashner @ 2018-07-24 18:51 UTC (permalink / raw)
  To: 32263; +Cc: Efraim Flashner

* gnu/packages/docker.scm (python-docker-py): Update to 1.10.6.
---
 gnu/packages/docker.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index 07b5b1ea1..2a08446dd 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -32,14 +32,14 @@
 (define-public python-docker-py
   (package
     (name "python-docker-py")
-    (version "1.6.0")
+    (version "1.10.6")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "docker-py" version))
        (sha256
         (base32
-         "16ba4xyd46hkj9nkfpz15r8kskl7ljx1afjzchyrhdsrklvzgzim"))))
+         "05f49f6hnl7npmi7kigg0ibqk8s3fhzx1ivvz1kqvlv4ay3paajc"))))
     (build-system python-build-system)
     ;; TODO: Tests require a running Docker daemon.
     (arguments '(#:tests? #f))
-- 
2.18.0

^ permalink raw reply related	[relevance 72%]

* [bug#32263] [PATCH 1/8] gnu: Add python-docker-pycreds.
  @ 2018-07-24 18:51 69% ` Efraim Flashner
  2018-07-24 18:51 72%   ` [bug#32263] [PATCH 7/8] gnu: python-docker-py: Update to 1.10.6 Efraim Flashner
  0 siblings, 1 reply; 149+ results
From: Efraim Flashner @ 2018-07-24 18:51 UTC (permalink / raw)
  To: 32263; +Cc: Efraim Flashner

* gnu/packages/docker.scm (python-docker-pycreds): New variable.
---
 gnu/packages/docker.scm | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

diff --git a/gnu/packages/docker.scm b/gnu/packages/docker.scm
index f540417b4..07b5b1ea1 100644
--- a/gnu/packages/docker.scm
+++ b/gnu/packages/docker.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
+;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,7 @@
   #:use-module (guix git-download)
   #:use-module (guix build-system python)
   #:use-module (guix utils)
+  #:use-module (gnu packages check)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web))
 
@@ -103,3 +105,39 @@ multi-container Docker applications.  A Compose file is used to configure an
 application’s services.  Then, using a single command, the containers are
 created and all the services are started as specified in the configuration.")
     (license license:asl2.0)))
+
+(define-public python-docker-pycreds
+  (package
+    (name "python-docker-pycreds")
+    (version "0.3.0")
+    (source
+      (origin
+        (method url-fetch)
+        (uri (pypi-uri "docker-pycreds" version))
+        (sha256
+         (base32
+          "1zxvam1q22qb0jf48553nnncnfrcp88ag4xa0qmq6vr0imn9a3lb"))))
+    (build-system python-build-system)
+    (arguments
+     `(#:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'fix-versioning
+           (lambda _
+             (substitute* "test-requirements.txt"
+               (("3.0.2") ,(package-version python-pytest))
+               (("2.3.1") ,(package-version python-pytest-cov))
+               (("2.4.1") ,(package-version python-flake8)))
+             #t)))))
+    (native-inputs
+     `(("python-flake8" ,python-flake8)
+       ("python-pytest" ,python-pytest)
+       ("python-pytest-cov" ,python-pytest-cov)))
+    (propagated-inputs
+     `(("python-six" ,python-six)))
+    (home-page "https://github.com/shin-/dockerpy-creds")
+    (synopsis
+     "Python bindings for the docker credentials store API")
+    (description
+     "Docker-Pycreds contains the Python bindings for the docker credentials
+store API.")
+    (license license:asl2.0)))
-- 
2.18.0

^ permalink raw reply related	[relevance 69%]

* [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker).
  @ 2018-05-28 21:59 64% ` Ludovic Courtès
  0 siblings, 0 replies; 149+ results
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* guix/docker.scm: Use module (json) the normal way.
* guix/scripts/pack.scm (docker-image)[build]: Wrap in
'with-extensions'.
---
 guix/docker.scm       |  6 ++----
 guix/scripts/pack.scm | 37 +++++++++++++++++--------------------
 2 files changed, 19 insertions(+), 24 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index a75534c33..b86990159 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module ((texinfo string-utils)
@@ -34,9 +35,6 @@
   #: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.
 (define docker-id
   (compose bytevector->base16-string sha256 string->utf8))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1e84459e7..f5e247ed7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -256,28 +256,25 @@ the image."
         guile-json))
 
   (define build
-    (with-imported-modules `(,@(source-module-closure '((guix docker))
-                                                      #:select? not-config?)
-                             (guix build store-copy)
-                             ((guix config) => ,config))
-      #~(begin
-          ;; Guile-JSON is required by (guix docker).
-          (add-to-load-path
-           (string-append #+json "/share/guile/site/"
-                          (effective-version)))
+    ;; Guile-JSON is required by (guix docker).
+    (with-extensions (list json)
+      (with-imported-modules `(,@(source-module-closure '((guix docker))
+                                                        #:select? not-config?)
+                               (guix build store-copy)
+                               ((guix config) => ,config))
+        #~(begin
+            (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 
-          (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+            (setenv "PATH" (string-append #$tar "/bin"))
 
-          (setenv "PATH" (string-append #$tar "/bin"))
-
-          (build-docker-image #$output
-                              (call-with-input-file "profile"
-                                read-reference-graph)
-                              #$profile
-                              #:system (or #$target (utsname:machine (uname)))
-                              #:symlinks '#$symlinks
-                              #:compressor '#$(compressor-command compressor)
-                              #:creation-time (make-time time-utc 0 1)))))
+            (build-docker-image #$output
+                                (call-with-input-file "profile"
+                                  read-reference-graph)
+                                #$profile
+                                #:system (or #$target (utsname:machine (uname)))
+                                #:symlinks '#$symlinks
+                                #:compressor '#$(compressor-command compressor)
+                                #:creation-time (make-time time-utc 0 1))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
-- 
2.17.0

^ permalink raw reply related	[relevance 64%]

* [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.
  @ 2018-03-21  4:25 54%         ` Chris Marusich
  0 siblings, 0 replies; 149+ results
From: Chris Marusich @ 2018-03-21  4:25 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: 30572


[-- Attachment #1.1: Type: text/plain, Size: 219 bytes --]

Chris Marusich <cmmarusich@gmail.com> writes:

> Is it OK to commit this as-is (with just the guile-json change you
> suggested above)?

Here's an updated patch which contains the guile-json change.

-- 
Chris

[-- Attachment #1.2: 0006-system-Add-guix-system-docker-image-command.patch --]
[-- Type: text/x-patch, Size: 14864 bytes --]

From 35f930186bcdc7863ac6ce19b0dba428b3cfab3a Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:45:03 +0100
Subject: [PATCH 6/7] system: Add "guix system docker-image" command.

* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system
  docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
---
 doc/guix.texi                         |  36 ++++++++++--
 gnu/system/examples/docker-image.tmpl |  47 +++++++++++++++
 gnu/system/vm.scm                     | 105 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  12 ++--
 4 files changed, 192 insertions(+), 8 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 792539a12..8d38c3d4a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -20361,12 +20361,18 @@ containing at least the kernel, initrd, and bootloader data files must
 be created.  The @code{--image-size} option can be used to specify the
 size of the image.
 
+@cindex System images, creation in various formats
+@cindex Creating system images in various formats
 @item vm-image
 @itemx disk-image
-Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  By default, @command{guix system}
-estimates the size of the image needed to store the system, but you can
-use the @option{--image-size} option to specify a value.
+@itemx docker-image
+Return a virtual machine, disk image, or Docker image of the operating
+system declared in @var{file} that stands alone.  By default,
+@command{guix system} estimates the size of the image needed to store
+the system, but you can use the @option{--image-size} option to specify
+a value.  Docker images are built to contain exactly what they need, so
+the @option{--image-size} option is ignored in the case of
+@code{docker-image}.
 
 You can specify the root file system type by using the
 @option{--file-system-type} option.  It defaults to @code{ext4}.
@@ -20384,6 +20390,28 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+When using @code{docker-image}, a Docker image is produced.  Guix builds
+the image from scratch, not from a pre-existing Docker base image.  As a
+result, it contains @emph{exactly} what you define in the operating
+system configuration file.  You can then load the image and launch a
+Docker container using commands like the following:
+
+@example
+image_id="$(docker load < guixsd-docker-image.tar.gz)"
+docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
+    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
+    $image_id /var/guix/profiles/system/boot
+@end example
+
+This command starts a new Docker container from the specified image.  It
+will boot the GuixSD system in the usual manner, which means it will
+start any services you have defined in the operating system
+configuration.  Depending on what you run in the Docker container, it
+may be necessary to give the container additional permissions.  For
+example, if you intend to build software using Guix inside of the Docker
+container, you may need to pass the @option{--privileged} option to
+@code{docker run}.
+
 @item container
 Return a script to run the operating system declared in @var{file}
 within a container.  Containers are a set of lightweight isolation
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
new file mode 100644
index 000000000..d73187398
--- /dev/null
+++ b/gnu/system/examples/docker-image.tmpl
@@ -0,0 +1,47 @@
+;; This is an operating system configuration template for a "Docker image"
+;; setup, so it has barely any services at all.
+
+(use-modules (gnu))
+
+(operating-system
+  (host-name "komputilo")
+  (timezone "Europe/Berlin")
+  (locale "en_US.utf8")
+
+  ;; This is where user accounts are specified.  The "root" account is
+  ;; implicit, and is initially created with the empty password.
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                (supplementary-groups '("wheel"
+                                        "audio" "video"))
+                (home-directory "/home/alice"))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages %base-packages)
+
+  ;; Because the system will run in a Docker container, we may omit many
+  ;; things that would normally be required in an operating system
+  ;; configuration file.  These things include:
+  ;;
+  ;;   * bootloader
+  ;;   * file-systems
+  ;;   * services such as mingetty, udevd, slim, networking, dhcp
+  ;;
+  ;; Either these things are simply not required, or Docker provides
+  ;; similar services for us.
+
+  ;; This will be ignored.
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target "does-not-matter")))
+  ;; This will be ignored, too.
+  (file-systems (list (file-system
+                        (device "does-not-matter")
+                        (mount-point "/")
+                        (type "does-not-matter"))))
+
+  ;; Guix is all you need!
+  (services (list (guix-service))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index d239fa56a..af49065f3 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,7 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
+  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -30,6 +31,7 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
   #:use-module (guix hash)
   #:use-module (guix base32)
@@ -39,7 +41,9 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -76,6 +80,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -376,6 +381,106 @@ the image."
    #:disk-image-format disk-image-format
    #:references-graphs inputs))
 
+(define* (system-docker-image os
+                              #:key
+                              (name "guixsd-docker-image")
+                              register-closures?)
+  "Build a docker image.  OS is the desired <operating-system>.  NAME is the
+base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
+register the closure of OS with Guix in the resulting Docker image.  This only
+makes sense when you want to build a GuixSD Docker image that has Guix
+installed inside of it.  If you don't need Guix (e.g., your GuixSD Docker
+image just contains a web server that is started by the Shepherd), then you
+should set REGISTER-CLOSURES? to #f."
+  (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"))))))
+  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
+                      (name -> (string-append name ".tar.gz"))
+                      (graph -> "system-graph"))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (guix build utils)
+                                                          (gnu build vm))
+                                                        #:select? not-config?)
+                               (guix build store-copy)
+                               ((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)
+                         (guix build utils)
+                         (gnu build vm)
+                         (srfi srfi-19)
+                         (guix build store-copy))
+
+            (let* ((inputs '#$(append (list tar)
+                                      (if register-closures?
+                                          (list guix)
+                                          '())))
+                   ;; This initializer requires elevated privileges that are
+                   ;; not normally available in the build environment (e.g.,
+                   ;; it needs to create device nodes).  In order to obtain
+                   ;; such privileges, we run it as root in a VM.
+                   (initialize (root-partition-initializer
+                                #:closures '(#$graph)
+                                #:register-closures? #$register-closures?
+                                #:system-directory #$os-drv
+                                ;; De-duplication would fail due to
+                                ;; cross-device link errors, so don't do it.
+                                #:deduplicate? #f))
+                   ;; Even as root in a VM, the initializer would fail due to
+                   ;; lack of privileges if we use a root-directory that is on
+                   ;; a file system that is shared with the host (e.g., /tmp).
+                   (root-directory "/guixsd-system-root"))
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir root-directory)
+              (initialize root-directory)
+              (build-docker-image
+               (string-append "/xchg/" #$name) ;; The output file.
+               (cons* root-directory
+                      (call-with-input-file (string-append "/xchg/" #$graph)
+                        read-reference-graph))
+               #$os-drv
+               #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+               #:creation-time (make-time time-utc 0 1)
+               #:transformations `((,root-directory -> "")))))))
+    (expression->derivation-in-linux-vm
+     name
+     ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
+     ;; needs to be run by a Guile that can dlopen libgcrypt.  The following
+     ;; hack works around that problem by putting the "build" gexp into an
+     ;; executable script (created by program-file) which, when executed, will
+     ;; run using a Guile that supports dlopen.  That way, the VM's initrd
+     ;; Guile can just execute it via invoke, without using dlopen.  See:
+     ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+     (with-imported-modules `((guix build utils))
+       #~(begin
+           (use-modules (guix build utils))
+           ;; If we use execl instead of invoke here, the VM will crash with a
+           ;; kernel panic.
+           (invoke #$(program-file "build-docker-image" build))))
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,graph ,os-drv)))))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index acfccce96..09f99b300 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -701,7 +701,9 @@ checking this by themselves in their 'check' procedure."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -899,6 +901,8 @@ Some ACTIONS support additional ARGS.\n"))
    vm-image         build a freestanding virtual machine image\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
+  (display (G_ "\
+   docker-image     build a Docker image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1130,7 +1134,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1159,7 +1163,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 54%]

* [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.
    2018-03-15  4:09 40%   ` [bug#30572] [PATCH 5/7] guix: Rewrite build-docker-image to allow more paths Chris Marusich
@ 2018-03-15  4:09 35%   ` Chris Marusich
    1 sibling, 1 reply; 149+ results
From: Chris Marusich @ 2018-03-15  4:09 UTC (permalink / raw)
  To: bug#30572; +Cc: Chris Marusich

* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system
  docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
---
 doc/guix.texi                         |  36 +++++++++--
 gnu/system/examples/docker-image.tmpl |  47 ++++++++++++++
 gnu/system/vm.scm                     | 113 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  12 ++--
 4 files changed, 200 insertions(+), 8 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 792539a12..8d38c3d4a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -20361,12 +20361,18 @@ containing at least the kernel, initrd, and bootloader data files must
 be created.  The @code{--image-size} option can be used to specify the
 size of the image.
 
+@cindex System images, creation in various formats
+@cindex Creating system images in various formats
 @item vm-image
 @itemx disk-image
-Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  By default, @command{guix system}
-estimates the size of the image needed to store the system, but you can
-use the @option{--image-size} option to specify a value.
+@itemx docker-image
+Return a virtual machine, disk image, or Docker image of the operating
+system declared in @var{file} that stands alone.  By default,
+@command{guix system} estimates the size of the image needed to store
+the system, but you can use the @option{--image-size} option to specify
+a value.  Docker images are built to contain exactly what they need, so
+the @option{--image-size} option is ignored in the case of
+@code{docker-image}.
 
 You can specify the root file system type by using the
 @option{--file-system-type} option.  It defaults to @code{ext4}.
@@ -20384,6 +20390,28 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+When using @code{docker-image}, a Docker image is produced.  Guix builds
+the image from scratch, not from a pre-existing Docker base image.  As a
+result, it contains @emph{exactly} what you define in the operating
+system configuration file.  You can then load the image and launch a
+Docker container using commands like the following:
+
+@example
+image_id="$(docker load < guixsd-docker-image.tar.gz)"
+docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
+    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
+    $image_id /var/guix/profiles/system/boot
+@end example
+
+This command starts a new Docker container from the specified image.  It
+will boot the GuixSD system in the usual manner, which means it will
+start any services you have defined in the operating system
+configuration.  Depending on what you run in the Docker container, it
+may be necessary to give the container additional permissions.  For
+example, if you intend to build software using Guix inside of the Docker
+container, you may need to pass the @option{--privileged} option to
+@code{docker run}.
+
 @item container
 Return a script to run the operating system declared in @var{file}
 within a container.  Containers are a set of lightweight isolation
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
new file mode 100644
index 000000000..d73187398
--- /dev/null
+++ b/gnu/system/examples/docker-image.tmpl
@@ -0,0 +1,47 @@
+;; This is an operating system configuration template for a "Docker image"
+;; setup, so it has barely any services at all.
+
+(use-modules (gnu))
+
+(operating-system
+  (host-name "komputilo")
+  (timezone "Europe/Berlin")
+  (locale "en_US.utf8")
+
+  ;; This is where user accounts are specified.  The "root" account is
+  ;; implicit, and is initially created with the empty password.
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                (supplementary-groups '("wheel"
+                                        "audio" "video"))
+                (home-directory "/home/alice"))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages %base-packages)
+
+  ;; Because the system will run in a Docker container, we may omit many
+  ;; things that would normally be required in an operating system
+  ;; configuration file.  These things include:
+  ;;
+  ;;   * bootloader
+  ;;   * file-systems
+  ;;   * services such as mingetty, udevd, slim, networking, dhcp
+  ;;
+  ;; Either these things are simply not required, or Docker provides
+  ;; similar services for us.
+
+  ;; This will be ignored.
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target "does-not-matter")))
+  ;; This will be ignored, too.
+  (file-systems (list (file-system
+                        (device "does-not-matter")
+                        (mount-point "/")
+                        (type "does-not-matter"))))
+
+  ;; Guix is all you need!
+  (services (list (guix-service))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index d239fa56a..dd3641151 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,7 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
+  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -30,6 +31,7 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
   #:use-module (guix hash)
   #:use-module (guix base32)
@@ -39,7 +41,9 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -76,6 +80,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -376,6 +381,114 @@ the image."
    #:disk-image-format disk-image-format
    #:references-graphs inputs))
 
+(define* (system-docker-image os
+                              #:key
+                              (name "guixsd-docker-image")
+                              register-closures?)
+  "Build a docker image.  OS is the desired <operating-system>.  NAME is the
+base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
+register the closure of OS with Guix in the resulting Docker image.  This only
+makes sense when you want to build a GuixSD Docker image that has Guix
+installed inside of it.  If you don't need Guix (e.g., your GuixSD Docker
+image just contains a web server that is started by the Shepherd), then you
+should set REGISTER-CLOSURES? to #f."
+  (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 json
+    ;; Pick the guile-json package that corresponds to the Guile used to build
+    ;; derivations.
+    (if (string-prefix? "2.0" (package-version (default-guile)))
+        guile2.0-json
+        guile-json))
+
+  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
+                      (name -> (string-append name ".tar.gz"))
+                      (graph -> "system-graph"))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (guix build utils)
+                                                          (gnu build vm))
+                                                        #:select? not-config?)
+                               (guix build store-copy)
+                               ((guix config) => ,config))
+        #~(begin
+            ;; Guile-JSON is required by (guix docker).
+            (add-to-load-path
+             (string-append #+json "/share/guile/site/"
+                            (effective-version)))
+            (use-modules (guix docker)
+                         (guix build utils)
+                         (gnu build vm)
+                         (srfi srfi-19)
+                         (guix build store-copy))
+
+            (let* ((inputs '#$(append (list tar)
+                                      (if register-closures?
+                                          (list guix)
+                                          '())))
+                   ;; This initializer requires elevated privileges that are
+                   ;; not normally available in the build environment (e.g.,
+                   ;; it needs to create device nodes).  In order to obtain
+                   ;; such privileges, we run it as root in a VM.
+                   (initialize (root-partition-initializer
+                                #:closures '(#$graph)
+                                #:register-closures? #$register-closures?
+                                #:system-directory #$os-drv
+                                ;; De-duplication would fail due to
+                                ;; cross-device link errors, so don't do it.
+                                #:deduplicate? #f))
+                   ;; Even as root in a VM, the initializer would fail due to
+                   ;; lack of privileges if we use a root-directory that is on
+                   ;; a file system that is shared with the host (e.g., /tmp).
+                   (root-directory "/guixsd-system-root"))
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir root-directory)
+              (initialize root-directory)
+              (build-docker-image
+               (string-append "/xchg/" #$name) ;; The output file.
+               (cons* root-directory
+                      (call-with-input-file (string-append "/xchg/" #$graph)
+                        read-reference-graph))
+               #$os-drv
+               #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+               #:creation-time (make-time time-utc 0 1)
+               #:transformations `((,root-directory -> "")))))))
+    (expression->derivation-in-linux-vm
+     name
+     ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
+     ;; needs to be run by a Guile that can dlopen libgcrypt.  The following
+     ;; hack works around that problem by putting the "build" gexp into an
+     ;; executable script (created by program-file) which, when executed, will
+     ;; run using a Guile that supports dlopen.  That way, the VM's initrd
+     ;; Guile can just execute it via invoke, without using dlopen.  See:
+     ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+     (with-imported-modules `((guix build utils))
+       #~(begin
+           (use-modules (guix build utils))
+           ;; If we use execl instead of invoke here, the VM will crash with a
+           ;; kernel panic.
+           (invoke #$(program-file "build-docker-image" build))))
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,graph ,os-drv)))))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index acfccce96..09f99b300 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -701,7 +701,9 @@ checking this by themselves in their 'check' procedure."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -899,6 +901,8 @@ Some ACTIONS support additional ARGS.\n"))
    vm-image         build a freestanding virtual machine image\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
+  (display (G_ "\
+   docker-image     build a Docker image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1130,7 +1134,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1159,7 +1163,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
-- 
2.15.1

^ permalink raw reply related	[relevance 35%]

* [bug#30572] [PATCH 5/7] guix: Rewrite build-docker-image to allow more paths.
  @ 2018-03-15  4:09 40%   ` Chris Marusich
  2018-03-15  4:09 35%   ` [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command Chris Marusich
  1 sibling, 0 replies; 149+ results
From: Chris Marusich @ 2018-03-15  4:09 UTC (permalink / raw)
  To: bug#30572; +Cc: Chris Marusich

* guix/docker.scm (build-docker-image): Rename "path" argument to
  "prefix" to reflect the fact that it is used as a prefix for the
  symlink targets.  Add the "paths" argument, and remove the "closure"
  argument, since it is now redundant.  Add a "transformations"
  argument.
* guix/scripts/pack.scm (docker-image): Read the profile's reference
  graph and provide its paths to build-docker-image via the new "paths"
  argument.
---
 guix/docker.scm       | 200 ++++++++++++++++++++++++++++++--------------------
 guix/scripts/pack.scm |   9 ++-
 2 files changed, 128 insertions(+), 81 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..a75534c33 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,9 +24,12 @@
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
-                          with-directory-excursion))
-  #:use-module (guix build store-copy)
+                          with-directory-excursion
+                          invoke))
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module ((texinfo string-utils)
+                #:select (escape-special-chars))
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:export (build-docker-image))
@@ -33,8 +37,7 @@
 ;; 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.
+;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
   (compose bytevector->base16-string sha256 string->utf8))
 
@@ -102,82 +105,123 @@ return \"a\"."
     ((first rest ...)
      first)))
 
-(define* (build-docker-image image path
-                             #:key closure compressor
+(define* (build-docker-image image paths prefix
+                             #:key
                              (symlinks '())
+                             (transformations '())
                              (system (utsname:machine (uname)))
+                             compressor
                              (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.  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."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
-        (closure (canonicalize-path closure))
-        (id (docker-id path))
-        (time (date->string (time-utc->date creation-time) "~4"))
-        (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")))))
+  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
+must be a store path that is a prefix of any store paths in PATHS.
+
+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
+transform the PATHS.  Any path in PATHS that begins with OLD will be rewritten
+in the Docker image so that it begins with NEW instead.  If a path is a
+non-empty directory, then its contents will be recursively added, as well.
+
+SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
+PATHS 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."
+  (define (sanitize path-fragment)
+    (escape-special-chars
+     ;; GNU tar strips the leading slash off of absolute paths before applying
+     ;; the transformations, so we need to do the same, or else our
+     ;; replacements won't match any paths.
+     (string-trim path-fragment #\/)
+     ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
+     ;; We also need to escape "/" because we use it as a delimiter.
+     "/*.^$[]\\"
+     #\\))
+  (define transformation->replacement
+    (match-lambda
+      ((old '-> new)
+       ;; See "(tar) transform" for details on the expression syntax.
+       (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
+  (define (transformations->expression transformations)
+    (let ((replacements (map transformation->replacement transformations)))
+      (string-append
+       ;; Avoid transforming link targets, since that would break some links
+       ;; (e.g., symlinks that point to an absolute store path).
+       "flags=rSH;"
+       (string-join replacements ";")
+       ;; Some paths might still have a leading path delimiter even after tar
+       ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
+       ;; strip any leading path delimiters that remain.
+       ";s,^//*,,")))
+  (define transformation-options
+    (if (eq? '() transformations)
+        '()
+        `("--transform" ,(transformations->expression transformations))))
+  (let* ((directory "/tmp/docker-image") ;temporary working directory
+         (id (docker-id prefix))
+         (time (date->string (time-utc->date creation-time) "~4"))
+         (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)
-
-    (and (with-directory-excursion 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))))
-
-             ;; Wrap it up.
-             (let ((items (call-with-input-file closure
-                            read-reference-graph)))
-               ;; Create SYMLINKS.
-               (for-each (match-lambda
-                           ((source '-> target)
-                            (let ((source (string-trim source #\/)))
-                              (mkdir-p (dirname source))
-                              (symlink (string-append path "/" target)
-                                       source))))
-                         symlinks)
-
-               (and (zero? (apply system* "tar" "-cf" "layer.tar"
-                                  (append %tar-determinism-options
-                                          items
-                                          (map symlink-source symlinks))))
-                    (for-each delete-file-recursively
-                              (map (compose topmost-component symlink-source)
-                                   symlinks)))))
-
-           (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
-                            `(,@%tar-determinism-options
-                              ,@(if compressor
-                                    (list "-I" (string-join compressor))
-                                    '())
-                              ".")))
-              (begin (delete-file-recursively directory) #t)))))
+    (with-directory-excursion 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))))
+
+        ;; Create SYMLINKS.
+        (for-each (match-lambda
+                    ((source '-> target)
+                     (let ((source (string-trim source #\/)))
+                       (mkdir-p (dirname source))
+                       (symlink (string-append prefix "/" target)
+                                source))))
+                  symlinks)
+
+        (apply invoke "tar" "-cf" "layer.tar"
+               `(,@transformation-options
+                 ,@%tar-determinism-options
+                 ,@paths
+                 ,@(map symlink-source symlinks)))
+        ;; It is possible for "/" to show up in the archive, especially when
+        ;; applying transformations.  For example, the transformation
+        ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
+        ;; the path "/a" into "/".  The presence of "/" in the archive is
+        ;; probably benign, but it is definitely safe to remove it, so let's
+        ;; do that.  This fails when "/" is not in the archive, so use system*
+        ;; instead of invoke to avoid an exception in that case.
+        (system* "tar" "--delete" "/" "-f" "layer.tar")
+        (for-each delete-file-recursively
+                  (map (compose topmost-component symlink-source)
+                       symlinks)))
+
+      (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 prefix id))))
+      (with-output-to-file "repositories"
+        (lambda ()
+          (scm->json (repositories prefix id)))))
+
+    (apply invoke "tar" "-cf" image "-C" directory
+           `(,@%tar-determinism-options
+             ,@(if compressor
+                   (list "-I" (string-join compressor))
+                   '())
+             "."))
+    (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 64ed44460..fba17f8e5 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -235,6 +235,7 @@ the image."
   (define build
     (with-imported-modules `(,@(source-module-closure '((guix docker))
                                                       #:select? not-config?)
+                             (guix build store-copy)
                              ((guix config) => ,config))
       #~(begin
           ;; Guile-JSON is required by (guix docker).
@@ -242,13 +243,15 @@ the image."
            (string-append #+json "/share/guile/site/"
                           (effective-version)))
 
-          (use-modules (guix docker) (srfi srfi-19))
+          (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 
           (setenv "PATH" (string-append #$tar "/bin"))
 
-          (build-docker-image #$output #$profile
+          (build-docker-image #$output
+                              (call-with-input-file "profile"
+                                read-reference-graph)
+                              #$profile
                               #:system (or #$target (utsname:machine (uname)))
-                              #:closure "profile"
                               #:symlinks '#$symlinks
                               #:compressor '#$(compressor-command compressor)
                               #:creation-time (make-time time-utc 0 1)))))
-- 
2.15.1

^ permalink raw reply related	[relevance 40%]

* [bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.
  @ 2018-02-27  4:43 83%           ` Chris Marusich
  0 siblings, 0 replies; 149+ results
From: Chris Marusich @ 2018-02-27  4:43 UTC (permalink / raw)
  To: Danny Milosavljevic; +Cc: 30572


[-- Attachment #1.1: Type: text/plain, Size: 365 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

> +         (and (zero? (apply system* "tar" "-C" tmpdir "-cf" image
>
> Apparently this works as-is, but also here, I'd write
>
> +         (and (zero? (apply system* "tar" "-cf" image "-C" tmpdir
>
> Otherwise LGTM!

Good catch!  I've attached a new patch that does what you suggest.

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0004-docker-Allow-the-use-of-a-custom-temporary-directory.patch --]
[-- Type: text/x-patch, Size: 3410 bytes --]

From 4bca56cc619e90b1c820c2a7f8f7a5fe1f4a8645 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:45:03 +0100
Subject: [PATCH 4/8] docker: Allow the use of a custom temporary directory.

* guix/docker.scm: (build-docker-image): Add #:tmpdir keyword argument.
---
 guix/docker.scm | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..659d228aa 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -106,7 +106,8 @@ return \"a\"."
                              #:key closure compressor
                              (symlinks '())
                              (system (utsname:machine (uname)))
-                             (creation-time (current-time time-utc)))
+                             (creation-time (current-time time-utc))
+                             (tmpdir "/tmp/docker-image"))
   "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
@@ -115,9 +116,13 @@ 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."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
-        (closure (canonicalize-path closure))
+CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
+
+TMPDIR is the name of the temporary working directory to use.  This can be
+useful if you need to use a specific temporary directory, for example because
+the default temporary directory lies on a file system with insufficient
+space."
+  (let ((closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
         (arch (let-syntax ((cond* (syntax-rules ()
@@ -133,9 +138,9 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
                        ("arm"    "arm")
                        ("mips64" "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
-    (mkdir directory)
+    (mkdir-p tmpdir)
 
-    (and (with-directory-excursion directory
+    (and (with-directory-excursion tmpdir
            (mkdir id)
            (with-directory-excursion id
              (with-output-to-file "VERSION"
@@ -174,10 +179,10 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
              (lambda ()
                (scm->json (repositories path id)))))
 
-         (and (zero? (apply system* "tar" "-C" directory "-cf" image
+         (and (zero? (apply system* "tar" "-cf" image "-C" tmpdir
                             `(,@%tar-determinism-options
                               ,@(if compressor
                                     (list "-I" (string-join compressor))
                                     '())
                               ".")))
-              (begin (delete-file-recursively directory) #t)))))
+              (begin (delete-file-recursively tmpdir) #t)))))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 83%]

* [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.
  2018-02-22 10:35 37%   ` [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command Chris Marusich
@ 2018-02-26 16:30 56%     ` Chris Marusich
  0 siblings, 0 replies; 149+ results
From: Chris Marusich @ 2018-02-26 16:30 UTC (permalink / raw)
  To: Chris Marusich; +Cc: 30572


[-- Attachment #1.1: Type: text/plain, Size: 830 bytes --]

Chris Marusich <cmmarusich@gmail.com> writes:

> +              (let ((tmpdir "/xchg/tmp"))
> +                (mkdir tmpdir)
> +                (build-docker-image
> +                 (string-append "/xchg/" #$name) ;; The output file.
> +                 #$os-drv
> +                 #:closure (string-append "/xchg/" #$system-graph-name)
> +                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
> +                 #:creation-time (make-time time-utc 0 1)
> +                 #:tmpdir tmpdir
> +                 #:extra-items-dir root)
> +                (delete-file-recursively tmpdir))))))

I've adjusted this section to take into account the changes I made to
patches earlier in the series.  Please find attached a new Patch 6/7,
which incorporates these minor adjustments.

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0006-system-Add-guix-system-docker-image-command.patch --]
[-- Type: text/x-patch, Size: 14006 bytes --]

From 1b325723f87ac09d4ac0b860f76982a07e14a985 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Tue, 20 Feb 2018 09:12:48 +0100
Subject: [PATCH 6/8] system: Add "guix system docker-image" command.

* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
---
 doc/guix.texi                         |  34 ++++++++--
 gnu/system/examples/docker-image.tmpl |  47 ++++++++++++++
 gnu/system/vm.scm                     | 114 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  10 ++-
 4 files changed, 198 insertions(+), 7 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 32e132d87..3a1708e54 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -19294,10 +19294,14 @@ size of the image.
 
 @item vm-image
 @itemx disk-image
-Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  By default, @command{guix system}
-estimates the size of the image needed to store the system, but you can
-use the @option{--image-size} option to specify a value.
+@itemx docker-image
+Return a virtual machine, disk image, or Docker image of the operating
+system declared in @var{file} that stands alone.  By default,
+@command{guix system} estimates the size of the image needed to store
+the system, but you can use the @option{--image-size} option to specify
+a value.  Docker images are built to contain exactly what they need, so
+the @option{--image-size} option is ignored in the case of
+@code{docker-image}.
 
 You can specify the root file system type by using the
 @option{--file-system-type} option.  It defaults to @code{ext4}.
@@ -19315,6 +19319,28 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+When using @code{docker-image}, a Docker image is produced.  Guix builds
+the image from scratch, not from a pre-existing Docker base image.  As a
+result, it contains @emph{exactly} what you define in the operating
+system configuration file.  You can then load the image and launch a
+Docker container using commands like the following:
+
+@example
+image_id="$(docker load < guixsd-docker-image.tar.gz)"
+docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
+    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
+    $image_id /var/guix/profiles/system/boot
+@end example
+
+This command starts a new Docker container from the specified image.  It
+will boot the GuixSD system in the usual manner, which means it will
+start any services you have defined in the operating system
+configuration.  Depending on what you run in the Docker container, it
+may be necessary to give the container additional permissions.  For
+example, if you intend to build software using Guix inside of the Docker
+container, you may need to pass the @option{--privileged} option to
+@code{docker-run}.
+
 @item container
 Return a script to run the operating system declared in @var{file}
 within a container.  Containers are a set of lightweight isolation
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
new file mode 100644
index 000000000..d73187398
--- /dev/null
+++ b/gnu/system/examples/docker-image.tmpl
@@ -0,0 +1,47 @@
+;; This is an operating system configuration template for a "Docker image"
+;; setup, so it has barely any services at all.
+
+(use-modules (gnu))
+
+(operating-system
+  (host-name "komputilo")
+  (timezone "Europe/Berlin")
+  (locale "en_US.utf8")
+
+  ;; This is where user accounts are specified.  The "root" account is
+  ;; implicit, and is initially created with the empty password.
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                (supplementary-groups '("wheel"
+                                        "audio" "video"))
+                (home-directory "/home/alice"))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages %base-packages)
+
+  ;; Because the system will run in a Docker container, we may omit many
+  ;; things that would normally be required in an operating system
+  ;; configuration file.  These things include:
+  ;;
+  ;;   * bootloader
+  ;;   * file-systems
+  ;;   * services such as mingetty, udevd, slim, networking, dhcp
+  ;;
+  ;; Either these things are simply not required, or Docker provides
+  ;; similar services for us.
+
+  ;; This will be ignored.
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target "does-not-matter")))
+  ;; This will be ignored, too.
+  (file-systems (list (file-system
+                        (device "does-not-matter")
+                        (mount-point "/")
+                        (type "does-not-matter"))))
+
+  ;; Guix is all you need!
+  (services (list (guix-service))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 345cecedd..e9a94019d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -22,6 +22,7 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
+  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -29,14 +30,18 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
 
   #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
+
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -73,6 +78,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -366,6 +372,114 @@ the image."
    #:disk-image-format disk-image-format
    #:references-graphs inputs))
 
+(define* (system-docker-image os
+                              #:key
+                              (name "guixsd-docker-image")
+                              register-closures?)
+  "Build a docker image.  OS is the desired <operating-system>.  NAME is the
+base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
+register the closure of OS with Guix in the resulting Docker image.  This only
+makes sense when you want to build a GuixSD Docker image that has Guix
+installed inside of it.  If you don't need Guix (e.g., your GuixSD Docker
+image just contains a web server that is started by Shepherd), then you should
+set REGISTER-CLOSURES? to #f."
+  (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 json
+    ;; Pick the guile-json package that corresponds to the Guile used to build
+    ;; derivations.
+    (if (string-prefix? "2.0" (package-version (default-guile)))
+        guile2.0-json
+        guile-json))
+
+  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
+                      (name -> (string-append name ".tar.gz"))
+                      (system-graph-name -> "system")
+                      ;; Use a Guile that supports dlopen because it needs to
+                      ;; dlopen libgcrypt in the initrd.  See:
+                      ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+                      (initrd (base-initrd %linux-vm-file-systems
+                                           #:virtio? #t
+                                           #:guile guile-2.2)))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (gnu build vm)
+                                                          (guix build utils)
+                                                          (guix build syscalls))
+                                                        #:select? not-config?)
+                               ((guix config) => ,config))
+        #~(begin
+            ;; Guile-JSON is required by (guix docker).
+            (add-to-load-path
+             (string-append #+json "/share/guile/site/"
+                            (effective-version)))
+            (use-modules (gnu build vm)
+                         (guix build utils)
+                         (guix build syscalls)
+                         (srfi srfi-26)
+                         (ice-9 match)
+                         (guix docker)
+                         (srfi srfi-19))
+
+            (let* ((inputs
+                    '#$(append (list tree parted e2fsprogs dosfstools tar)
+                               (map canonical-package
+                                    (list sed grep coreutils findutils gawk))
+                               (if register-closures? (list guix) '())))
+
+                   ;; This variable is unused but allows us to add INPUTS-TO-COPY
+                   ;; as inputs.
+                   (to-register '#$os-drv)
+                   (initialize (root-partition-initializer
+                                #:closures '(#$system-graph-name)
+                                #:register-closures? #$register-closures?
+                                #:system-directory #$os-drv
+                                ;; De-duplication would fail due to
+                                ;; cross-device link errors, so don't do it.
+                                #:deduplicate? #f))
+                   (root "/tmp/root"))
+
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir-p root)
+              (initialize root)
+              ;; Use a temporary directory inside xchg to avoid hitting space
+              ;; limitations in the initrd's root file system.
+              (let ((tmpdir "/xchg/tmp/docker-image"))
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 #$os-drv
+                 #:closure (string-append "/xchg/" #$system-graph-name)
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:tmpdir tmpdir
+                 #:extra-items-dir root))))))
+    (expression->derivation-in-linux-vm
+     name
+     build
+     #:initrd initrd
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,system-graph-name ,os-drv))
+     ;; Our larger initrd requires more memory.
+     #:memory-size 512)))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 999ffb010..20919d1b1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -670,7 +670,9 @@ procedure of its type."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -867,6 +869,8 @@ Some ACTIONS support additional ARGS.\n"))
    vm-image         build a freestanding virtual machine image\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
+  (display (G_ "\
+   docker-image     build a Docker image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1098,7 +1102,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1127,7 +1131,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 56%]

* [bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.
  @ 2018-02-26 16:25 85%       ` Chris Marusich
  0 siblings, 0 replies; 149+ results
From: Chris Marusich @ 2018-02-26 16:25 UTC (permalink / raw)
  To: Danny Milosavljevic; +Cc: 30572, Chris Marusich


[-- Attachment #1.1: Type: text/plain, Size: 693 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

>> +                      (zero? (apply system* "tar" "-C" extra-items-dir
>> +                                    "-rf" "layer.tar"
>> +                                    (append %tar-determinism-options
>> +                                            '("."))))))))
>
> -C is order-sensitive.  Apparently it still doesn't cause layer.tar
> to be created inside extra-items-dir (huh...), but for clarity, I'd prefer:
>
> tar -rf layer.tar -C extra-items-dir .

I didn't realize this was the case.  I agree it would be best to reverse
the order here.  I've attached a patch which does this.  How does it
look?

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0005-docker-Allow-the-addition-of-extra-files-into-the-im.patch --]
[-- Type: text/x-patch, Size: 2674 bytes --]

From 5a889e7d8dc6847c2d9a8ae526df7c974688a947 Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:53:16 +0100
Subject: [PATCH 5/8] docker: Allow the addition of extra files into the image.

* guix/docker.scm (build-docker-image): Add #:extra-items-dir keyword
  argument.
---
 guix/docker.scm | 17 ++++++++++++++---
 1 file changed, 14 insertions(+), 3 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 305e8273b..ef92714e0 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -107,7 +107,8 @@ return \"a\"."
                              (symlinks '())
                              (system (utsname:machine (uname)))
                              (creation-time (current-time time-utc))
-                             (tmpdir "/tmp/docker-image"))
+                             (tmpdir "/tmp/docker-image")
+                             extra-items-dir)
   "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
@@ -121,7 +122,12 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
 TMPDIR is the name of the temporary working directory to use.  This can be
 useful if you need to use a specific temporary directory, for example because
 the default temporary directory lies on a file system with insufficient
-space."
+space.
+
+EXTRA-ITEMS-DIR is the name of a directory containing extra files to add to
+the image; the entire directory tree rooted at EXTRA-ITEMS-DIR will be copied
+into the root directory of the image, so a file EXTRA-ITEMS-DIR/foo will wind
+up at /foo in the final Docker image."
   (let ((closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
@@ -166,7 +172,12 @@ space."
                                           (map symlink-source symlinks))))
                     (for-each delete-file-recursively
                               (map (compose topmost-component symlink-source)
-                                   symlinks)))))
+                                   symlinks))
+                    extra-items-dir
+                    (zero? (apply system* "tar" "-rf" "layer.tar"
+                                  "-C" extra-items-dir
+                                  (append %tar-determinism-options
+                                          '(".")))))))
 
            (with-output-to-file "config.json"
              (lambda ()
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 85%]

* [bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.
  @ 2018-02-26 16:23 83%       ` Chris Marusich
    0 siblings, 1 reply; 149+ results
From: Chris Marusich @ 2018-02-26 16:23 UTC (permalink / raw)
  To: Danny Milosavljevic; +Cc: 30572, Chris Marusich


[-- Attachment #1.1: Type: text/plain, Size: 308 bytes --]

Danny Milosavljevic <dannym@scratchpost.org> writes:

> Hmm, I have a slight preference for not magically adding "/docker-image" here
> but rather adding it in the caller and in the default.

Good idea.  Here's a new version of Patch 4/7 which does what you
suggest!  What do you think?

-- 
Chris

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0004-docker-Allow-the-use-of-a-custom-temporary-directory.patch --]
[-- Type: text/x-patch, Size: 3410 bytes --]

From dcb8dfd9c6c12f585ec9b64fb42489ce5b4fa9ae Mon Sep 17 00:00:00 2001
From: Chris Marusich <cmmarusich@gmail.com>
Date: Mon, 19 Feb 2018 05:45:03 +0100
Subject: [PATCH 4/8] docker: Allow the use of a custom temporary directory.

* guix/docker.scm: (build-docker-image): Add #:tmpdir keyword argument.
---
 guix/docker.scm | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..305e8273b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -106,7 +106,8 @@ return \"a\"."
                              #:key closure compressor
                              (symlinks '())
                              (system (utsname:machine (uname)))
-                             (creation-time (current-time time-utc)))
+                             (creation-time (current-time time-utc))
+                             (tmpdir "/tmp/docker-image"))
   "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
@@ -115,9 +116,13 @@ 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."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
-        (closure (canonicalize-path closure))
+CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
+
+TMPDIR is the name of the temporary working directory to use.  This can be
+useful if you need to use a specific temporary directory, for example because
+the default temporary directory lies on a file system with insufficient
+space."
+  (let ((closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
         (arch (let-syntax ((cond* (syntax-rules ()
@@ -133,9 +138,9 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
                        ("arm"    "arm")
                        ("mips64" "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
-    (mkdir directory)
+    (mkdir-p tmpdir)
 
-    (and (with-directory-excursion directory
+    (and (with-directory-excursion tmpdir
            (mkdir id)
            (with-directory-excursion id
              (with-output-to-file "VERSION"
@@ -174,10 +179,10 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
              (lambda ()
                (scm->json (repositories path id)))))
 
-         (and (zero? (apply system* "tar" "-C" directory "-cf" image
+         (and (zero? (apply system* "tar" "-C" tmpdir "-cf" image
                             `(,@%tar-determinism-options
                               ,@(if compressor
                                     (list "-I" (string-join compressor))
                                     '())
                               ".")))
-              (begin (delete-file-recursively directory) #t)))))
+              (begin (delete-file-recursively tmpdir) #t)))))
-- 
2.15.1


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[relevance 83%]

* [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command.
    2018-02-22 10:35 69%   ` [bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory Chris Marusich
  2018-02-22 10:35 67%   ` [bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image Chris Marusich
@ 2018-02-22 10:35 37%   ` Chris Marusich
  2018-02-26 16:30 56%     ` Chris Marusich
  2 siblings, 1 reply; 149+ results
From: Chris Marusich @ 2018-02-22 10:35 UTC (permalink / raw)
  To: 30572; +Cc: Chris Marusich

* gnu/system/vm.scm (system-docker-image): New procedure.
* guix/scripts/system.scm (system-derivation-for-action): Add a case for
  docker-image, and in that case, call system-docker-image.
  (show-help): Document docker-image.
  (guix-system): Parse arguments for docker-image.
* doc/guix.texi (Invoking guix system): Document "guix system docker-image".
* gnu/system/examples/docker-image.tmpl: New file.
---
 doc/guix.texi                         |  34 ++++++++--
 gnu/system/examples/docker-image.tmpl |  47 ++++++++++++++
 gnu/system/vm.scm                     | 116 ++++++++++++++++++++++++++++++++++
 guix/scripts/system.scm               |  10 ++-
 4 files changed, 200 insertions(+), 7 deletions(-)
 create mode 100644 gnu/system/examples/docker-image.tmpl

diff --git a/doc/guix.texi b/doc/guix.texi
index 5e8c27486..ea39642c9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -19282,10 +19282,14 @@ size of the image.
 
 @item vm-image
 @itemx disk-image
-Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  By default, @command{guix system}
-estimates the size of the image needed to store the system, but you can
-use the @option{--image-size} option to specify a value.
+@itemx docker-image
+Return a virtual machine, disk image, or Docker image of the operating
+system declared in @var{file} that stands alone.  By default,
+@command{guix system} estimates the size of the image needed to store
+the system, but you can use the @option{--image-size} option to specify
+a value.  Docker images are built to contain exactly what they need, so
+the @option{--image-size} option is ignored in the case of
+@code{docker-image}.
 
 You can specify the root file system type by using the
 @option{--file-system-type} option.  It defaults to @code{ext4}.
@@ -19303,6 +19307,28 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
+When using @code{docker-image}, a Docker image is produced.  Guix builds
+the image from scratch, not from a pre-existing Docker base image.  As a
+result, it contains @emph{exactly} what you define in the operating
+system configuration file.  You can then load the image and launch a
+Docker container using commands like the following:
+
+@example
+image_id="$(docker load < guixsd-docker-image.tar.gz)"
+docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\
+    --entrypoint /var/guix/profiles/system/profile/bin/guile \\
+    $image_id /var/guix/profiles/system/boot
+@end example
+
+This command starts a new Docker container from the specified image.  It
+will boot the GuixSD system in the usual manner, which means it will
+start any services you have defined in the operating system
+configuration.  Depending on what you run in the Docker container, it
+may be necessary to give the container additional permissions.  For
+example, if you intend to build software using Guix inside of the Docker
+container, you may need to pass the @option{--privileged} option to
+@code{docker-run}.
+
 @item container
 Return a script to run the operating system declared in @var{file}
 within a container.  Containers are a set of lightweight isolation
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl
new file mode 100644
index 000000000..d73187398
--- /dev/null
+++ b/gnu/system/examples/docker-image.tmpl
@@ -0,0 +1,47 @@
+;; This is an operating system configuration template for a "Docker image"
+;; setup, so it has barely any services at all.
+
+(use-modules (gnu))
+
+(operating-system
+  (host-name "komputilo")
+  (timezone "Europe/Berlin")
+  (locale "en_US.utf8")
+
+  ;; This is where user accounts are specified.  The "root" account is
+  ;; implicit, and is initially created with the empty password.
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                (supplementary-groups '("wheel"
+                                        "audio" "video"))
+                (home-directory "/home/alice"))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages %base-packages)
+
+  ;; Because the system will run in a Docker container, we may omit many
+  ;; things that would normally be required in an operating system
+  ;; configuration file.  These things include:
+  ;;
+  ;;   * bootloader
+  ;;   * file-systems
+  ;;   * services such as mingetty, udevd, slim, networking, dhcp
+  ;;
+  ;; Either these things are simply not required, or Docker provides
+  ;; similar services for us.
+
+  ;; This will be ignored.
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target "does-not-matter")))
+  ;; This will be ignored, too.
+  (file-systems (list (file-system
+                        (device "does-not-matter")
+                        (mount-point "/")
+                        (type "does-not-matter"))))
+
+  ;; Guix is all you need!
+  (services (list (guix-service))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 345cecedd..08f33b462 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -22,6 +22,7 @@
 
 (define-module (gnu system vm)
   #:use-module (guix config)
+  #:use-module (guix docker)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -29,14 +30,18 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix scripts pack)
   #:use-module (guix utils)
 
   #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
+
   #:use-module (gnu packages bootloaders)
   #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
   #:use-module (gnu packages gawk)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages less)
@@ -73,6 +78,7 @@
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image
+            system-docker-image
 
             virtual-machine
             virtual-machine?))
@@ -366,6 +372,116 @@ the image."
    #:disk-image-format disk-image-format
    #:references-graphs inputs))
 
+(define* (system-docker-image os
+                              #:key
+                              (name "guixsd-docker-image")
+                              register-closures?)
+  "Build a docker image.  OS is the desired <operating-system>.  NAME is the
+base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
+register the closure of OS with Guix in the resulting Docker image.  This only
+makes sense when you want to build a GuixSD Docker image that has Guix
+installed inside of it.  If you don't need Guix (e.g., your GuixSD Docker
+image just contains a web server that is started by Shepherd), then you should
+set REGISTER-CLOSURES? to #f."
+  (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 json
+    ;; Pick the guile-json package that corresponds to the Guile used to build
+    ;; derivations.
+    (if (string-prefix? "2.0" (package-version (default-guile)))
+        guile2.0-json
+        guile-json))
+
+  (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
+                      (name -> (string-append name ".tar.gz"))
+                      (system-graph-name -> "system")
+                      ;; Use a Guile that supports dlopen because it needs to
+                      ;; dlopen libgcrypt in the initrd.  See:
+                      ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html
+                      (initrd (base-initrd %linux-vm-file-systems
+                                           #:virtio? #t
+                                           #:guile guile-2.2)))
+    (define build
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (gnu build vm)
+                                                          (guix build utils)
+                                                          (guix build syscalls))
+                                                        #:select? not-config?)
+                               ((guix config) => ,config))
+        #~(begin
+            ;; Guile-JSON is required by (guix docker).
+            (add-to-load-path
+             (string-append #+json "/share/guile/site/"
+                            (effective-version)))
+            (use-modules (gnu build vm)
+                         (guix build utils)
+                         (guix build syscalls)
+                         (srfi srfi-26)
+                         (ice-9 match)
+                         (guix docker)
+                         (srfi srfi-19))
+
+            (let* ((inputs
+                    '#$(append (list tree parted e2fsprogs dosfstools tar)
+                               (map canonical-package
+                                    (list sed grep coreutils findutils gawk))
+                               (if register-closures? (list guix) '())))
+
+                   ;; This variable is unused but allows us to add INPUTS-TO-COPY
+                   ;; as inputs.
+                   (to-register '#$os-drv)
+                   (initialize (root-partition-initializer
+                                #:closures '(#$system-graph-name)
+                                #:register-closures? #$register-closures?
+                                #:system-directory #$os-drv
+                                ;; De-duplication would fail due to
+                                ;; cross-device link errors, so don't do it.
+                                #:deduplicate? #f))
+                   (root "/tmp/root"))
+
+              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+              (mkdir-p root)
+              (initialize root)
+              ;; Use a temporary directory inside xchg to avoid hitting space
+              ;; limitations in the initrd's root file system.
+              (let ((tmpdir "/xchg/tmp"))
+                (mkdir tmpdir)
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 #$os-drv
+                 #:closure (string-append "/xchg/" #$system-graph-name)
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:tmpdir tmpdir
+                 #:extra-items-dir root)
+                (delete-file-recursively tmpdir))))))
+    (expression->derivation-in-linux-vm
+     name
+     build
+     #:initrd initrd
+     #:make-disk-image? #f
+     #:single-file-output? #t
+     #:references-graphs `((,system-graph-name ,os-drv))
+     ;; Our larger initrd requires more memory.
+     #:memory-size 512)))
+
 \f
 ;;;
 ;;; VM and disk images.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 999ffb010..20919d1b1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -670,7 +670,9 @@ procedure of its type."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -867,6 +869,8 @@ Some ACTIONS support additional ARGS.\n"))
    vm-image         build a freestanding virtual machine image\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
+  (display (G_ "\
+   docker-image     build a Docker image\n"))
   (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
@@ -1098,7 +1102,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1127,7 +1131,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
-- 
2.15.1

^ permalink raw reply related	[relevance 37%]

* [bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory.
  @ 2018-02-22 10:35 69%   ` Chris Marusich
    2018-02-22 10:35 67%   ` [bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image Chris Marusich
  2018-02-22 10:35 37%   ` [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command Chris Marusich
  2 siblings, 1 reply; 149+ results
From: Chris Marusich @ 2018-02-22 10:35 UTC (permalink / raw)
  To: 30572; +Cc: Chris Marusich

* guix/docker.scm: (build-docker-image): Add #:tmpdir keyword argument.
---
 guix/docker.scm | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148..693b4426f 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -106,7 +106,8 @@ return \"a\"."
                              #:key closure compressor
                              (symlinks '())
                              (system (utsname:machine (uname)))
-                             (creation-time (current-time time-utc)))
+                             (creation-time (current-time time-utc))
+                             (tmpdir "/tmp"))
   "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
@@ -115,8 +116,13 @@ 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."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
+CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
+
+TMPDIR is the name of the temporary working directory to use.  This can be
+useful if you need to use a specific temporary directory, for example because
+the default temporary directory lies on a file system with insufficient
+space."
+  (let ((directory (string-append tmpdir "/docker-image")) ;temporary working directory
         (closure (canonicalize-path closure))
         (id (docker-id path))
         (time (date->string (time-utc->date creation-time) "~4"))
-- 
2.15.1

^ permalink raw reply related	[relevance 69%]

* [bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image.
    2018-02-22 10:35 69%   ` [bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory Chris Marusich
@ 2018-02-22 10:35 67%   ` Chris Marusich
    2018-02-22 10:35 37%   ` [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command Chris Marusich
  2 siblings, 1 reply; 149+ results
From: Chris Marusich @ 2018-02-22 10:35 UTC (permalink / raw)
  To: 30572; +Cc: Chris Marusich

* guix/docker.scm (build-docker-image): Add #:extra-items-dir keyword
  argument.
---
 guix/docker.scm | 21 ++++++++++++++++-----
 1 file changed, 16 insertions(+), 5 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 693b4426f..1b9b36a3b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -107,7 +107,8 @@ return \"a\"."
                              (symlinks '())
                              (system (utsname:machine (uname)))
                              (creation-time (current-time time-utc))
-                             (tmpdir "/tmp"))
+                             (tmpdir "/tmp")
+                             extra-items-dir)
   "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
@@ -121,7 +122,12 @@ CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata.
 TMPDIR is the name of the temporary working directory to use.  This can be
 useful if you need to use a specific temporary directory, for example because
 the default temporary directory lies on a file system with insufficient
-space."
+space.
+
+EXTRA-ITEMS-DIR is the name of a directory containing extra files to add to
+the image; the entire directory tree rooted at EXTRA-ITEMS-DIR will be copied
+into the root directory of the image, so a file EXTRA-ITEMS-DIR/foo will wind
+up at /foo in the final Docker image."
   (let ((directory (string-append tmpdir "/docker-image")) ;temporary working directory
         (closure (canonicalize-path closure))
         (id (docker-id path))
@@ -165,9 +171,14 @@ space."
                                   (append %tar-determinism-options
                                           items
                                           (map symlink-source symlinks))))
-                    (for-each delete-file-recursively
-                              (map (compose topmost-component symlink-source)
-                                   symlinks)))))
+                    (begin
+                      (for-each delete-file-recursively
+                                (map (compose topmost-component symlink-source)
+                                     symlinks))
+                      (zero? (apply system* "tar" "-C" extra-items-dir
+                                    "-rf" "layer.tar"
+                                    (append %tar-determinism-options
+                                            '("."))))))))
 
            (with-output-to-file "config.json"
              (lambda ()
-- 
2.15.1

^ permalink raw reply related	[relevance 67%]

Results 1-149 of 149 | reverse | options above
-- pct% links below jump to the message on this page, permalinks otherwise --
2018-02-22 10:29     [bug#30572] [PATCH 0/7] Add "guix system docker-image" command Chris Marusich
2018-03-15  4:09     ` [bug#30572] [PATCH 0/7] Add "guix system docker-image" command (v2) Chris Marusich
2018-03-15  4:09 40%   ` [bug#30572] [PATCH 5/7] guix: Rewrite build-docker-image to allow more paths Chris Marusich
2018-03-15  4:09 35%   ` [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command Chris Marusich
2018-03-17 21:56         ` Ludovic Courtès
2018-03-21  3:58           ` Chris Marusich
2018-03-21  4:25 54%         ` Chris Marusich
     [not found]     <handler.30572.B.151929540925748.ack@debbugs.gnu.org>
2018-02-22 10:35     ` [bug#30572] [PATCH 1/7] tests: Add tests for "guix pack" Chris Marusich
2018-02-22 10:35 69%   ` [bug#30572] [PATCH 4/7] docker: Allow the use of a custom temporary directory Chris Marusich
2018-02-26  0:48         ` Danny Milosavljevic
2018-02-26 16:23 83%       ` Chris Marusich
2018-02-26 23:46             ` Danny Milosavljevic
2018-02-27  4:43 83%           ` Chris Marusich
2018-02-22 10:35 67%   ` [bug#30572] [PATCH 5/7] docker: Allow the addition of extra files into the image Chris Marusich
2018-02-25 23:36         ` Danny Milosavljevic
2018-02-26 16:25 85%       ` Chris Marusich
2018-02-22 10:35 37%   ` [bug#30572] [PATCH 6/7] system: Add "guix system docker-image" command Chris Marusich
2018-02-26 16:30 56%     ` Chris Marusich
2018-05-28 21:59     [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
2018-05-28 21:59 64% ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès
2018-07-24 18:48     [bug#32263] [PATCH 0/8] Add fdroidserver Efraim Flashner
2018-07-24 18:51 69% ` [bug#32263] [PATCH 1/8] gnu: Add python-docker-pycreds Efraim Flashner
2018-07-24 18:51 72%   ` [bug#32263] [PATCH 7/8] gnu: python-docker-py: Update to 1.10.6 Efraim Flashner
2018-09-01 22:25     [bug#32606] [PATCH 0/1] Switch to Guile-Gcrypt Ludovic Courtès
2018-09-01 22:26  9% ` [bug#32606] [PATCH 1/1] " Ludovic Courtès
2018-11-04 22:10     [bug#33259] [PATCH 1/8] pack: Move store database creation to a separate derivation Ludovic Courtès
2018-11-04 22:10 51% ` [bug#33259] [PATCH 4/8] pack: Docker backend now honors '--localstatedir' Ludovic Courtès
2018-12-28 10:13     [bug#33893] [PATCH 0/2] Add docker Danny Milosavljevic
2018-12-28 10:17 60% ` [bug#33893] [PATCH 1/2] gnu: Add docker-engine Danny Milosavljevic
2018-12-28 10:17 65%   ` [bug#33893] [PATCH 2/2] gnu: Add docker-cli Danny Milosavljevic
2018-12-29  1:32     ` [bug#33893] [PATCH v2 0/3] Add docker Danny Milosavljevic
2018-12-29  1:32 67%   ` [bug#33893] [PATCH v2 1/3] gnu: Add containerd Danny Milosavljevic
2018-12-29  1:32 53%   ` [bug#33893] [PATCH v2 2/3] gnu: Add docker-engine Danny Milosavljevic
2018-12-29  1:32 60%   ` [bug#33893] [PATCH v2 3/3] services: Add docker Danny Milosavljevic
2018-12-29  1:39       ` [bug#33893] [PATCH v3 0/4] " Danny Milosavljevic
2018-12-29  1:39 67%     ` [bug#33893] [PATCH v3 1/4] gnu: Add containerd Danny Milosavljevic
2018-12-29  1:39 53%     ` [bug#33893] [PATCH v3 2/4] gnu: Add docker-engine Danny Milosavljevic
2018-12-29  1:39 60%     ` [bug#33893] [PATCH v3 3/4] services: Add docker Danny Milosavljevic
2018-12-30  9:50 92%       ` Danny Milosavljevic
2018-12-29  1:39 65%     ` [bug#33893] [PATCH v3 4/4] gnu: Add docker-cli Danny Milosavljevic
2018-12-30 12:17         ` [bug#33893] [PATCH v4 0/4] Add docker Danny Milosavljevic
2018-12-30 12:17 67%       ` [bug#33893] [PATCH v4 1/4] gnu: Add containerd Danny Milosavljevic
2018-12-30 12:17 53%       ` [bug#33893] [PATCH v4 2/4] gnu: Add docker-engine Danny Milosavljevic
2018-12-30 12:17 57%       ` [bug#33893] [PATCH v4 3/4] services: Add docker Danny Milosavljevic
2018-12-30 12:17 65%       ` [bug#33893] [PATCH v4 4/4] gnu: Add docker-cli Danny Milosavljevic
2018-12-30 23:38           ` [bug#33893] [PATCH v5 0/4] Add docker Danny Milosavljevic
2018-12-30 23:39 64%         ` [bug#33893] [PATCH v5 1/4] gnu: Add containerd Danny Milosavljevic
2018-12-30 23:39 51%         ` [bug#33893] [PATCH v5 2/4] gnu: Add docker-engine Danny Milosavljevic
2018-12-30 23:39 57%         ` [bug#33893] [PATCH v5 3/4] services: Add docker Danny Milosavljevic
2018-12-30 23:39 65%         ` [bug#33893] [PATCH v5 4/4] gnu: Add docker-cli Danny Milosavljevic
2019-01-10 21:58 88% [bug#34039] [WIP] tests: Make docker system test more comprehensive Danny Milosavljevic
2019-01-14 14:35 80% [bug#34071] [PATCH] tests: docker: Run a guest guile inside the docker container Danny Milosavljevic
2019-01-14 14:46 60% ` [bug#34071] [PATCH v2] " Danny Milosavljevic
2019-01-14 16:32 61%   ` [bug#34071] [PATCH v3] " Danny Milosavljevic
2019-01-18  5:31 69% [bug#34120] [PATCH] gnu: Add cqfd Maxim Cournoyer
2019-02-12  0:27     [bug#34446] [PATCH 1/2] gnu: runc: Update to 1.0.0-rc6 [fixes CVE-2019-5736] Leo Famulari
2019-02-12  0:27 72% ` [bug#34446] [PATCH 2/2] gnu: Docker: Update to 18.09.2 Leo Famulari
2019-03-19 18:20 93% [bug#34917] [PATCH] gnu: docker: Use fewer modprobes Danny Milosavljevic
2019-03-19 18:26 71% ` [bug#34917] [PATCH v2] " Danny Milosavljevic
2019-03-22 17:27     [bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record' Ludovic Courtès
2019-03-22 17:27 45% ` [bug#34948] [PATCH 2/3] accounts: Add default value for the 'home-directory' field of <user-account> Ludovic Courtès
2019-04-11 14:36 89% [bug#35229] [PATCH] gnu: docker: Check for error on XFRM Danny Milosavljevic
2019-04-14 23:02 88% [bug#35281] [PATCH] gnu: docker: Add a couple go dependencies and enable docker-proxy Maxim Cournoyer
2019-04-15  0:12 81% [bug#35282] [PATCH] gnu: docker: Patch paths of xz and docker-proxy Maxim Cournoyer
2019-04-15  5:56     ` Danny Milosavljevic
2019-04-15 20:19 98%   ` [bug#35282] [PATCHv2] " Maxim Cournoyer
2019-05-12 10:37     [bug#35697] [PATCH 1/8] system: Export 'operating-system-default-essential-services' Ludovic Courtès
2019-05-12 10:38 65% ` [bug#35697] [PATCH 7/8] docker: 'build-docker-image' accepts an optional #:entry-point Ludovic Courtès
2019-05-12 10:38 45% ` [bug#35697] [PATCH 8/8] vm: 'system-docker-image' provides an entry point Ludovic Courtès
2019-06-04 20:51     [bug#36093] [PATCH 0/2] 'guix pack --entry-point' and Singularity service Ludovic Courtès
2019-06-04 21:01 43% ` [bug#36093] [PATCH 1/2] services: Add Singularity Ludovic Courtès
2019-06-04 21:01 47%   ` [bug#36093] [PATCH 2/2] pack: Add '--entry-point' Ludovic Courtès
2019-06-05 20:27     Ludovic Courtès
2019-06-06 11:03 43% ` [bug#36093] [PATCH v2 1/2] services: Add Singularity Ludovic Courtès
2019-06-06 11:03 47%   ` [bug#36093] [PATCH v2 2/2] pack: Add '--entry-point' Ludovic Courtès
2019-07-02  8:37     [bug#36469] [PATCH 0/2] 'guix pack' records environment variables Ludovic Courtès
2019-07-02  8:56 73% ` [bug#36469] [PATCH 1/2] pack: 'docker' backend records the profile's search paths Ludovic Courtès
2019-07-11 20:48     [bug#36608] [PATCH] Update docker-compose to 1.24.1 Jacob MacDonald
2019-07-11 20:51 72% ` [bug#36608] [PATCH 6/9] " Jacob MacDonald
2019-07-11 20:51 72% ` [bug#36608] [PATCH 7/9] " Jacob MacDonald
2019-07-11 20:52 70% ` [bug#36608] [PATCH 8/9] " Jacob MacDonald
2019-07-11 20:52 71% ` [bug#36608] [PATCH 9/9] " Jacob MacDonald
2019-07-22 10:13     [bug#36760] [PATCH 0/3] Switch to Guile-JSON 3.x Ludovic Courtès
2019-07-22 10:18 24% ` [bug#36760] [PATCH 1/3] maint: " Ludovic Courtès
2019-08-30 14:25     [bug#37234] [PATCH 01/21] gnu: Add python-gunicorn Marius Bakke
2019-08-30 14:25 72% ` [bug#37234] [PATCH 06/21] gnu: python-docker-py: Propagate runtime dependency Marius Bakke
2019-09-01  9:44 99% [bug#37250] [PATCH] gnu: docker: Add support for tini Maxim Cournoyer
2019-09-13 15:43     [bug#37401] [PATCH 0/2] 'guix pack -f docker' uses a meaningful "repository name" Ludovic Courtès
2019-09-13 15:51 55% ` [bug#37401] [PATCH 1/2] pack: Provide a meaningful "repository name" for Docker Ludovic Courtès
2020-01-03  1:33     [bug#38885] [WIP 0/4] Update docker Danny Milosavljevic
2020-01-03  1:34     ` [bug#38885] [WIP 1/4] gnu: Add go-golang.org-x-sync-errgroup Danny Milosavljevic
2020-01-03  1:34 75%   ` [bug#38885] [WIP 4/4] gnu: docker: Update to 19.03.5 Danny Milosavljevic
2020-02-12 20:33 65% [bug#39581] [PATCH] gnu: containerd: Fix test failure with Go 1.13 Jack Hill
2020-03-19 18:54 80% [bug#40136] [PATCH] * gnu/packages/docker.scm (docker-compose): update to 1.25.4 Michael Rohleder
2020-04-26 15:58 70% [bug#40871] [PATCH] file-systems: mount the PID cgroup filesystem Jakub Kądziołka
2020-06-03 23:36     [bug#41695] [PATCH] Update Go to v1.14.4 Katherine Cox-Buday
2020-06-05 21:07     ` Jack Hill
2020-06-06 19:13 72%   ` Katherine Cox-Buday
2020-08-16  8:06     [bug#42886] [PATCH 0/1] Need a way to disable iptables for dockerd Alexey Abramov
2020-08-16  8:09 72% ` [bug#42886] [PATCH 1/1] services: docker: Add 'enable-iptables?' argument Alexey Abramov
2021-04-14 17:06     [bug#44700] services: setuid: More configurable setuid support Christopher Lemmer Webber
2021-07-03 16:51 45% ` [bug#44700] [PATCH v2 2/2] services: Migrate to <setuid-program> Brice Waegeneire
2021-06-21  6:11     [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-21  6:12 44% ` [bug#49149] [PATCH 2/7] pack: Factorize base tar options Maxim Cournoyer
2021-06-23 10:22     [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names Maxime Devos
2021-06-24  4:40     ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-24  4:40 44%   ` [bug#49149] [PATCH v2 2/7] pack: Factorize base tar options Maxim Cournoyer
2021-06-24  4:40       ` [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
2021-06-30 10:13         ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Ludovic Courtès
2021-06-30 18:36           ` Maxim Cournoyer
2021-07-01 13:26             ` Ludovic Courtès
2021-07-04  3:21 84%           ` Maxim Cournoyer
2021-07-05 15:28     [bug#44700] [PATCH v2 2/2] services: Migrate to <setuid-program> Chris Lemmer-Webber
2021-07-06 20:03 40% ` [bug#44700] [PATCH v3 " Brice Waegeneire
2021-08-27 15:10     [bug#50227] [PATCH 0/3] go-build-system and GOPATH improvements Marius Bakke
2021-08-27 16:44 47% ` [bug#50227] [PATCH] build-system/go: Trim store references using the native compiler option Marius Bakke
2021-08-27 17:47       ` Marius Bakke
2021-08-27 19:38 63%     ` Marius Bakke
2021-10-20 14:59 72% [bug#51306] [PATCH] gnu: docker-compose: Update to 1.29.2 Olivier Dion via Guix-patches via
2021-11-04  6:48 70% [bug#51597] [PATCH] services: docker: Add 'environment-variables' configuration field Alexey Abramov via Guix-patches via
2021-11-19 21:01     [bug#51984] [PATCH 0/1] guix: Enable arm64 docker image building for 'guix pack' Collin J. Doering
2021-11-19 21:12 72% ` [bug#51984] [PATCH 1/1] " Collin J. Doering
2021-12-16 13:06     [bug#52550] [PATCH 01/10] build: image: Add optional closure copy support Mathieu Othacehe
2021-12-16 13:06 59% ` [bug#52550] [PATCH 10/10] tests: docker: Fix it Mathieu Othacehe
2021-12-25 14:17     [bug#52790] [PATCH 0/4] Update docker to 20.10.11 Pierre Langlois
2021-12-25 14:40 92% ` [bug#52790] [PATCH 1/4] gnu: containerd: Fix patch-paths build phase Pierre Langlois
2021-12-25 14:40 92%   ` [bug#52790] [PATCH 2/4] gnu: containerd: Update to 1.5.8 Pierre Langlois
2021-12-25 14:40 83%   ` [bug#52790] [PATCH 4/4] gnu: docker: Update to 20.10.11 Pierre Langlois
2022-04-01  0:46     [bug#52790] [PATCH v2 0/7] Update docker to 20.10.14 Pierre Langlois
2022-04-01  0:46 92% ` [bug#52790] [PATCH v2 2/7] gnu: containerd: Fix patch-paths build phase Pierre Langlois
2022-04-01  0:46 90% ` [bug#52790] [PATCH v2 3/7] gnu: containerd: Update to 1.6.2 Pierre Langlois
2022-04-01  0:46 80% ` [bug#52790] [PATCH v2 4/7] gnu: containerd: Switch to gexp arguments Pierre Langlois
2022-04-01  0:46 92% ` [bug#52790] [PATCH v2 5/7] gnu: docker: Fix mkfs.xfs reference Pierre Langlois
2022-04-01  0:46 83% ` [bug#52790] [PATCH v2 6/7] gnu: docker: Update to 20.10.14 Pierre Langlois
2022-04-01  1:11 70%   ` Pierre Langlois
2022-04-01  0:46 51% ` [bug#52790] [PATCH v2 7/7] gnu: docker: Switch to gexp and new input style Pierre Langlois
2022-04-11 22:28 65% [bug#54866] [PATCH] docker-compose, python-pyyaml daniel.herzig
2022-04-14 11:10     [bug#54934] [PATCH 1/4] gnu: python-pyyaml-for-awscli: Rename and hide zimoun
2022-04-14 11:10 72% ` [bug#54934] [PATCH 2/4] gnu: docker-compose: Use python-pyyaml@5 zimoun
2022-05-09 23:27     [bug#52790] [PATCH v3 0/7] Update docker to 20.10.15 Pierre Langlois
2022-05-09 23:35     ` [bug#52790] [PATCH v3 1/7] gnu: runc: Update to 1.1.1 Pierre Langlois
2022-05-09 23:35 92%   ` [bug#52790] [PATCH v3 2/7] gnu: containerd: Fix patch-paths build phase Pierre Langlois
2022-05-09 23:35 90%   ` [bug#52790] [PATCH v3 3/7] gnu: containerd: Update to 1.6.4 Pierre Langlois
2022-05-09 23:35 80%   ` [bug#52790] [PATCH v3 4/7] gnu: containerd: Switch to gexp arguments Pierre Langlois
2022-05-09 23:35 92%   ` [bug#52790] [PATCH v3 5/7] gnu: docker: Fix mkfs.xfs reference Pierre Langlois
2022-05-09 23:35 83%   ` [bug#52790] [PATCH v3 6/7] gnu: docker: Update to 20.10.15 Pierre Langlois
2022-05-09 23:35 51%   ` [bug#52790] [PATCH v3 7/7] gnu: docker: Switch to gexp and new input style Pierre Langlois
2022-09-27 17:16 56% [bug#58123] [PATCH] gnu: services: docker: Add docker-container-service-type guix-patches--- via
2022-10-02 20:38 59% ` [bug#58123] guix-patches--- via
2023-01-13  4:59 63% [bug#60770] [PATCH v1] gnu: Add docker-registry Denis 'GNUtoo' Carikli
2023-01-14 18:26 63% ` [bug#60770] [PATCH v2] " Denis 'GNUtoo' Carikli
2023-02-21 23:31 46% [bug#61692] [PATCH] services: dbus-service: Deprecate 'dbus-service' procedure Bruno Victal
2023-02-25 18:53     [bug#61789] [PATCH 00/27] Deprecate old-style services Bruno Victal
2023-02-25 18:58 60% ` [bug#61789] [PATCH 18/27] services: dbus: Deprecate 'polkit-service' procedure Bruno Victal
2023-02-25 18:58 47% ` [bug#61789] [PATCH 27/27] services: dbus: Deprecate 'dbus-service' procedure Bruno Victal
2023-03-13  0:30     [bug#62153] [PATCH 0/2] Add Docker layered image for pack and system Oleg Pykhalov
2023-03-13  0:33 28% ` [bug#62153] [PATCH 1/2] guix: docker: Build layered image Oleg Pykhalov
2023-03-13 21:09     [bug#62153] [PATCH 2/2] news: Add entry for the new 'docker-layered' distribution format pelzflorian (Florian Pelz)
2023-03-14  0:24     ` [bug#62153] [PATCH 0/2] Add Docker layered image for pack and system (v2) Oleg Pykhalov
2023-03-14  0:24 27%   ` [bug#62153] [PATCH 1/2] guix: docker: Build layered image Oleg Pykhalov
2023-04-08 15:09     [bug#62726] services: Activate `setuid-program-service-type' in shepherd Brian Cully via Guix-patches via
2023-04-08 15:16 45% ` [bug#62726] [PATCH] " Brian Cully via Guix-patches via
2023-06-07 12:59 40% ` [bug#62726] [PATCH v2] " Brian Cully via Guix-patches via
2023-05-31  8:45     [bug#62153] [PATCH] Add Docker layered image for pack and system (v3) Oleg Pykhalov
2023-05-31  8:47 35% ` [bug#62153] [PATCH] guix: docker: Build layered image Oleg Pykhalov
2023-06-03 19:10     [bug#62153] [PATCH 0/2] Add Docker layered image for pack and system Oleg Pykhalov
2023-06-03 19:14 35% ` [bug#62153] [PATCH v4 1/2] guix: docker: Build layered image Oleg Pykhalov
2023-07-28  3:11     [bug#64910] [PATCH 0/3] gnu: docker: Update to 20.10.25 Hilton Chain via Guix-patches via
2023-07-28  3:13 72% ` [bug#64910] [PATCH 2/3] gnu: containerd: Update to 1.6.22 Hilton Chain via Guix-patches via
2023-07-28  3:13 67% ` [bug#64910] [PATCH 3/3] gnu: docker: Update to 20.10.25 Hilton Chain via Guix-patches via
2023-08-11 10:45     [bug#64910] [PATCH v2 0/3] " Hilton Chain via Guix-patches via
2023-08-11 10:46 72% ` [bug#64910] [PATCH v2 2/3] gnu: containerd: Update to 1.6.22 Hilton Chain via Guix-patches via
2023-08-11 10:46 67% ` [bug#64910] [PATCH v2 3/3] gnu: docker: Update to 20.10.25 Hilton Chain via Guix-patches via
2023-09-22 20:32     [bug#66160] [PATCH] gnu: Add oci-container-service-type paul via Guix-patches via
2023-09-22 20:34 45% ` Giacomo Leidi via Guix-patches via
2023-10-06 19:09 41% ` Giacomo Leidi via Guix-patches via
2023-10-13 22:57 40% ` Giacomo Leidi via Guix-patches via
2023-10-14 21:36 36% ` Giacomo Leidi via Guix-patches via
2023-10-14 21:47 36% ` Giacomo Leidi via Guix-patches via
2023-10-24 20:59 34% ` [bug#66160] [PATCH v2] " Giacomo Leidi via Guix-patches via
2023-12-01 22:38     [bug#67574] oci-container-service: hotfix paul via Guix-patches via
2023-12-01 22:45 72% ` [bug#67574] [PATCH] services: Fix oci-container-service-type container user Giacomo Leidi via Guix-patches via
2023-12-03 21:53     [bug#67613] Introduce unit tests for oci-container-service-type paul via Guix-patches via
2023-12-03 21:56 70% ` [bug#67613] [PATCH] tests: Add oci-container-service-type unit tests Giacomo Leidi via Guix-patches via
2024-01-11 20:39 50% ` [bug#67613] [PATCH v2 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
2024-01-11 20:39 63%   ` [bug#67613] [PATCH v2 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
2024-01-11 20:39 70%   ` [bug#67613] [PATCH v2 3/5] gnu: docker: Allow setting Shepherd dependencies " Giacomo Leidi via Guix-patches via
2024-01-11 20:39 39%   ` [bug#67613] [PATCH v2 4/5] gnu: docker: Allow passing tarballs for images " Giacomo Leidi via Guix-patches via
2024-01-11 20:39 60%   ` [bug#67613] [PATCH v2 5/5] gnu: Add tests and documentation for oci-container-service-type Giacomo Leidi via Guix-patches via
2024-05-03 22:11 45% ` [bug#67613] [PATCH v3 1/5] gnu: docker: Provide escape hatch in oci-container-configuration Giacomo Leidi via Guix-patches via
2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 2/5] gnu: docker: Allow setting host environment variables " Giacomo Leidi via Guix-patches via
2024-05-03 22:11 67%   ` [bug#67613] [PATCH v3 3/5] gnu: docker: Allow setting Shepherd dependencies " Giacomo Leidi via Guix-patches via
2024-05-03 22:11 34%   ` [bug#67613] [PATCH v3 4/5] gnu: docker: Allow passing tarballs for images " Giacomo Leidi via Guix-patches via
2024-05-03 22:11 57%   ` [bug#67613] [PATCH v3 5/5] gnu: Add tests for oci-container-service-type Giacomo Leidi via Guix-patches via
2023-12-26  2:15     [bug#62153] [PATCH v5 0/5] Add Docker layered image for pack and system Oleg Pykhalov
2023-12-26  2:18 72% ` [bug#62153] [PATCH 2/5] tests: docker-system: Increase image size Oleg Pykhalov
2023-12-26  2:18 37% ` [bug#62153] [PATCH 3/5] guix: docker: Build layered images Oleg Pykhalov
2023-12-27 20:20 66% [bug#68073] [PATCH] Add config-file configuration option to dockerd Connor Clark via Guix-patches via
2023-12-29  4:47 66% ` [bug#68073] [PATCH v2] services: docker: Add config-file option Connor Clark via Guix-patches via
2024-01-04  6:51 69% [bug#68240] [PATCH] gnu: docker: Update to 20.10.27 Christian Miller via Guix-patches via
2024-02-11 10:36     [bug#69042] [PATCH 00/30] Split (gnu packages golang) part IV Sharlatan Hellseher
2024-02-11 10:52 42% ` [bug#69042] [PATCH 06/30] gnu: go-golang-org-x-sys: Move to (gnu packages golang-build) Sharlatan Hellseher
2024-02-12 18:48     [bug#69042] [PATCH v2 01/30] gnu: Add (gnu packages golang-build) module Sharlatan Hellseher
2024-02-12 18:48 42% ` [bug#69042] [PATCH v2 06/30] gnu: go-golang-org-x-sys: Move to golang-build Sharlatan Hellseher
2024-04-07 20:54     [bug#70265] Add docker cli Guix Home service and some docker authentication plugins paul via Guix-patches via
2024-04-07 20:57 56% ` [bug#70265] [PATCH 1/3] gnu: Add docker-credential-secretservice Giacomo Leidi via Guix-patches via
2024-05-03 16:55     [bug#70739] [PATCH 001/714] gnu: python-transient: Remove python-black native-input Nicolas Graves via Guix-patches via
2024-05-03 16:55 72% ` [bug#70739] [PATCH 047/714] gnu: python-docker-pycreds: Remove python-flake8 native-input Nicolas Graves via Guix-patches via
2024-05-03 22:18     [bug#70735] [PATCH 001/714] gnu: python-transient: Remove python-black native-input Nicolas Graves via Guix-patches via
2024-05-03 22:18 72% ` [bug#70735] [PATCH 047/714] gnu: python-docker-pycreds: Remove python-flake8 native-input Nicolas Graves via Guix-patches via
2024-05-09 22:52     [bug#70855] [PATCH 01/92] gnu: python-seaborn: Correct dependencies Nicolas Graves via Guix-patches via
2024-05-09 22:53 67% ` [bug#70855] [PATCH 12/92] gnu: python-docker-pycreds: Move to pyproject-build-system Nicolas Graves via Guix-patches via
2024-05-29  4:17 72% [bug#71254] [PATCH] services: oci-container: fix provided image is string Zheng Junjie
2024-05-29 21:38     [bug#71263] [PATCH 1/5] doc: Minor changes to the OCI-backed Services documentation Giacomo Leidi via Guix-patches via
2024-05-29 21:38 60% ` [bug#71263] [PATCH 2/5] gnu: docker: Allow setting Shepherd log-file in oci-container-configuration Giacomo Leidi via Guix-patches via
2024-05-29 21:38 64% ` [bug#71263] [PATCH 3/5] gnu: docker: Allow setting Shepherd auto-start? " Giacomo Leidi via Guix-patches via
2024-05-29 21:38 65% ` [bug#71263] [PATCH 4/5] gnu: docker: Allow setting Shepherd respawn? " Giacomo Leidi via Guix-patches via
2024-05-29 21:38 62% ` [bug#71263] [PATCH 5/5] gnu: docker: Allow setting Shepherd actions " Giacomo Leidi via Guix-patches via
2024-06-02 13:04     [bug#71324] [PATCH] services: containerd: Provision separately from docker service Oleg Pykhalov
2024-06-02 13:15 67% ` Oleg Pykhalov
2024-06-03 15:17     [bug#71324] [PATCH] news: Add entry for 'docker-service-type' changes pelzflorian (Florian Pelz)
2024-06-03 22:30 65% ` [bug#71324] [PATCH 1/2] services: containerd: Provision separately from docker service Oleg Pykhalov

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).