aboutsummaryrefslogblamecommitdiff
path: root/src/org/euandre/services.scm
blob: 4b62fc9e3cd095e89d377260e204b53bec923e01 (plain) (tree)
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518





































































































































































































































































































































































































































































































































                                                                                                                              
(define-module (org euandre services)
  #:use-module ((org euandre packages) #:prefix pkg:)
  #:use-module ((org euandre queue) #:prefix q:)
  #:use-module ((ice-9 match) #:prefix m:)
  #:use-module ((ice-9 popen) #:prefix popen:)
  #:use-module ((ice-9 textual-ports) #:prefix textual-ports:)
  #:use-module ((gnu build linux-container) #:prefix container:)
  #:use-module ((srfi srfi-1) #:prefix s1:)
  #:use-module ((xyz euandreh heredoc) #:prefix heredoc:)
  #:use-module (gnu)
  #:use-module (guix build utils)
  #:use-module (guix least-authority)
  #:use-module (guix records)
  #:export (<syskeep-configuration>
             syskeep-configuration
        make-syskeep-configuration
             syskeep-configuration?
             syskeep-configuration-package
             syskeep-configuration-log-file

	    <binder-configuration>
             binder-configuration
        make-binder-configuration
             binder-configuration?
             binder-configuration-name
             binder-configuration-package
             binder-configuration-user
             binder-configuration-group
             binder-configuration-log-file
             binder-configuration-data-directory
             binder-configuration-run-directory
             binder-configuration-run-in-container?
             binder-configuration-container-name
             binder-configuration-extra-mappings

            <glaze-configuration>
             glaze-configuration
        make-glaze-configuration
             glaze-configuration?
             glaze-configuration-name
             glaze-configuration-package
             glaze-configuration-user
             glaze-configuration-group
             glaze-configuration-log-file
             glaze-configuration-data-directory
             glaze-configuration-run-directory
             glaze-configuration-run-in-container?
             glaze-configuration-container-name
             glaze-configuration-extra-mappings

            <untls-configuration>
             untls-configuration
        make-untls-configuration
             untls-configuration?
             untls-configuration-name
             untls-configuration-package
             untls-configuration-user
             untls-configuration-group
             untls-configuration-log-file
             untls-configuration-data-directory
             untls-configuration-run-directory
             untls-configuration-run-in-container?
             untls-configuration-container-name
             untls-configuration-extra-mappings

            <wscat-configuration>
             wscat-configuration
        make-wscat-configuration
             wscat-configuration?
             wscat-configuration-name
             wscat-configuration-package
             wscat-configuration-user
             wscat-configuration-group
             wscat-configuration-log-file
             wscat-configuration-data-directory
             wscat-configuration-run-directory
             wscat-configuration-run-in-container?
             wscat-configuration-container-name
             wscat-configuration-extra-mappings

            <papod-configuration>
             papod-configuration
        make-papod-configuration
             papod-configuration?
             papod-configuration-name
             papod-configuration-package
             papod-configuration-user
             papod-configuration-group
             papod-configuration-log-file
             papod-configuration-data-directory
             papod-configuration-run-directory
             papod-configuration-run-in-container?
             papod-configuration-container-name
             papod-configuration-extra-mappings))
(use-package-modules
  admin
  version-control)
(use-service-modules
  admin
  mcron
  shepherd)



(define-public (slurp path)
  (call-with-input-file
   path
   textual-ports:get-string-all))

(define-public (str . rest)
  (apply string-append rest))

