summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorFlorian Dold <florian.dold@gmail.com>2018-12-04 11:24:50 +0100
committerFlorian Dold <florian.dold@gmail.com>2018-12-04 11:24:50 +0100
commitc51c406adc9cd5b3c56aa709a688ff72a35bb7ed (patch)
tree89ffb5bbe754252af5e557c30d0f2cb8dfbe2607 /guix
parentc855883424d058e11feb55ae8d0cb0234c5d876a (diff)
downloaddeployment-c51c406adc9cd5b3c56aa709a688ff72a35bb7ed.tar.gz
deployment-c51c406adc9cd5b3c56aa709a688ff72a35bb7ed.tar.bz2
deployment-c51c406adc9cd5b3c56aa709a688ff72a35bb7ed.zip
shepherd socket activation
Diffstat (limited to 'guix')
-rw-r--r--guix/config.scm50
-rw-r--r--guix/shepherd-with-sock.scm225
2 files changed, 265 insertions, 10 deletions
diff --git a/guix/config.scm b/guix/config.scm
index 6e9982e..e2cf6ba 100644
--- a/guix/config.scm
+++ b/guix/config.scm
@@ -21,6 +21,7 @@
(use-modules
(srfi srfi-1)
+ (ice-9 match)
(gnu)
(guix)
(guix utils)
@@ -29,7 +30,7 @@
(taler-helpers))
(use-system-modules nss)
-(use-service-modules networking ssh version-control cgit databases admin web)
+(use-service-modules networking ssh version-control cgit databases admin web shepherd)
(use-package-modules base bash shells web tls)
;;; Commentary:
@@ -55,19 +56,48 @@
(group my-fcgiwrap-configuration-group
(default "fcgiwrap")))
+(define (parse-fcgiwrap-socket s)
+ (cond
+ ((string-prefix? "unix:" s)
+ (list 'unix (substring s 5)))
+ ((string-prefix? "tcp:" s)
+ (match (string-match "^tcp:([.0-9]+):([0-9]+)$" s)
+ ((? regexp-match? m)
+ (list
+ 'tcp
+ (match:substring m 1)
+ (string->number (match:substring m 2))))
+ (_ (error "invalid tcp socket address"))))
+ ((string-prefix? "tcp6:" s)
+ (match (string-match "^tcp6:\\[(.*)\\]:([0-9]+)$" s)
+ ((? regexp-match? m)
+ (list
+ 'tcp6
+ (match:substring m 1)
+ (string->number (match:substring m 2))))
+ (_ (error "invalid tcp6 socket address"))))
+ (else (error "unrecognized socket protocol"))))
+
(define my-fcgiwrap-shepherd-service
(match-lambda
(($ <my-fcgiwrap-configuration> package socket user group)
- (list (shepherd-service
- (provision '(fcgiwrap))
- (documentation "Run the fcgiwrap daemon.")
- (requirement '(networking))
- (start #~(make-forkexec-constructor
- '(#$(file-append package "/sbin/fcgiwrap")
- "-s" #$socket)
- #:user #$user #:group #$group))
- (stop #~(make-kill-destructor)))))))
+ (let ((parsed-socket (parse-fcgiwrap-socket socket)))
+ (list
+ (shepherd-service
+ (provision '(fcgiwrap))
+ (documentation "Run the fcgiwrap daemon.")
+ (requirement '(networking))
+ (start (with-imported-modules
+ '((shepherd-with-sock))
+ #~(begin
+ (use-modules ((shepherd-with-sock) #:prefix my:))
+ (my:make-forkexec-constructor
+ '(#$(file-append package "/sbin/fcgiwrap"))
+ #:user #$user
+ #:group #$group
+ #:stdin-socket #$parsed-socket))))
+ (stop #~(make-kill-destructor))))))))
(define my-fcgiwrap-accounts
diff --git a/guix/shepherd-with-sock.scm b/guix/shepherd-with-sock.scm
new file mode 100644
index 0000000..7a43c66
--- /dev/null
+++ b/guix/shepherd-with-sock.scm
@@ -0,0 +1,225 @@
+(define-module (shepherd-with-sock)
+ #:use-module ((shepherd service)
+ #:select ()))
+
+
+(define default-service-directory (@@ (shepherd service) default-service-directory))
+(define default-environment-variables (@@ (shepherd service) default-environment-variables))
+(define %pid-file-timeout (@@ (shepherd service) %pid-file-timeout))
+
+
+(define (open-service-stdin stdin-socket)
+ (define (get-sock pf af . addr)
+ (let ((sock (socket pf SOCK_STREAM 0)))
+ (apply bind sock af addr)
+ (fileno sock)))
+ (match stdin-socket
+ (('unix sockpath)
+ (get-sock PF_UNIX AF_UNIX sockpath)
+ (('tcp addr port)
+ (get-sock PF_INET AF_INET (inet-pton AF_INET addr) port))
+ (('tcp6 addr port)
+ (get-sock PF_INET6 AF_INET6 (inet-pton AF_INET6 addr) port))
+ (#f
+ ;; Make sure file descriptor zero is used, so we don't end up reusing
+ ;; it for something unrelated, which can confuse some packages.
+ (open-fdes "/dev/null" O_RDONLY))))
+
+
+(define* (exec-command command
+ #:key
+ (user #f)
+ (group #f)
+ (log-file #f)
+ (directory (default-service-directory))
+ (environment-variables (default-environment-variables))
+ (stdin-socket #f))
+ "Run COMMAND as the current process from DIRECTORY, and with
+ENVIRONMENT-VARIABLES (a list of strings like \"PATH=/bin\".) File
+descriptors 1 and 2 are kept as is or redirected to LOG-FILE if it's true,
+whereas file descriptor 0 (standard input) points to /dev/null; all other file
+descriptors are closed prior to yielding control to COMMAND.
+
+By default, COMMAND is run as the current user. If the USER keyword
+argument is present and not false, change to USER immediately before
+invoking COMMAND. USER may be a string, indicating a user name, or a
+number, indicating a user ID. Likewise, COMMAND will be run under the
+current group, unless the GROUP keyword argument is present and not
+false."
+ (match command
+ ((program args ...)
+ ;; Become the leader of a new session and session group.
+ ;; Programs such as 'mingetty' expect this.
+ (setsid)
+
+ (chdir directory)
+ (environ environment-variables)
+
+ ;; Close all the file descriptors except stdout and stderr.
+ (let ((max-fd (max-file-descriptors)))
+ ;; Redirect stdin to use /dev/null or stdin-socket
+ (catch-system-error (close-fdes 0))
+
+ ;; Make sure file descriptor zero is always used, so we don't end up reusing
+ ;; it for something unrelated, which can confuse some packages.
+ (dup2 (open-service-stdin stdin-socket) 0))
+
+ (when log-file
+ (catch #t
+ (lambda ()
+ ;; Redirect stout and stderr to use LOG-FILE.
+ (catch-system-error (close-fdes 1))
+ (catch-system-error (close-fdes 2))
+ (dup2 (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)) 1)
+ (dup2 1 2))
+ (lambda (key . args)
+ (format (current-error-port)
+ "failed to open log-file ~s:~%" log-file)
+ (print-exception (current-error-port) #f key args)
+ (primitive-exit 1))))
+
+ ;; setgid must be done *before* setuid, otherwise the user will
+ ;; likely no longer have permissions to setgid.
+ (when group
+ (catch #t
+ (lambda ()
+ ;; Clear supplementary groups.
+ (setgroups #())
+ (setgid (group:gid (getgr group))))
+ (lambda (key . args)
+ (format (current-error-port)
+ "failed to change to group ~s:~%" group)
+ (print-exception (current-error-port) #f key args)
+ (primitive-exit 1))))
+
+ (when user
+ (catch #t
+ (lambda ()
+ (setuid (passwd:uid (getpw user))))
+ (lambda (key . args)
+ (format (current-error-port)
+ "failed to change to user ~s:~%" user)
+ (print-exception (current-error-port) #f key args)
+ (primitive-exit 1))))
+
+ ;; As the last action, close file descriptors. Doing it last makes
+ ;; "error in the finalization thread: Bad file descriptor" issues
+ ;; unlikely on 2.2.
+ (let loop ((i 3))
+ (when (< i max-fd)
+ ;; First try to close any ports associated with file descriptor I.
+ ;; Otherwise the finalization thread might get around to closing
+ ;; those ports eventually, which will raise an EBADF exception (on
+ ;; 2.2), leading to messages like "error in the finalization
+ ;; thread: Bad file descriptor".
+ (for-each (lambda (port)
+ (catch-system-error (close-port port)))
+ (fdes->ports i))
+ (catch-system-error (close-fdes i))
+ (loop (+ i 1)))))
+
+ (catch 'system-error
+ (lambda ()
+ (apply execlp program program args))
+ (lambda args
+ (format (current-error-port)
+ "exec of ~s failed: ~a~%"
+ program (strerror (system-error-errno args)))
+ (primitive-exit 1))))))
+
+
+(define* (fork+exec-command command
+ #:key
+ (user #f)
+ (group #f)
+ (log-file #f)
+ (directory (default-service-directory))
+ (environment-variables
+ (default-environment-variables))
+ (stdin-socket #f))
+ "Spawn a process that executed COMMAND as per 'exec-command', and return
+its PID."
+ ;; Install the SIGCHLD handler if this is the first fork+exec-command call
+ (unless %sigchld-handler-installed?
+ (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP)
+ (set! %sigchld-handler-installed? #t))
+ (let ((pid (primitive-fork)))
+ (if (zero? pid)
+ (exec-command command
+ #:user user
+ #:group group
+ #:log-file log-file
+ #:directory directory
+ #:environment-variables environment-variables
+ #:stdin-socket stdin-socket)
+ pid)))
+
+(define make-forkexec-constructor
+ (let ((warn-deprecated-form
+ ;; Until 0.1, this procedure took a rest list.
+ (lambda ()
+ (issue-deprecation-warning
+ "This 'make-forkexec-constructor' form is deprecated; use
+ (make-forkexec-constructor '(\"PROGRAM\" \"ARGS\"...)."))))
+ (case-lambda*
+ "Return a procedure that forks a child process, closes all file
+descriptors except the standard output and standard error descriptors, sets
+the current directory to @var{directory}, changes the environment to
+@var{environment-variables} (using the @code{environ} procedure), sets the
+current user to @var{user} and the current group to @var{group} unless they
+are @code{#f}, and executes @var{command} (a list of strings.) The result of
+the procedure will be the PID of the child process.
+
+When @var{pid-file} is true, it must be the name of a PID file associated with
+the process being launched; the return value is the PID read from that file,
+once that file has been created. If @var{pid-file} does not show up in less
+than @var{pid-file-timeout} seconds, the service is considered as failing to
+start."
+ ((command #:key
+ (user #f)
+ (group #f)
+ (directory (default-service-directory))
+ (environment-variables (default-environment-variables))
+ (pid-file #f)
+ (pid-file-timeout %pid-file-timeout)
+ (log-file #f)
+ (stdin-socket #f))
+ (let ((command (if (string? command)
+ (begin
+ (warn-deprecated-form)
+ (list command))
+ command)))
+ (lambda args
+ (define (clean-up file)
+ (when file
+ (catch 'system-error
+ (lambda ()
+ (delete-file file))
+ (lambda args
+ (unless (= ENOENT (system-error-errno args))
+ (apply throw args))))))
+
+ (clean-up pid-file)
+ (clean-up log-file)
+
+ (let ((pid (fork+exec-command command
+ #:user user
+ #:group group
+ #:log-file log-file
+ #:directory directory
+ #:environment-variables
+ environment-variables
+ #:stdin-socket stdin-socket)))
+ (if pid-file
+ (match (read-pid-file pid-file
+ #:max-delay pid-file-timeout)
+ (#f
+ (catch-system-error (kill pid SIGTERM))
+ #f)
+ ((? integer? pid)
+ pid))
+ pid)))))
+ ((program . program-args)
+ ;; The old form, documented until 0.1 included.
+ (warn-deprecated-form)
+ (make-forkexec-constructor (cons program program-args))))))