packages.scm: Add (with-services-from-args ...)

2 files changed, 49 insertions, 1 deletions

diff --git a/src/org/euandre/packages.scm b/src/org/euandre/packages.scm
index 50db25c..c5e8287 100644
--- a/src/org/euandre/packages.scm
+++ b/src/org/euandre/packages.scm
@@ -843,6 +843,46 @@ It includes:
 The default configuration should provide sane values for all of these."
        name))))
 
+(define-public (without-shepherd-services lst)
+  (filter (lambda (extension)
+            (not (eq? shepherd-root-service-type
+                      (service-extension-target extension))))
+          lst))
+
+(define-public (replacing-shepherd-services service fn)
+  (service-type
+    (inherit service)
+    (extensions
+      (append
+       (without-shepherd-services
+        (service-type-extensions service))
+       (list
+        (service-extension shepherd-root-service-type
+                           fn))))))
+
+(define-public (with-services-from-args service config-type args)
+  (replacing-shepherd-services
+   service
+   (lambda (config)
+     (m:match config
+       (($ config-type _name _package user group log-file data-directory)
+        (map (lambda (tuple)
+               (let ((provision (s1:first  tuple))
+                     (args      (s1:second tuple)))
+                 (shepherd-service
+                   (provision provision)
+                   (requirement '(networking))
+                   (start
+                     #~(make-forkexec-constructor
+                        (list #$(cmd-for config-type config)
+                              #$@args)
+                        #:user      #$user
+                        #:group     #$group
+                        #:log-file  #$log-file
+                        #:directory #$data-directory))
+                   (stop #~(make-kill-destructor SIGKILL)))))
+             args))))))
+
 
 
 (define-public binder-service-type
diff --git a/tests/internet/system.scm b/tests/internet/system.scm
index 453f3fa..0173ddf 100644
--- a/tests/internet/system.scm
+++ b/tests/internet/system.scm
@@ -19,6 +19,14 @@
   `(("user1"   "I'm a user"  ())
     ("another" "Description" ("wheel") ,(path "tests/internet/key.txt"))))
 
+(define glaze-service-type
+  (pkg:with-services-from-args
+   pkg:glaze-service-type
+   pkg:<glaze-configuration>
+   '(((glaze-http)  ("-X"                  "/var/run/glaze/redirect.socket"))
+     ((glaze-https) ("-P/*:/var/lib/glaze" "/var/run/glaze/glaze.socket")))))
+
+
 (operating-system
   (host-name "a-internet-test-host")
   (skeletons pkg:skeletons)
@@ -30,7 +38,7 @@
       (service dhcp-client-service-type)
       (service fail2ban-service-type)
       (service pkg:binder-service-type)
-      (service pkg:glaze-service-type)
+      (service glaze-service-type)
       (service pkg:untls-service-type)
       (service pkg:wscat-service-type)
       (service pkg:papod-service-type)