(define-module (tw services docker)
  #:use-module ((gnu packages docker) #:select (docker-cli))
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (every append-map concatenate))
  #:use-module ((srfi srfi-26) #:select (cut))
  #:export (docker-container-service-type
            docker-container-configuration))

(define-maybe/no-serialization string)

(define docker-volume?
  (match-lambda
    (((? string? host-path)
      (? string? container-path))
     #t)
    (((? string? host-path)
      (? string? container-path)
      (? boolean? read-write?))
     #t)
    (_ #f)))

(define (list-of-volumes? thing)
  (and (list? thing)
       (every docker-volume? thing)))

(define (list-of-files? thing)
  (and (list? thing)
       (every (lambda (item)
                (or (string? item) (file-like? item)))
              thing)))

(define-configuration/no-serialization docker-container-configuration
  (name maybe-string "The name to assign to the running container, if given.")
  (user maybe-string "The user to run the container as.")
  (image string "The Docker image to run.")
  (volumes (list-of-volumes '()) "A list of Docker volumes to mount in the
container. Each volume is given as a list containing the path on the host (or
volume name), the path in the container and an optional boolean (defaulting to
false) specifying whether to allow the container write access to the given
volume.")
  (environment-variables (list-of-strings '()) "A list of
@code{VARIABLE=value} strings specifying environment variables to set inside
the container.  Warning: it is not safe to pass secrets using this method; use
@code{environment-files} instead!")
  (environment-files (list-of-files '()) "A list of files containing
environment variable assignments, to be applied inside the container.")
  (network-type (string "none") "Allow the container to connect to the network?")
  (read-only-root? (boolean #t) "Run the container with a read-only root file system?")
  (remove-after-stop? (boolean #t) "Delete the container once it has stopped?
Enable this if you set a @code{name} to avoid blocking the name for the
following run.")
  (docker-args (list-of-strings '()) "Extra command-line arguments to pass to
@code{docker run}.")
  (docker-cli (package docker-cli) "The package containing the Docker
executable to use."))

(define (docker-container-shepherd-service config)
  (match-record config <docker-container-configuration>
                (image
                 volumes
                 name
                 user
                 environment-variables
                 environment-files
                 network-type
                 read-only-root?
                 remove-after-stop?
                 docker-args
                 docker-cli)

    (let ((docker-run-args
           `(,@(if read-only-root? '("--read-only") '())
             ,@(if remove-after-stop? '("--rm") '())
             "--network" ,network-type
             ,@(if (maybe-value-set? name) `("--name" ,name) '())
             ,@(if (maybe-value-set? user) `("--user" ,user) '())
             ,@(append-map (cut list "--env-file" <>) environment-files)
             ,@(append-map (cut list "-e" <>) environment-variables)
             ,@(append-map
                (match-lambda
                  (((? string? host-path)
                    (? string? container-path))
                   `("-v" ,(string-append host-path ":" container-path)))
                  (((? string? host-path)
                    (? string? container-path)
                    (? boolean? read-write?))
                   `("-v" ,(string-append host-path ":" container-path ":"
                                          (if read-write? "rw" "ro")))))
                volumes))))

      (shepherd-service
       (provision (list (string->symbol
                         (string-append "docker-container-" (maybe-value name image)))))
       (requirement (if (string=? network-type "none") '() '(networking)))
       (documentation (format #f "Run a Docker container called ~s from the image ~s."
                              (maybe-value name) image))
       (start #~(lambda ()
                  (use-modules ((srfi srfi-1) #:select (every))
                               ((srfi srfi-26) #:select (cut))
                               (ice-9 popen)
                               (ice-9 textual-ports))
                  (let* ((hex (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
                                        #\a #\b #\c #\d #\e #\f #\A #\B #\C #\D #\E #\F))
                         (pipe
                          (open-pipe* OPEN_READ #$(file-append docker-cli "/bin/docker")
                                      "run" "-d" #$@docker-run-args #$@docker-args #$image))
                         (container-id
                          (string-trim-both (get-string-all pipe) char-whitespace?)))
                    (close-pipe pipe)
                    ;; We expect a hexadecimal container ID from `docker run'.
                    (and (every (cut char-set-contains? hex <>)
                                (string->list container-id))
                         container-id))))
       ;; First arg is shepherd's "running value", i.e. whatever `start' returned.
       (stop #~(lambda* (#:optional (container-id #$(maybe-value name #f)))
                 (if (zero?
                      (status:exit-val
                       (system* #$(file-append docker-cli "/bin/docker") "stop" container-id)))
                     #f  ; #f means the service stopped and can be restarted again.
                     container-id)))))))

(define (docker-container-shepherd-services configs)
  (map docker-container-shepherd-service configs))

(define docker-container-service-type
  (service-type
   (name 'docker-container)
   (extensions
    (list (service-extension shepherd-root-service-type docker-container-shepherd-services)))
   (default-value '())
   (compose concatenate)
   (extend append)
   (description "Run Docker containers under Shepherd.")))