unofficial mirror of guix-devel@gnu.org 
 help / color / mirror / code / Atom feed
* GSoC update
@ 2018-07-10 17:42 Ioannis Panagiotis Koutsidis
  2018-07-10 22:40 ` Ludovic Courtès
  0 siblings, 1 reply; 4+ messages in thread
From: Ioannis Panagiotis Koutsidis @ 2018-07-10 17:42 UTC (permalink / raw)
  To: Guix-devel

[-- Attachment #1: Type: text/plain, Size: 305 bytes --]

Hi Guix!

This patch adds initial support for .socket unit files. It does not currently 
work but is near completion. During the past month I also worked on a patch that 
adds signalfd and fiber support but these are currently way too unstable and for 
that reason I have not included them in this patch.

[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 30367 bytes --]

From cd260ae65056b53749e7c03f2498a28af2525934 Mon Sep 17 00:00:00 2001
From: Ioannis Panagiotis Koutsidis <ixk680@student.bham.ac.uk>
Date: Tue, 10 Jul 2018 20:03:21 +0300
Subject: [PATCH] .socket units

---
 modules/shepherd.scm         |  44 +++--
 modules/shepherd/service.scm | 170 ++++++++++-------
 modules/shepherd/systemd.scm | 354 ++++++++++++++++++++++++-----------
 3 files changed, 368 insertions(+), 200 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 5d97598..45fcb23 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -31,6 +31,7 @@
   #:use-module (shepherd config)
   #:use-module (shepherd support)
   #:use-module (shepherd service)
+  #:use-module (shepherd systemd)
   #:use-module (shepherd system)
   #:use-module (shepherd runlevel)
   #:use-module (shepherd args)
@@ -259,9 +260,18 @@
                    (setvbuf command-source _IOFBF 1024)
                    (process-connection command-source))
                   (_ #f)))
-              (match (select (list sock) (list) (list) (if poll-services? 0.5 #f))
-                (((sock) _ _)
-                 (read-from sock))
+
+              (match (select (cons* sock unit-sockets-list) (list) (list)
+                             (if poll-services? 0.5 #f))
+                (((rsock _ ...) _ _)
+                 (let* ((sockserv1 (find (lambda (x)
+                                           (eq? (slot-ref x 'running) rsock))
+                                         (service-list)))
+                        (sockserv (if sockserv1 (before sockserv1) #f))
+                        (res (if sockserv (car (lookup-services (string->symbol (car sockserv)))) #f)))
+                   (if res
+                       (start res (accept rsock))
+                       (read-from sock))))
                 (_
                  #f))
               (when poll-services?
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 5b0d72d..ceba004 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -74,6 +74,7 @@
             make-forkexec-constructor
             make-kill-destructor
             exec-command
+            exec-command2
             fork+exec-command
             read-pid-file
             make-system-constructor
@@ -102,7 +103,10 @@
             action-runtime-error-key
             action-runtime-error-arguments

-            condition->sexp))
+            condition->sexp
+
+            before
+            service-list))

 ;; Keep track of lazy initialization of SIGCHLD handler
 (define %sigchld-handler-installed? #f)
@@ -161,16 +165,12 @@ respawned, shows that it has been respawned more than TIMES in SECONDS."
   (requires #:init-keyword #:requires
 	    #:init-value '()
 	    #:getter required-by)
-  ;; If `#t', then assume the `running' slot specifies a PID and
-  ;; respawn it if that process terminates.  Otherwise `#f'.
+  ;; If not #f, then assume the `running' slot specifies a PID and
+  ;; respawn it if that process terminates.  Otherwise it can be
+  ;; 'on-success, 'on-failure, 'on-abnormal, 'on-watchdog, 'on-abort, or 'always
   (respawn? #:init-keyword #:respawn?
-	    #:init-value #f
+	    #:init-value 'no
 	    #: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
@@ -211,7 +211,11 @@ respawned, shows that it has been respawned more than TIMES in SECONDS."
   (stop-delay? #:init-keyword #:stop-delay?
 	       #:init-value #f)
   ;; The times of the last respawns, most recent first.
-  (last-respawns #:init-form '()))
+  (last-respawns #:init-form '())
+  ;; if it is a socket unit file, it contains all services that depend on it
+  (before #:init-keyword #:before
+          #:init-value '()
+          #:getter before))

 (define (service? obj)
   "Return true if OBJ is a service."
@@ -331,7 +335,7 @@ wire."
                   ;; Start the service itself.  Asyncs are blocked so that if
                   ;; the newly-started process dies immediately, the SIGCHLD
                   ;; handler is invoked later, once we have set the 'running'
-                  ;; field.
+                  ;; field .
                   (slot-set! obj 'running (catch #t
                                             (lambda ()
                                               (apply (slot-ref obj 'start)
@@ -693,25 +697,17 @@ otherwise return the number that was read (a PID)."
                      (loop)))
               (apply throw args)))))))

-(define* (exec-command command
-                       #:key
-                       (user #f)
-                       (group #f)
-                       (log-file #f)
-                       (directory (default-service-directory))
-                       (environment-variables (default-environment-variables)))
-  "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."
+(define* (exec-command2 command
+                        #:key
+                        (user #f)
+                        (group #f)
+                        (stdin #f)
+                        (stderr #f)
+                        (stdout #f)
+                        (directory (default-service-directory))
+                        (rdir "/")
+                        (environment-variables (default-environment-variables)))
+  "Like exec-command but extended"
   (match command
     ((program args ...)
      ;; Become the leader of a new session and session group.
@@ -719,30 +715,23 @@ false."
      (setsid)

      (chdir directory)
+     (chroot rdir)
      (environ environment-variables)

-     ;; Close all the file descriptors except stdout and stderr.
-     (let ((max-fd (max-file-descriptors)))
-
+     (unless stdin
        ;; Redirect stdin to use /dev/null
        (catch-system-error (close-fdes 0))
        ;; Make sure file descriptor zero is used, so we don't end up reusing
        ;; it for something unrelated, which can confuse some packages.
-       (dup2 (open-fdes "/dev/null" O_RDONLY) 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))))
+       (dup2 (open-fdes "/dev/null" O_RDONLY) 0))
+
+     (when stdin
+       (dup2 stdin 0))
+
+     (when stdout
+       (dup2 stdout 1))
+     (when stderr
+       (dup2 stderr 2))

      ;; setgid must be done *before* setuid, otherwise the user will
      ;; likely no longer have permissions to setgid.
@@ -784,14 +773,54 @@ false."
          (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))))))
+    (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* (exec-command command
+                       #:key
+                       (user #f)
+                       (group #f)
+                       (log-file #f)
+                       (directory (default-service-directory))
+                       (environment-variables (default-environment-variables)))
+  "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."
+  (let ((fd (if 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))
+                    (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)))
+                  (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)))
+                #f)))
+    (exec-command command
+                  #:user user
+                  #:group group
+                  #:stdout fd
+                  #:stderr fd
+                  #:directory directory
+                  #:environment-variables environment-variables)))

 (define* (fork+exec-command command
                             #:key
@@ -1031,20 +1060,20 @@ then disable it."
            (not (respawn-limit-hit? (slot-ref serv 'last-respawns)
                                     (car respawn-limit)
                                     (cdr respawn-limit))))
-      (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)))
+      (let* ((e (status:exit-val status))
+             (t (status:term-sig status))
+             (r (respawn? serv))
+             (clean (or (eq? e 0)
+                        (eq? t SIGHUP)
+                        (eq? t SIGINT)
+                        (eq? t SIGTERM)
+                        (eq? t SIGPIPE))))
+        (if (or (eq? r 'always)
+                (eq? r 'on-watchdog) ;; not implemented yet
+                (and (eq? r 'on-success)  clean)
+                (and (eq? r 'on-abnormal) (not clean) (equal? e #f))
+                (and (eq? r 'on-failure)  (not clean))
+                (and (eq? r 'on-abort)    (= t SIGABRT)))
             (if (not (slot-ref serv 'waiting-for-termination?))
                 (begin
                   ;; Everything is okay, start it.
@@ -1075,7 +1104,6 @@ then disable it."
     ;; Sanity-checks first.
     (assert (list-of-symbols? (provided-by new)))
     (assert (list-of-symbols? (required-by new)))
-    (assert (boolean? (respawn? new)))
     ;; Canonical name actually must be canonical.  (FIXME: This test
     ;; is incomplete, since we may add a service later that makes it
     ;; non-cannonical.)
diff --git a/modules/shepherd/systemd.scm b/modules/shepherd/systemd.scm
index 77679fa..1dee888 100644
--- a/modules/shepherd/systemd.scm
+++ b/modules/shepherd/systemd.scm
@@ -17,127 +17,257 @@
 ;; along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.

 (define-module (shepherd systemd)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (ice-9 textual-ports)
   #:use-module (oop goops)
   #:use-module (shepherd service)
-  #:export (make-systemd-service))
+  #:export (read-unit-file
+            unit-files->services
+            unit-sockets-list))

-;; Change this
-(define unitdir "/systemd/")
+(define unit-sockets-list '())

-;; 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 (read-unit-file file)
+  "Implements a state machine to parse the ini-like systemd unit files."
+  (define (unit-parse file state key value kv)
+    (define c (read-char file))
+    (match (list (if (eof-object? c) #f c) state)
+      (((or #f #\newline) 'keypart)
+       (error "Key " (list->string key) " is missing its value"))
+      ((#f (or 'valuepart 'firstchar 'ignoreline))
+       kv)
+      (((or #\; #\[) 'firstchar)
+       (unit-parse file
+                   'ignoreline
+                   '()
+                   '()
+                   kv))
+      ((#\newline (or 'firstchar 'ignoreline))
+       (unit-parse file
+                   'firstchar
+                   '()
+                   '()
+                   kv))
+      ((#\= 'keypart)
+       (unit-parse file
+                   'valuepart
+                   key
+                   '()
+                   kv))
+      ((#\newline 'valuepart)
+       (unit-parse file
+                   'firstchar
+                   '()
+                   '()
+                   `((,(list->string key)
+                      . ,(list->string value))
+                     . ,kv)))
+      ((_ 'ignoreline)
+       (unit-parse file
+                   'ignoreline
+                   '()
+                   '()
+                   kv))
+      ((c 'valuepart)
+       (unit-parse file
+                   'valuepart
+                   key
+                   (append value `(,c))
+                   kv))
+      ((c (or 'keypart 'firstchar))
+       (unit-parse file
+                   'keypart
+                   (append key `(,c))
+                   '()
+                   kv))))
+  (unit-parse file 'firstchar '() '() '()))

-(define (unit-parse-file path)
-  (let* ([in (open-input-file path)]
-         [out (unit-parse (get-string-all in))])
-    (close-port in)
-    out))
+(define (dassoc alst key default)
+  "assoc-ref with a default value"
+  (or (assoc-ref alst key) default))

-;; 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)))))
+(define (make-socket family addr port backlog)
+  (define sock (socket family SOCK_STREAM 0))
+  (fcntl sock F_SETFD FD_CLOEXEC)
+  (cond ((= family PF_UNIX)  (bind sock AF_UNIX  addr))
+        ((= family PF_INET)  (bind sock AF_INET  (inet-pton AF_INET addr) port))
+        ((= family PF_INET6) (bind sock AF_INET6 (inet-pton AF_INET6 addr) port))
+        (#t                  (error "Unknown protocol")))
+  (fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL)))
+  (listen sock backlog)
+  sock)

-;; 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 %sigchld-handler-installed? #f)

-(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])
+;; TODO: deduplicate
+(define* (fork+exec-command2 command
+                             #:key
+                             (user #f)
+                             (group #f)
+                             (stdin #f)
+                             (stdout #f)
+                             (stderr #f)
+                             (directory (default-service-directory))
+                             (rdir "/")
+                             (environment-variables (environ)))
+  "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-command2 command
+                       #:user user
+                       #:group group
+                       #:stdin stdin
+                       #:stdout stdout
+                       #:stderr stderr
+                       #:directory directory
+                       #:rdir rdir
+                       #:environment-variables environment-variables)
+        pid)))

-    (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))))
+;; TODO: deduplicate
+(define* (make-forkexec-constructor-sock command
+                                         #:key
+                                         (user #f)
+                                         (group #f)
+                                         (directory (default-service-directory))
+                                         (rdir "/")
+                                         (environment-variables (environ))
+                                         (pid-file #f)
+                                         (pid-file-timeout 5))
+  "See make-forkexec-constructor"
+  (lambda (sock)
+    (define (clean-up file)
+      (when file
+        (catch 'system-error
+          (lambda ()
+            (delete-file file))
+          (lambda args
+            (unless (= ENOENT (system-error-errno args))
+              (apply throw args))))))

-(register-services (make-systemd-service "test.service"))
+    (clean-up pid-file)
+
+    (let* ((pid (fork+exec-command2 command
+                                    #:user user
+                                    #:group group
+                                    #:stdin sock
+                                    #:stdout sock
+                                    #:directory directory
+                                    #:rdir rdir
+                                    #:environment-variables
+                                    environment-variables)))
+      (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))))
+
+;; O(n^2)
+(define (unit-files->services ufiles-orig)
+  (define (inner ufiles return)
+    (match ufiles
+      (() return)
+      (((fullname basename 'service alst) rest ...)
+       (let* ((dassoc        (lambda (name val) (dassoc alst name val)))
+              (busname       (dassoc "BusName"       #f))
+              (execstart     (dassoc "ExecStart"     #f))
+              (execstartpre  (dassoc "ExecStartPre"  #f)) ;; TODO
+              (execstartpost (dassoc "ExecStartPost" #f)) ;; TODO
+              (execstop      (dassoc "ExecStop"      #f))
+              (execstoppost  (dassoc "ExecStopPost"  #f)) ;; TODO
+              (execreload    (dassoc "ExecReload"    #f)) ;; TODO
+              (type          (dassoc "Type"          (if (equal? execstart #f)
+                                                         "oneshot"
+                                                         (if (equal? busname #f)
+                                                             "simple"
+                                                             "dbus"))))
+              (restart         (let ((res (dassoc "Restart" "no")))
+                                 (if (eq? res #f)
+                                     #f
+                                     (string->symbol res))))
+              (user            (dassoc "User"             #f))
+              (group           (dassoc "Group"            #f))
+              (rootdir         (dassoc "RootDirectory"    "/")) ;; TODO
+              (workdir         (dassoc "WorkingDirectory" rootdir))
+              (env             (dassoc "Environment"      #f))) ;; TODO
+
+         (let ((serv (make <service>
+                       #:docstring (dassoc "Description" "")
+                       #:provides  `(,(string->symbol fullname))
+                       #:requires  (let* ((req  (string-split (dassoc "Requires"
+                                                                      "")
+                                                              #\space))
+                                          (req2 (if (equal? req '(""))
+                                                    '()
+                                                    (map string->symbol req))))
+                                     (if (equal? type "dbus")
+                                         (append req2 'dbus.service)
+                                         req2))
+                       #:respawn?        restart
+                       #:start           (if (find (lambda (x)
+                                                     (match x
+                                                       ((_ basename2 'socket _)
+                                                        (eq? basename basename2))
+                                                       (_ #f))) ufiles-orig)
+                                             (make-forkexec-constructor-sock
+                                              (list "/bin/sh" "-c" execstart)
+                                              #:user      user
+                                              #:group     group
+                                              #:directory workdir
+                                              #:rdir      rootdir)
+                                             (cond [(and (equal? type "simple")
+                                                         (not (equal? execstart #f)))
+                                                    (make-forkexec-constructor
+                                                     (list "/bin/sh" "-c" execstart)
+                                                     #:user      user
+                                                     #:group     group
+                                                     #:directory workdir)]
+                                                   [#t '()])) ;; TODO: nonsimple
+                       #:stop            (make-kill-destructor #:timeout 60))))
+           (inner rest (cons serv return)))))
+      (((fullname basename 'socket alst) rest ...)
+       (let* ((dassoc  (lambda (name val) (dassoc alst name val)))
+              (backlog (dassoc "Backlog" 128))
+              (listens (string-split (dassoc "ListenStream" #f) #\:))
+              (port    (string->number (cadr listens)))
+              (addr    (car listens)))
+
+         (let ((serv (make <service>
+                       #:docstring (dassoc "Description" "")
+                       #:provides  `(,(string->symbol fullname))
+                       #:start     (lambda args
+                                     (let ((sock (make-socket PF_INET addr port backlog)))
+                                       (set! unit-sockets-list
+                                             (cons sock unit-sockets-list))
+                                       sock))
+                       #:stop      (lambda (running) (begin (delete running
+                                                                    unit-sockets-list)
+                                                            (close running)
+                                                            #f))
+                       #:before    (find (lambda (x)
+                                           (match x
+                                             ((_ basename2 'service _)
+                                              (eq? basename basename2))
+                                             (_ #f))) ufiles-orig))))
+           (inner rest (cons serv return)))))))
+  (inner ufiles-orig (list)))
--
2.18.0

^ permalink raw reply related	[flat|nested] 4+ messages in thread

end of thread, other threads:[~2018-07-12 12:13 UTC | newest]

Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-07-10 17:42 GSoC update Ioannis Panagiotis Koutsidis
2018-07-10 22:40 ` Ludovic Courtès
2018-07-11 14:26   ` Jelle Licht
2018-07-12 12:13   ` Ioannis Panagiotis Koutsidis

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).