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