Extract wsdd out of samba.scm, push modifications of wsdd.

	modified:   siguix/services/samba.scm
	new file:   siguix/services/wsdd.scm

2 files changed, 174 insertions, 198 deletions

diff --git a/siguix/services/samba.scm b/siguix/services/samba.scm
index 97bcb57..ed0f473 100644
--- a/siguix/services/samba.scm
+++ b/siguix/services/samba.scm
@@ -74,29 +74,6 @@
 
             ;; temp!
             samba-configuration-default-config-file
-
-            wsdd-service
-            wsdd-service-type
-            wsdd-configuration
-            wsdd-configuration?
-            wsdd-configuration-package
-            wsdd-configuration-ipv4only?
-            wsdd-configuration-ipv6only?
-            wsdd-configuration-chroot
-            wsdd-configuration-hoplimit
-            wsdd-configuration-interface
-            ;; wsdd-configuration-user
-            ;; wsdd-configuration-group
-            wsdd-configuration-uuid-device
-            ;; wsdd-configuration-verbose?
-            wsdd-configuration-domain
-            wsdd-configuration-hostname
-            ;; wsdd-configuration-no-host?
-            wsdd-configuration-preserve-case?
-            ;; wsdd-configuration-no-http?
-            wsdd-configuration-workgroup
-            ;; wsdd-configuration-discovery?
-            ;; wsdd-configuration-listen
             ))
 
 ;;; Commentary:
