;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; 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>
;;; Copyright © 2022 Maya Tomasek <maya.omase@disroot.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 setuid)
  #: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-container-configuration
            docker-container-service-type
            singularity-service-type))

(define-configuration docker-configuration
  (docker
   (file-like docker)
   "Docker daemon package.")
  (docker-cli
   (file-like docker-cli)
   "Docker client package.")
  (containerd
   (file-like containerd)
   "containerd package.")
  (proxy
   (file-like 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).")
  (debug?
   (boolean #f)
   "Enable or disable debug output.")
  (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
  (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))))

(define (containerd-shepherd-service config)
  (let* ((package (docker-configuration-containerd 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)))))

(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))
         (environment-variables (docker-configuration-environment-variables config))
         (proxy (docker-configuration-proxy config))
         (debug? (docker-configuration-debug? config)))
    (shepherd-service
           (documentation "Docker daemon.")
           (provision '(dockerd))
           (requirement '(containerd
                          dbus-system
                          elogind
                          file-system-/sys/fs/cgroup/blkio
                          file-system-/sys/fs/cgroup/cpu
                          file-system-/sys/fs/cgroup/cpuset
                          file-system-/sys/fs/cgroup/devices
                          file-system-/sys/fs/cgroup/memory
                          file-system-/sys/fs/cgroup/pids
                          networking
                          udev))
           (start #~(make-forkexec-constructor
                     (list (string-append #$docker "/bin/dockerd")
                           "-p" "/var/run/docker.pid"
                           #$@(if debug?
                                  '("--debug" "--log-level=debug")
                                  '())
                           #$@(if enable-proxy?
                                  (list "--userland-proxy=true"
                                        #~(string-append
                                           "--userland-proxy-path=" #$proxy "/bin/proxy"))
                                  '("--userland-proxy=false"))
                           (if #$enable-iptables?
                               "--iptables"
                               "--iptables=false")
                           "--containerd" "/run/containerd/containerd.sock")
                     #:environment-variables
                     (list #$@environment-variables)
                     #:pid-file "/var/run/docker.pid"
                     #:log-file "/var/log/docker.log"))
           (stop #~(make-kill-destructor)))))

(define docker-service-type
  (service-type (name 'docker)
                (description "Provide capability to run Docker application
bundles in Docker containers.")
                (extensions
                 (list
                  ;; Make sure the 'docker' command is available.
                  (service-extension profile-service-type
                                     (compose list docker-configuration-docker-cli))
                  (service-extension activation-service-type
                                     %docker-activation)
                  (service-extension shepherd-root-service-type
                                     (lambda (config)
                                       (list (containerd-shepherd-service config)
                                             (docker-shepherd-service config))))
                  (service-extension account-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.
;;;

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

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