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
| | ;; systemd.scm -- Systemd support
;; Copyright (C) 2018 Ioannis Panagiotis Koutsidis <gk.ppp7@gmail.com>
;;
;; This file is part of the GNU Shepherd.
;;
;; The GNU Shepherd 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.
;;
;; The GNU Shepherd 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 the GNU Shepherd. If not, see <http://www.gnu.org/licenses/>.
(define-module (shepherd systemd)
#:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:use-module (oop goops)
#:use-module (shepherd service)
#:export (make-systemd-service))
;; Change this
(define unitdir "/systemd/")
;; Implements a state machine to parse the ini-like systemd unit files
(define (unit-parse s)
(letrec ([unit-parse (lambda (s state key value kv)
(match (list s state)
[((or (#\newline _ ...)
()) 'keypart)
(error "Key " (list->string key) " is missing its value")]
[(() (or 'valuepart 'firstchar 'ignoreline))
kv]
[lst (let ([rest (cdar lst)])
(match (list (caar lst) state)
[((or #\;
#\[) 'firstchar)
(unit-parse rest
'ignoreline
'()
'()
kv)]
[(#\newline (or 'firstchar
'ignoreline))
(unit-parse rest
'firstchar
'()
'()
kv)]
[(#\= 'keypart)
(unit-parse rest
'valuepart
key
'()
kv)]
[(#\newline 'valuepart)
(unit-parse rest
'firstchar
'()
'()
`((,(list->string key)
. ,(list->string value))
. ,kv))]
[(_ 'ignoreline)
(unit-parse rest
'ignoreline
'()
'()
kv)]
[(c 'valuepart)
(unit-parse rest
'valuepart
key
(append value `(,c))
kv)]
[(c (or 'keypart 'firstchar))
(unit-parse rest
'keypart
(append key `(,c))
'()
kv)]))]))])
(unit-parse (string->list s) 'firstchar '() '() '())))
(define (unit-parse-file path)
(let* ([in (open-input-file path)]
[out (unit-parse (get-string-all in))])
(close-port in)
out))
;; like assoc but uses a coninuation for failure and success
(define (kassoc key alst failure success)
(let ((res (assoc key alst)))
(if (equal? res #f)
failure
(success (cdr res)))))
;; like assoc but 1: allows the use of a default value on failure
;; and 2: returns just the value instead of (cons key value)
(define (dassoc key alst default)
(kassoc key alst default (lambda (x) x)))
(define (make-systemd-service name)
(let* ([alst (unit-parse-file (string-append unitdir name))]
[busname (dassoc "BusName" alst #f)]
[execstart (dassoc "ExecStart" alst #f)]
[type (dassoc "Type" alst (if (equal? execstart #f)
"oneshot"
(if (equal? busname #f)
"simple"
"dbus")))]
[restart (string->symbol (dassoc "Restart" alst "no"))]
[user (dassoc "User" alst #f)]
[group (dassoc "Group" alst #f)]
[rootdir (dassoc "RootDirectory" alst "/")] ;; not currently used
[workdir (dassoc "WorkingDirectory" alst rootdir)]
[command execstart])
(make <service>
#:docstring (dassoc "Description" alst "")
#:provides `(,(string->symbol name))
#:requires (let* ([req (string-split (dassoc "Requires" alst "") #\space)]
[req2 (if (equal? req '(""))
'()
(map string->symbol req))])
(if (equal? type "dbus")
(append req2 'dbus.service)
req2))
#:respawn-systemd restart
#:respawn? #t
#:start (cond [(and (equal? type "simple") (not (equal? command #f)))
(make-forkexec-constructor (list "/bin/sh" "-c" command)
#:user user
#:group group
#:directory workdir)]
[#t '()]) ; TODO: non-simple services (which exit)
; should not use make-forkexec-constructor
#:stop (make-kill-destructor #:timeout 60))))
(register-services (make-systemd-service "test.service"))
|