Hi Guix!
As the 1st phase is coming to an end I decided to post my progress. I have
implemented the unit file parsing as well as some of the basic entries supported
by it, such as ExecStart, User, Group, Restart, etc. In addition, support for
the systemd Restart values (on-success, on-failure, on-abnormal, and on-abort)
was added to the Shepherd via the restart-systemd field in the <service> class,
letting services written in guile to also use that feature.
During the next phases I will focus on other common .service entries, .socket
support, as well as thoroughly testing the code.
From a0a46ead5e43cd2672a08adb4c16919c377514c2 Mon Sep 17 00:00:00 2001
From: Ioannis Panagiotis Koutsidis <ixk...@student.bham.ac.uk>
Date: Sat, 9 Jun 2018 16:17:27 +0300
Subject: [PATCH] Initial systemd unit support
---
modules/shepherd/service.scm | 78 ++++++++++++-------
modules/shepherd/systemd.scm | 143 +++++++++++++++++++++++++++++++++++
2 files changed, 194 insertions(+), 27 deletions(-)
create mode 100644 modules/shepherd/systemd.scm
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 93d3779..5b0d72d 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -4,6 +4,7 @@
;; Copyright (C) 2014 Alex Sassmannshausen <alex.sassmannshau...@gmail.com>
;; Copyright (C) 2016 Alex Kost <alez...@gmail.com>
;; Copyright (C) 2018 Carlo Zancanaro <ca...@zancanaro.id.au>
+;; Copyright (C) 2018 Ioannis Panagiotis Koutsidis <gk.p...@gmail.com>
;;
;; This file is part of the GNU Shepherd.
;;
@@ -165,6 +166,11 @@ respawned, shows that it has been respawned more than
TIMES in SECONDS."
(respawn? #:init-keyword #:respawn?
#:init-value #f
#:getter respawn?)
+ ;; For the systemd restart values. Can be 'no (when respawn? is #f),
+ ;; 'on-success, 'on-failure, 'on-abnormal, 'on-watchdog, 'on-abort, or
'always
+ (respawn-systemd #:init-keyword #:respawn-systemd
+ #:init-value 'always
+ #:getter respawn-systemd)
;; The action to perform to start the service. This must be a
;; procedure and may take an arbitrary amount of arguments, but it
;; must be possible to call it without any argument. If the
@@ -270,7 +276,7 @@ wire."
(define-method (running? (obj <service>))
(and (slot-ref obj 'running) #t))
-;; Return a list of all actions implemented by OBJ.
+;; Return a list of all actions implemented by OBJ.
(define-method (action-list (obj <service>))
(map action-name (slot-ref obj 'actions)))
@@ -886,9 +892,12 @@ start."
;; Produce a destructor that sends SIGNAL to the process with the pid
;; given as argument, where SIGNAL defaults to `SIGTERM'.
(define make-kill-destructor
- (lambda* (#:optional (signal SIGTERM))
+ (lambda* (#:optional (signal SIGTERM)
+ (timeout #f))
(lambda (pid . args)
(kill pid signal)
+ ;; TODO: Make sure that the process has actually stopped by timeout.
+ ;; If it has not, send a SIGKILL
#f)))
;; Produce a constructor that executes a command.
@@ -996,7 +1005,7 @@ otherwise by updating its state."
((0 . _)
;; Nothing left to wait for.
#t)
- ((pid . _)
+ ((pid . status)
(let ((serv (find-service (lambda (serv)
(and (enabled? serv)
(match (slot-ref serv 'running)
@@ -1007,13 +1016,13 @@ otherwise by updating its state."
;; SERV can be #f for instance when this code runs just after a
;; service's 'stop' method killed its process and completed.
(when serv
- (respawn-service serv))
+ (respawn-service serv status))
;; As noted in libc's manual (info "(libc) Process Completion"),
;; loop so we don't miss any terminated child process.
(loop))))))
-(define (respawn-service serv)
+(define (respawn-service serv status)
"Respawn a service that has stopped running unexpectedly. If we have
attempted to respawn the service a number of times already and it keeps dying,
then disable it."
@@ -1022,22 +1031,37 @@ then disable it."
(not (respawn-limit-hit? (slot-ref serv 'last-respawns)
(car respawn-limit)
(cdr respawn-limit))))
- (if (not (slot-ref serv 'waiting-for-termination?))
- (begin
- ;; Everything is okay, start it.
- (local-output "Respawning ~a."
- (canonical-name serv))
- (slot-set! serv 'last-respawns
- (cons (current-time)
- (slot-ref serv 'last-respawns)))
- (start serv))
- ;; We have just been waiting for the
- ;; termination. The `running' slot has already
- ;; been set to `#f' by `stop'.
- (begin
- (local-output "Service ~a terminated."
- (canonical-name serv))
- (slot-set! serv 'waiting-for-termination? #f)))
+ (let* ([e (status:exit-val status)]
+ [t (status:term-sig status)]
+ [r (respawn-systemd serv)]
+ [clean (or (zero? e)
+ (equal? t SIGHUP)
+ (equal? t SIGINT)
+ (equal? t SIGTERM)
+ (equal? t SIGPIPE))])
+ (if (or (equal? r 'always)
+ (equal? r 'on-watchdog) ;; not implemented yet
+ (and (equal? r 'on-success) clean)
+ (and (equal? r 'on-abnormal) (not clean) (equal? e #f))
+ (and (equal? r 'on-failure) (not clean))
+ (and (equal? r 'on-abort) (equal? t SIGABRT)))
+ (if (not (slot-ref serv 'waiting-for-termination?))
+ (begin
+ ;; Everything is okay, start it.
+ (local-output "Respawning ~a."
+ (canonical-name serv))
+ (slot-set! serv 'last-respawns
+ (cons (current-time)
+ (slot-ref serv 'last-respawns)))
+ (start serv))
+ ;; We have just been waiting for the
+ ;; termination. The `running' slot has already
+ ;; been set to `#f' by `stop'.
+ (begin
+ (local-output "Service ~a terminated."
+ (canonical-name serv))
+ (slot-set! serv 'waiting-for-termination? #f)))
+ #f))
(begin
(local-output "Service ~a has been disabled."
(canonical-name serv))
@@ -1062,10 +1086,10 @@ then disable it."
;; Insert into the hash table.
(for-each (lambda (name)
- (let ((old (lookup-services name)))
- ;; Actually add the new service now.
- (hashq-set! %services name (cons new old))))
- (provided-by new)))
+ (let ((old (lookup-services name)))
+ ;; Actually add the new service now.
+ (hashq-set! %services name (cons new old))))
+ (provided-by new)))
(for-each register-single-service new-services))
@@ -1186,8 +1210,8 @@ where prctl/PR_SET_CHILD_SUBREAPER is unsupported."
(let ((running (slot-ref service 'running)))
(when (and (integer? running)
(not (process-exists? running)))
- (local-output "PID ~a (~a) is dead!" running
(canonical-name service))
- (respawn-service service))))))
+ (local-output "PID ~a (~a) is dead!" running
(canonical-name service))
+ (respawn-service service #f)))))) ;; TODO; get the
status
(define root-service
(make <service>
diff --git a/modules/shepherd/systemd.scm b/modules/shepherd/systemd.scm
new file mode 100644
index 0000000..77679fa
--- /dev/null
+++ b/modules/shepherd/systemd.scm
@@ -0,0 +1,143 @@
+;; systemd.scm -- Systemd support
+;; Copyright (C) 2018 Ioannis Panagiotis Koutsidis <gk.p...@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"))
--
2.17.1
