Add files in wip-samba.

2 files changed, 615 insertions, 0 deletions

diff --git a/siguix/packages/wsdd.scm b/siguix/packages/wsdd.scm
new file mode 100644
index 0000000..2116ac8
--- /dev/null
+++ b/siguix/packages/wsdd.scm
@@ -0,0 +1,51 @@
+;;; 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 (siguix packages wsdd)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix git-download)
+  #:use-module (guix build-system copy)
+  #:use-module (guix packages)
+  #:use-module (gnu packages python))
+
+(define-public wsdd
+  (package
+    (name "wsdd")
+    (version "0.6.4")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference (url "https://github.com/christgau/wsdd")
+                           (commit (string-append "v" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "0lfvpbk1lkri597ac4gz5x4csfyik8axz4b41i03xsqv9bci2vh6"))))
+    (build-system copy-build-system)
+    (inputs
+     `(("python" ,python)))
+    (arguments
+     '(#:install-plan
+       '(("src/wsdd.py" "bin/wsdd")
+         ("man/wsdd.1" "share/man/man1/"))))
+    (home-page "https://github.com/christgau/wsdd")
+    (synopsis "A Web Service Discovery host daemon")
+    (description "This daemon allows (Samba) hosts to be found by Web
+Service Dicovery Clients.  It also implements the client side of the
+discovery protocol which allows to search for devices implementing
+WSD.")
+    (license license:expat)))
diff --git a/siguix/services/samba.scm b/siguix/services/samba.scm
new file mode 100644
index 0000000..97bcb57
--- /dev/null
+++ b/siguix/services/samba.scm
@@ -0,0 +1,564 @@
+;;; 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 (siguix services samba)
+
+  #:use-module (gnu packages)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages samba)
+  #:use-module (siguix packages wsdd)   ;eventually move to guix
+
+  #: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)
+
+  #:export (samba-service
+            samba-service-type
+            samba-configuration
+            samba-configuration?
+            samba-configuration-package
+            samba-configuration-config-file
+            samba-configuration-enable-samba?
+            samba-configuration-enable-smbd?
+            samba-configuration-enable-nmbd?
+            samba-configuration-enable-winbindd?
+            samba-configuration-global-extra-config
+            samba-configuration-workgroup
+            samba-configuration-server-string
+            samba-configuration-server-role
+            samba-configuration-bind-interfaces-only?
+            samba-configuration-interfaces
+            samba-configuration-hosts-allow
+            samba-configuration-guest-account
+            samba-configuration-log-file
+            samba-configuration-loggin
+            samba-configuration-realm
+            samba-configuration-passdb-backend
+            samba-configuration-include-config
+            samba-configuration-logon-path
+            samba-configuration-wins-support?
+            samba-configuration-wins-server
+            samba-configuration-wins-proxy?
+            samba-configuration-dns-proxy?
+            samba-configuration-config-sections
+
+            ;; 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:
+;;;
+;;; Windows network services.
+;;;
+;;; Code:
+
+(define-record-type* <samba-configuration>
+  samba-configuration
+  make-samba-configuration
+  samba-configuration?
+
+  (package              samba-configuration-package
+                        (default samba))
+  (config-file          samba-configuration-config-file
+                        (default #f))
+  (enable-samba?        samba-configuration-enable-samba?
+                        (default #f))
+  (enable-smbd?         samba-configuration-enable-smbd?
+                        (default #t))
+  (enable-nmbd?         samba-configuration-enable-nmbd?
+                        (default #t))
+  (enable-winbindd?     samba-configuration-enable-winbindd?
+                        (default #f))
+
+  ;; From here on anything goes to smb.conf
+
+  ;; This line will be put at the end of [global].
+  (global-extra-config   samba-configuration-global-extra-config
+                         (default #f))
+  (workgroup             samba-configuration-workgroup
+                         (default "WORKGROUP"))
+  (server-string         samba-configuration-server-string
+                         (default "Samba Server"))
+  (server-role           samba-configuration-server-role
+                         (default "standalone server"))
+  (bind-interfaces-only? samba-configuration-bind-interfaces-only?
+                         (default #f))
+  (interfaces            samba-configuration-interfaces
+                         (default '()))
+  (hosts-allow           samba-configuration-hosts-allow
+                         (default '()))
+  (guest-account         samba-configuration-guest-account
+                         (default #f))
+  (log-file              samba-configuration-log-file
+                         (default "/var/log/samba/log.%m"))
+  (logging               samba-configuration-loggin
+                         (default "file"))
+  (realm                 samba-configuration-realm
+                         (default #f))
+  (passdb-backend        samba-configuration-passdb-backend
+                         (default #f))
+  (include-config        samba-configuration-include-config
+                         (default #f))
+  (logon-path            samba-configuration-logon-path
+                         (default #f))
+  (wins-support?         samba-configuration-wins-support?
+                         (default #f))
+  (wins-server           samba-configuration-wins-server
+                         (default #f))
+  (wins-proxy?           samba-configuration-wins-proxy?
+                         (default #f))
+  (dns-proxy?            samba-configuration-dns-proxy?
+                         (default #f))
+  (config-sections       samba-configuration-config-sections
+                         (default #f)))
+
+(define (samba-configuration-config-file global-extra-config
+                                         workgroup
+                                         server-string
+                                         server-role
+                                         bind-interfaces-only?
+                                         interfaces
+                                         hosts-allow
+                                         guest-account
+                                         log-file
+                                         logging
+                                         realm
+                                         passdb-backend
+                                         include-config
+                                         logon-path
+                                         wins-support?
+                                         wins-server
+                                         wins-proxy?
+                                         dns-proxy?
+                                         config-sections)
+  (mixed-text-file
+   "smb.conf"
+   "# Generated by samba-service.
+[global]
+" (if workgroup
+      (string-append "    workgroup = " workgroup "\n") "")
+(if server-string
+    (string-append "    server string = " server-string "\n") "")
+(if server-role
+    (string-append "    server role = " server-role "\n") "")
+(if bind-interfaces-only? "    bind interfaces only = Yes\n" "")
+(if (not (null? interfaces))
+    (string-append "    interfaces = " (string-join interfaces) "\n") "")
+(if (not (null? hosts-allow))
+    (string-append "    hosts allow = " (string-join hosts-allow) "\n") "")
+(if guest-account
+    (string-append "    guest account = " guest-account "\n") "")
+(if log-file
+    (string-append "    log file = " log-file "\n") "")
+(if logging
+    (string-append "    logging = " logging "\n") "")
+(if realm
+    (string-append "    realm = " realm "\n") "")
+(if passdb-backend
+    (string-append "    passdb backend = " passdb-backend "\n") "")
+(if include-config
+    (string-append "    include config = " include-config "\n") "")
+(if logon-path
+    (string-append "    logon path = " logon-path "\n") "")
+(if wins-support? "    wins support = Yes" "")
+(if wins-server
+    (string-append "    wins server = " wins-server "\n") "")
+(if wins-proxy? "    wins proxy = Yes\n" "")
+(if dns-proxy? "    dns proxy = Yes\n" "")
+(if global-extra-config
+    (string-append
+     "\n#Extra options provided by ‘global-extra-config’:\n"
+     global-extra-config "\n") "")
+(if config-sections
+    (string-append "\n#Contents of ‘config-sections’:\n"
+                   config-sections "\n") "")))
+
+(define samba-activation
+  (match-lambda
+    (($ <samba-configuration> package
+                              config-file
+                              ;; enable-samba? enable-smbd? enable-nmbd? enable-winbindd?
+                              _ _ _ _
+                              global-extra-config
+                              workgroup
+                              server-string
+                              server-role
+                              bind-interfaces-only?
+                              interfaces
+                              hosts-allow
+                              guest-account
+                              log-file
+                              logging
+                              realm
+                              passdb-backend
+                              include-config
+                              logon-path
+                              wins-support?
+                              wins-server
+                              wins-proxy?
+                              dns-proxy?
+                              config-sections)
+     (with-imported-modules '((guix build utils))
+       (let ((config-file
+              (or config-file
+                  (samba-configuration-config-file global-extra-config
+                                                   workgroup
+                                                   server-string
+                                                   server-role
+                                                   bind-interfaces-only?
+                                                   interfaces
+                                                   hosts-allow
+                                                   guest-account
+                                                   log-file
+                                                   logging
+                                                   realm
+                                                   passdb-backend
+                                                   include-config
+                                                   logon-path
+                                                   wins-support?
+                                                   wins-server
+                                                   wins-proxy?
+                                                   dns-proxy?
+                                                   config-sections)))
+             (lib-directory "/var/lib/samba")
+             (log-directory "/var/log/samba")
+             (run-directory "/var/run/samba")
+             (smb.conf "/etc/samba/smb.conf"))
+         #~(begin
+             (use-modules (guix build utils))
+             (mkdir-p #$log-directory)
+             (mkdir-p #$run-directory)
+             (mkdir-p (string-append #$lib-directory "/private"))
+
+             ;; I'd like to place smb.conf to /etc/samba.  It might
+             ;; make sense, since there will be other daemons wanting
+             ;; to access it.
+
+             (mkdir-p "/etc/samba")
+             (copy-file #$config-file #$smb.conf)
+
+             ;; Test config
+             (system* (string-append #$samba "/bin/testparm")
+                      "--suppress-prompt")
+
+             ;; (display #$(string-append lib-directory "/private\n"))
+             ;; (display (string-append #$(file-append samba "/sbin/smbd")
+             ;;                         (string-append "--configfile="
+             ;;                                        #$config-file)
+             ;;                         "--foreground"
+             ;;                         (string-append "--log-basename="
+             ;;                                        #$log-directory)
+             ;;                         "--no-process-group"))
+             ))))))
+
+(define samba-shepherd-service
+  (match-lambda
+    (($ <samba-configuration> package)
+     (let ((config-file "/etc/samba/smb.conf"))
+       (list (shepherd-service
+              (documentation "Run the Samba")
+              (provision '(samba))
+              (requirement '(networking))
+              (start #~(make-forkexec-constructor
+                        (list #$(file-append samba "/sbin/samba")
+                              (string-append "--configfile="
+                                             #$config-file)
+                              "--foreground"
+                              "--no-process-group")))
+              (stop #~(make-kill-destructor))))))))
+
+(define samba-nmbd-shepherd-service
+  (match-lambda
+    (($ <samba-configuration> package)
+     (let ((config-file "/etc/samba/smb.conf"))
+       (list (shepherd-service
+              (documentation "Run NetBIOS name server.")
+              (provision '(samba-nmbd))
+              (requirement '(networking))
+              (start #~(make-forkexec-constructor
+                        (list #$(file-append samba "/sbin/nmbd")
+                              (string-append "--configfile="
+                                             #$config-file)
+                              "--foreground"
+                              "--no-process-group")))
+              (stop #~(make-kill-destructor))))))))
+
+(define samba-smbd-shepherd-service
+  (match-lambda
+    (($ <samba-configuration> package)
+     (let ((config-file "/etc/samba/smb.conf"))
+       (list (shepherd-service
+              (documentation "Run SMB/CIFS service")
+              (provision '(samba-smbd))
+              (requirement '(networking))
+              (start #~(make-forkexec-constructor
+                        (list #$(file-append samba "/sbin/smbd")
+                              (string-append "--configfile="
+                                             #$config-file)
+                              "--foreground"
+                              "--no-process-group")))
+              (stop #~(make-kill-destructor))))))))
+
+(define samba-winbind-shepherd-service
+  (match-lambda
+    (($ <samba-configuration> package)
+     (let ((config-file "/etc/samba/smb.conf"))
+       (list (shepherd-service
+              (documentation "Run winbindd for Name Service Switch")
+              (provision '(samba-winbindd))
+              (requirement '(networking))
+              (start #~(make-forkexec-constructor
+                        (list #$(file-append samba "/sbin/winbindd")
+                              (string-append "--configfile="
+                                             #$config-file)
+                              "--foreground"
+                              "--no-process-group")))
+              (stop #~(make-kill-destructor))))))))
+
+(define (samba-shepherd-services config)
+  (append ;; (samba-shepherd-service config)
+             (samba-nmbd-shepherd-service config)
+             (samba-smbd-shepherd-service config)
+             (samba-winbind-shepherd-service config)))
+
+(define samba-service-type
+  (service-type
+   (name 'samba)
+   (description "Samba")
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             samba-shepherd-services)
+          (service-extension activation-service-type
+                             samba-activation)
+          ;; (service-extension account-service-type
+          ;;                    (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))))