shepherd socket activation

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))))))