[bug#58123]

[guix-patches--- via <guix-patches@gnu.org>]

[-- 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