@@ -387,178 +364,3 @@
           ;;                    (const %samba-accounts))
           ))
    (default-value (samba-configuration))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (let ((uid (passwd:uid (getpw "samba")))
-;;       (gid (group:gid (getgr "samba"))))
-;;   )
-
-
-;;;
-;;; WSDD
-;;;
-
-(define-record-type* <wsdd-configuration>
-  wsdd-configuration
-  make-wsdd-configuration
-  wsdd-configuration?
-  (package               wsdd-configuration-package
-                         (default wsdd))
-  (ipv4only?             wsdd-configuration-ipv4only? ;bolean
-                         (default #f))
-  (ipv6only?             wsdd-configuration-ipv6only? ;bolean
-                         (default #f))
-  (chroot                wsdd-configuration-chroot ;string
-                         (default #f))
-  (hoplimit              wsdd-configuration-hoplimit ;integer | 1
-                         (default 1))
-  (interface             wsdd-configuration-interface ;list of
-                                                      ;strings, and
-                                                      ;FIXME! This
-                                                      ;list is not
-                                                      ;expanded yet.
-                         (default #f))
-  ;; (user           wsdd-configuration-user
-  ;;                 (default '()))
-  ;; (group          wsdd-configuration-group
-  ;;                 (default '("nouser")))
-  (uuid-device           wsdd-configuration-uuid-device
-                         (default #f))
-  ;; (verbose?              wsdd-configuration-verbose? ;doesn't help in shepherd.
-  ;;                        (default #f))
-  (domain                wsdd-configuration-domain ;string
-                         (default #f))
-  (hostname              wsdd-configuration-hostname ;string
-                         (default #f))
-  ;; (no-host?              wsdd-configuration-no-host? ;bolean
-  ;;                        (default #f))
-  (preserve-case?        wsdd-configuration-preserve-case? ;bolean
-                         (default #f))
-  ;; (no-http?              wsdd-configuration-no-http? ;bolean
-  ;;                        (default #f))
-  (workgroup             wsdd-configuration-workgroup ;string
-                         (default "WORKGROUP"))
-
-  ;;; I don't think it makes sense to run it in discovery mode as a
-  ;;; service.
-
-  ;; (discovery?            wsdd-configuration-discovery? ;bolean
-  ;;                        (default #f))
-  ;; (listen                wsdd-configuration-listen ;string
-  ;;                        (default #f))
-  )
-
-(define wsdd-accounts
-  (list
-   (user-group (name "wsdd"))
-   (user-account (name "wsdd")
-                 (group "wsdd")
-                 (comment "Web Service Discovery user")
-                 (home-directory "/var/empty")
-                 (shell (file-append shadow "/sbin/nologin")))))
-
-(define wsdd-shepherd-service
-  (match-lambda
-    (($ <wsdd-configuration> package
-                             ipv4only?
-                             ipv6only?
-                             chroot
-                             hoplimit
-                             interface
-                             ;; user
-                             ;; group
-                             uuid-device
-                             ;; verbose?
-                             domain
-                             hostname
-                             ;; no-host?
-                             preserve-case?
-                             ;; no-http?
-                             workgroup
-                             ;; discovery?
-                             ;; listen
-                             )
-     (list (shepherd-service
-            (documentation "Run a Web Service Discovery service")
-            (provision '(wsdd))
-            (requirement '(networking))
-            (start #~(make-forkexec-constructor
-                      (list #$(file-append package "/bin/wsdd")
-                            #$@(if ipv4only?
-                                   #~("--ipv4only")
-                                   #~())
-                            #$@(if ipv6only?
-                                   #~("--ipv6only")
-                                   #~())
-                            #$@(if chroot
-                                   #~("--chroot" chroot)
-                                   #~())
-                            #$@(if hoplimit
-                                   ;; #~(string-append "--hoplimit" #$(number->string hoplimit))
-                                   #~("--hoplimit" #$(number->string hoplimit))
-                                   #~())
-
-                            #$@(if interface ;this one needs a
-                                             ;function so that the
-                                             ;items of list of strings
-                                             ;are prepended with an --interface.
-                                   #~(string-append "--interface" #$interface)
-                                   #~())
-
-                            ;; #$@(if user
-                            ;;        #~(string-append "--user " #$user)
-                            ;;        #~())
-                            ;; #$@(if group
-                            ;;        #~(string-append "--group " #$group)
-                            ;;        #~())
-
-                            #$@(if uuid-device
-                                   #~("--uuid" #$uuid-device)
-                                   #~())
-                            ;; #$@(if verbose?
-                            ;;        #~("--verbose")
-                            ;;        #~())
-                            #$@(if domain
-                                   #~("--domain" #$domain)
-                                   #~())
-                            #$@(if hostname
-                                   #~("--hostname" #$hostname)
-                                   #~())
-                            ;; #$@(if no-host?
-                            ;;        #~("--no-host")
-                            ;;        #~())
-                            #$@(if preserve-case?
-                                   #~("--preserve-case")
-                                   #~())
-                            ;; #$@(if no-http?
-                            ;;        #~("--no-http")
-                            ;;        #~())
-                            #$@(if workgroup
-                                   #~("--workgroup" #$workgroup)
-                                   #~())
-                            ;; #$@(if discovery?
-                            ;;        #~("--discovery")
-                            ;;        #~())
-                            ;; #$@(if listen
-                            ;;        #~("--listen " #$listen)
-                            ;;        #~())
-                            )
-                      #:user "wsdd"
-                      #:group "wsdd"
-                      #:log-file "/var/log/wsdd.log"
-                      ))
-            (stop #~(make-kill-destructor)))))))
-
-(define wsdd-service-type
-  (service-type
-   (name 'wsdd)
-   (description "Web Service Discovery Daemon")
-   (extensions
-    (list (service-extension shepherd-root-service-type
-                             wsdd-shepherd-service)
-          (service-extension account-service-type
-                             (const wsdd-accounts))
-          ))
-   (default-value (wsdd-configuration))))
diff --git a/siguix/services/wsdd.scm b/siguix/services/wsdd.scm
new file mode 100644
index 0000000..8b95755
--- /dev/null
+++ b/siguix/services/wsdd.scm
@@ -0,0 +1,174 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Simon Streit <simon@netpanic.org>
+;;;
+;;; This file is NOT part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (services wsdd)
+
+  #:use-module (gnu packages)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages admin)
+
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services base)
+  #:use-module (gnu system shadow)
+
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (guix modules)
+  #:use-module (guix records)
+
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (srfi srfi-1)
+
+  #:use-module (siguix packages wsdd)   ;temp!
+
+  #:export (wsdd-service
+            wsdd-service-type
+            wsdd-configuration
+            wsdd-configuration?
+            wsdd-configuration-package
+            wsdd-configuration-ipv4only?
+            wsdd-configuration-ipv6only?
+            wsdd-configuration-chroot
+            wsdd-configuration-hoplimit
+            wsdd-configuration-interface
+            wsdd-configuration-uuid-device
+            wsdd-configuration-domain
+            wsdd-configuration-hostname
+            wsdd-configuration-preserve-case?
+            wsdd-configuration-workgroup))
+
+;;;
+;;; WSDD
+;;;
+
+(define-record-type* <wsdd-configuration>
+  wsdd-configuration
+  make-wsdd-configuration
+  wsdd-configuration?
+  (package               wsdd-configuration-package
+                         (default wsdd))
+  (ipv4only?             wsdd-configuration-ipv4only?
+                         (default #f))
+  (ipv6only?             wsdd-configuration-ipv6only?
+                         (default #f))
+  (chroot                wsdd-configuration-chroot
+                         (default #f))
+  (hoplimit              wsdd-configuration-hoplimit
+                         (default 1))
+  (interface             wsdd-configuration-interface
+                         (default #f))
+  (uuid-device           wsdd-configuration-uuid-device
+                         (default #f))
+  (domain                wsdd-configuration-domain
+                         (default #f))
+  (hostname              wsdd-configuration-hostname
+                         (default #f))
+  (preserve-case?        wsdd-configuration-preserve-case?
+                         (default #f))
+  (workgroup             wsdd-configuration-workgroup
+                         (default "WORKGROUP")))
+
+(define wsdd-accounts
+  (list
+   (user-group (name "wsdd"))
+   (user-account (name "wsdd")
+                 (group "wsdd")
+                 (comment "Web Service Discovery user")
+                 (home-directory "/var/empty")
+                 (shell (file-append shadow "/sbin/nologin")))))
+
+(define wsdd-shepherd-service
+  (match-lambda
+    (($ <wsdd-configuration> package
+                             ipv4only?
+                             ipv6only?
+                             chroot
+                             hoplimit
+                             interface
+                             uuid-device
+                             domain
+                             hostname
+                             preserve-case?
+                             workgroup
+                             )
+     (list (shepherd-service
+            (documentation "Run a Web Service Discovery service")
+            (provision '(wsdd))
+            (requirement '(networking))
+            (start #~(make-forkexec-constructor
+                      (list #$(file-append package "/bin/wsdd")
+                            #$@(if ipv4only?
+                                   #~("--ipv4only")
+                                   '())
+                            #$@(if ipv6only?
+                                   #~("--ipv6only")
+                                   '())
+                            #$@(if chroot
+                                   #~("--chroot" #$chroot)
+                                   '())
+                            #$@(if hoplimit
+                                   #~("--hoplimit" #$(number->string hoplimit))
+                                   '())
+
+                            ;; FIXME, this results into wrong type applied.
+                            ;; #$(if interface
+                            ;;       #~(for-each (lambda (arg)
+                            ;;                     (display (string-append "--interface" arg))
+                            ;;                     ;; (format #t "--interface ~a " (list->string arg))
+                            ;;                     )
+                            ;;                   #$(interface))
+                            ;;       '())
+
+                            #$@(if interface ;to be replaced by procedure above
+                                   #~("--interface" #$interface)
+                                   '())
+
+                            #$@(if uuid-device
+                                   #~("--uuid" #$uuid-device)
+                                   '())
+                            #$@(if domain
+                                   #~("--domain" #$domain)
+                                   '())
+                            #$@(if hostname
+                                   #~("--hostname" #$hostname)
+                                   '())
+                            #$@(if preserve-case?
+                                   #~("--preserve-case")
+                                   '())
+                            #$@(if workgroup
+                                   #~("--workgroup" #$workgroup)
+                                   '()))
+                      #:user "wsdd"
+                      #:group "wsdd"
+                      #:log-file "/var/log/wsdd.log"))
+            (stop #~(make-kill-destructor)))))))
+
+(define wsdd-service-type
+  (service-type
+   (name 'wsdd)
+   (description "Web Service Discovery Daemon")
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             wsdd-shepherd-service)
+          (service-extension account-service-type
+                             (const wsdd-accounts))))
+   (default-value (wsdd-configuration))))