1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
(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))
;; TODO: Guix has `oci-container-service-type', but it doesn't support
;; environment files, so may not be safe for secrets.
(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.")
(extra-requirements (list-of-symbols '()) "Any Shepherd services on the host
system that this container relies on."))
(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
extra-requirements)
(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 `(dockerd ,@(if (string=? network-type "none") '() '(networking))
,@extra-requirements))
(documentation (format #f "Run a Docker container called ~s from the image ~s."
(maybe-value name) image))
(modules `(((srfi srfi-1) #:select (every))
((srfi srfi-26) #:select (cut))
(ice-9 popen)
(ice-9 textual-ports)
,@%default-modules))
(start #~(lambda ()
(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 (not (string=? "" container-id))
(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.")))
|