(define-public (fmt . rest)
  (apply format #f rest))

(define-public (user-accounts users)
  (map (lambda (user)
         (let ((name    (s1:first  user))
               (comment (s1:second user))
               (groups  (s1:third  user)))
           (user-account
             (name name)
             (comment comment)
             (group "users")
             (supplementary-groups groups))))
       users))

(define-public (users->keys users)
  (let ((users-with-keys (filter (compose not null? cdddr)
                                 users)))
    (append
     (map (lambda (user)
            (let ((name (s1:first  user))
                  (key  (s1:fourth user)))
              `(,name ,(plain-file (str name "-id_rsa.pub") key))))
          users-with-keys)
    `(("git" ,@(map (lambda (user)
                      (let ((name (s1:first  user))
                            (key  (s1:fourth user)))
                        (plain-file (str name "-git-id_rsa.pub")
                                    (slurp key))))
                    users-with-keys))))))

(define (tuple->entry tuple)
  (let* ((name    (s1:first  tuple))
         (package (s1:second tuple))
         (path (string-append "/etc/" name)))
    (list
     name
     (computed-file
      (string-append "syskeep-" name)
      #~(begin
          (use-modules
            ((ice-9 textual-ports) #:prefix textual-ports:))

          (define (slurp p)
            (call-with-input-file p textual-ports:get-string-all))

          (define (spit p s)
            (call-with-output-file
             p
             (lambda (port)
               (display s port))))

          (spit #$output
                (slurp #$(file-append package path))))))))

(define (etc-entries package paths)
  (map
   tuple->entry
   (map (lambda (path)
          (list path package))
        paths)))

(define-public (package-set symbols records)
  (append
   records
   (map
    (compose list specification->package+output symbol->string)
    symbols)))

(define-public skeletons
  (etc-entries
   pkg:syskeep
   '(".profile")))

(define-public base-services
  (modify-services %base-services
    (rottlog-service-type config =>
      (rottlog-configuration
        (inherit config)
        (rc-file
          (file-append q:rottlog-mailutils-sendmail "/etc/rc"))))))



(define-record-type* <syskeep-configuration>
  syskeep-configuration
  make-syskeep-configuration
  syskeep-configuration?
  (package  syskeep-configuration-package  (default pkg:syskeep))
  (log-file syskeep-configuration-log-file (default "/var/log/cronjobs/cronjobs.log")))

(define (syskeep-profile config)
  (match-record config <syskeep-configuration>
      (package)
    (package-set
     '(parted
       guile-heredoc
       acl
       bind:utils
       knot:tools
       file
       git
       lsof
       moreutils
       mailutils-sendmail
       curl
       make
       borg
       rsync
       sqlite
       strace
       rlwrap
       trash-cli
       tree)
      (list
       package))))

(define (syskeep-rotations config)
  (match-record config <syskeep-configuration>
      (log-file)
    (list
     (log-rotation
       (frequency 'weekly)
       (files (list log-file))
       (options '("rotate 52"))))))

(define (syskeep-cronjobs config)
  (match-record config <syskeep-configuration>
      ()
    (list
     #~(job "0 0 * * *" "cronjob check")
     #~(job "0 1 * * *" "cronjob env BORG_REPO=/mnt/backup/borg backup -q cron")
     #~(job "0 2 * * *" "cronjob                                backup -q cron")
     #~(job "0 3 * * 0" "cronjob gc")
     #~(job "0 4 * * *" "cronjob reconfigure -U"))))

(define (syskeep-etc-files config)
  (match-record config <syskeep-configuration>
      (package)
    (etc-entries
     package
     '("rc"
       "known_hosts"
       "ssh.conf"
       "init.scm"
       "gitconfig"))))

(define (syskeep-accounts config)
  (match-record config <syskeep-configuration>
      ()
    (list
     (user-account
       (name  "git")
       (group "git")
       (system? #t)
       (comment "External SSH Git user")
       (home-directory "/src/ĝit")
       (create-home-directory? #f)
       (shell
         (file-append git "/bin/git-shell")))
     (user-group
       (name "git")
       (system? #t)))))

(define-public syskeep-service-type
  (service-type
    (name 'syskeep)
    (extensions
      (list
       (service-extension rottlog-service-type
                          syskeep-rotations)
       (service-extension mcron-service-type
                          syskeep-cronjobs)
       (service-extension etc-service-type
                          syskeep-etc-files)
       (service-extension account-service-type
                          syskeep-accounts)
       (service-extension profile-service-type
                          syskeep-profile)))
    (default-value (syskeep-configuration))
    (description "Common configuration of maintained servers.")))



(define-record-type* <binder-configuration>
  binder-configuration
  make-binder-configuration
  binder-configuration?
  (name              binder-configuration-name              (default "binder"))
  (package           binder-configuration-package           (default pkg:binder))
  (user              binder-configuration-user              (default "binder"))
  (group             binder-configuration-group             (default "binder"))
  (log-file          binder-configuration-log-file          (default "/var/log/binder/binder.log"))
  (data-directory    binder-configuration-data-directory    (default #f))
  (run-directory     binder-configuration-run-directory     (default "/var/run/binder"))
  (run-in-container? binder-configuration-run-in-container? (default #t))
  (container-name    binder-configuration-container-name    (default "binder-container"))
  (extra-mappings    binder-configuration-extra-mappings    (default '())))

(define-record-type* <glaze-configuration>
  glaze-configuration
  make-glaze-configuration
  glaze-configuration?
  (name              glaze-configuration-name              (default "glaze"))
  (package           glaze-configuration-package           (default pkg:glaze))
  (user              glaze-configuration-user              (default "glaze"))
  (group             glaze-configuration-group             (default "glaze"))
  (log-file          glaze-configuration-log-file          (default "/var/log/glaze/glaze.log"))
  (data-directory    glaze-configuration-data-directory    (default #f))
  (run-directory     glaze-configuration-run-directory     (default "/var/run/glaze"))
  (run-in-container? glaze-configuration-run-in-container? (default #t))
  (container-name    glaze-configuration-container-name    (default "glaze-container"))
  (extra-mappings    glaze-configuration-extra-mappings    (default '())))

(define-record-type* <untls-configuration>
  untls-configuration
  make-untls-configuration
  untls-configuration?
  (name              untls-configuration-name              (default "untls"))
  (package           untls-configuration-package           (default pkg:untls))
  (user              untls-configuration-user              (default "untls"))
  (group             untls-configuration-group             (default "untls"))
  (log-file          untls-configuration-log-file          (default "/var/log/untls/untls.log"))
  (data-directory    untls-configuration-data-directory    (default #f))
  (run-directory     untls-configuration-run-directory     (default "/var/run/untls"))
  (run-in-container? untls-configuration-run-in-container? (default #t))
  (container-name    untls-configuration-container-name    (default "untls-container"))
  (extra-mappings    untls-configuration-extra-mappings    (default '())))

(define-record-type* <wscat-configuration>
  wscat-configuration
  make-wscat-configuration
  wscat-configuration?
  (name              wscat-configuration-name              (default "wscat"))
  (package           wscat-configuration-package           (default pkg:wscat))
  (user              wscat-configuration-user              (default "wscat"))
  (group             wscat-configuration-group             (default "wscat"))
  (log-file          wscat-configuration-log-file          (default "/var/log/wscat/wscat.log"))
  (data-directory    wscat-configuration-data-directory    (default #f))
  (run-directory     wscat-configuration-run-directory     (default "/var/run/wscat"))
  (run-in-container? wscat-configuration-run-in-container? (default #t))
  (container-name    wscat-configuration-container-name    (default "wscat-container"))
  (extra-mappings    wscat-configuration-extra-mappings    (default '())))

(define-record-type* <papod-configuration>
  papod-configuration
  make-papod-configuration
  papod-configuration?
  (name              papod-configuration-name              (default "papod"))
  (package           papod-configuration-package           (default pkg:papod))
  (user              papod-configuration-user              (default "papod"))
  (group             papod-configuration-group             (default "papod"))
  (log-file          papod-configuration-log-file          (default "/var/log/papod/papod.log"))
  (data-directory    papod-configuration-data-directory    (default "/var/lib/papod"))
  (run-directory     papod-configuration-run-directory     (default "/var/run/papod"))
  (run-in-container? papod-configuration-run-in-container? (default #t))
  (container-name    papod-configuration-container-name    (default "papod-container"))
  (extra-mappings    papod-configuration-extra-mappings    (default '())))


(define-public (profile-for type)
  (lambda (config)
    (m:match config
      (($ type _name package)
       (list package)))))

(define-public (rotations-for type)
  (lambda (config)
    (m:match config
      (($ type _name _package _user _group log-file)
       (list
         (log-rotation
           (frequency 'weekly)
           (files (list log-file))
           (options '("rotate 5200"))))))))

(define-public (activation-for type)
  (lambda (config)
    (m:match config
      (($ type name _package user _group log-file data-directory run-directory)
       #~(begin
           (use-modules (guix build utils))
           (when #$log-file
             (format (current-error-port)
              "Creating ~a log directory for '~a'.~%" #$name #$log-file)
             (mkdir-p (dirname #$log-file))
             (when (not (file-exists? #$log-file))
               (call-with-output-file #$log-file (const #t)))
             (chmod #$log-file #o644))
           (let ((user (getpwnam #$user)))
             (when #$data-directory
               (format (current-error-port)
                "Creating ~a data directory '~a'.~%" #$name #$data-directory)
               (mkdir-p #$data-directory)
               (chown #$data-directory (passwd:uid user) (passwd:gid user))
               (chmod #$data-directory #o750))
             (when #$run-directory
               (format (current-error-port)
                "Creating ~a run directory '~a'.~%" #$name #$run-directory)
               (mkdir-p #$run-directory)
               (chown #$run-directory (passwd:uid user) (passwd:gid user))
               (chmod #$run-directory #o755))))))))

(define-public (accounts-for type)
  (lambda (config)
    (m:match config
      (($ type name _package user group)
       (list
        (user-group
          (name group)
          (system? #t))
        (user-account
          (name user)
          (group group)
          (system? #t)
          (comment (format #f "The user for runtime execution of ~a code" name))
          (home-directory "/var/empty")
          (shell
            (file-append shadow "/sbin/nologin"))))))))

(define-public (shepherd-services-for type)
  (lambda (config)
    (m:match config
      (($ type name package user group log-file data-directory _run-directory run-in-container? container-name extra-mappings)
       (list
        (shepherd-service
          (provision (list (string->symbol name)))
          (requirement '())
          (start
            #~(make-forkexec-constructor ;; FIXME: add #:resource-limits
               (list
                #$(let ((bin (file-append package (string-append "/bin/" name))))
                    (if (not run-in-container?)
                      bin
                      (least-authority-wrapper
                       bin
                       #:user      user
                       #:group     group
                       #:name      container-name
                       #:directory (or data-directory "/")
                       #:preserved-environment-variables
                       '()
                       #:mappings
                       (append
                        (if data-directory
                          (list
                           (file-system-mapping
                             (source data-directory)
                             (target source)
                             (writable? #t)))
                          (list))
                        extra-mappings)))))
               #:user      #$user
               #:group     #$group
               #:log-file  #$log-file
               #:directory #$data-directory))
          (stop #~(make-kill-destructor SIGKILL))
          (documentation
            (fmt "The Shepherd service that runs the server via \"~a\"." name))))))))

(define-public (service-type-for name type config extensions)
  (service-type
    (name name)
    (extensions
      (append
       (list
        (service-extension shepherd-root-service-type
                           (shepherd-services-for type))
        (service-extension profile-service-type
                           (profile-for type))
        (service-extension activation-service-type
                           (activation-for type))
        (service-extension account-service-type
                           (accounts-for type))
        (service-extension rottlog-service-type
                           (rotations-for type)))
       extensions))
    (default-value config)
    (description
      (fmt "The top-level generic system service, generated for ~a code.

It includes:
- the Shepherd service for starting, stopping and reloading the service;
- activation script for setting up the initial directories and permissions;
- the group and account for running the production service;
- log management (storage and rotation) for logs produced by the running services.

The default configuration should provide sane values for all of these."
       name))))



(define-public binder-service-type
  (service-type-for 'binder <binder-configuration> (binder-configuration) '()))

(define-public glaze-service-type
  (service-type-for 'glaze  <glaze-configuration>  (glaze-configuration)  '()))

(define-public untls-service-type
  (service-type-for 'untls  <untls-configuration>  (untls-configuration)  '()))

(define-public wscat-service-type
  (service-type-for 'wscat  <wscat-configuration>  (wscat-configuration)  '()))

(define-public papod-service-type
  (service-type-for 'papod  <papod-configuration>  (papod-configuration)  '()))