From a0a46ead5e43cd2672a08adb4c16919c377514c2 Mon Sep 17 00:00:00 2001
From: Ioannis Panagiotis Koutsidis
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
;; Copyright (C) 2016 Alex Kost
;; Copyright (C) 2018 Carlo Zancanaro
+;; Copyright (C) 2018 Ioannis Panagiotis Koutsidis
;;
;; 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 ))
(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 ))
(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
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
+;;
+;; 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 .
+
+(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
+ #: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