services: web: Add sogogi service.

* gnu/services/web.scm (sogogi-service-type): New services.
(sogogi-serialize-section, sogogi-serialize-field)
(sogogi-serialize-string, sogogi-serialize-list-of-strings)
(sogogi-serialize-sogogi-user, sogogi-serialize-sogogi-location)
(sogogi-serialize-list-of-sogogi-user): New procedures.
(sogogi-user, sogogi-location)
(sogogi-configuration): New record types.
(sogogi-account-service): New variable.
(sogogi-config-file, sogogi-shepherd-service): New procedures.
* gnu/tests/web.scm (%test-sogogi): Add tests for the service.
* doc/guix.texi (Web Services): Document it.

Change-Id: I5cc6dd84d6c7c8d5d13b685853b19c5d433ed7e5

doc/guix.texi

@@ -35893,6 +35893,75 @@ The port on which to connect to the database.
 @end table
 @end deftp
 
+@subsubheading sogogi
+
+@cindex sogogi, WebDAV Server
+@uref{https://codeberg.org/emersion/sogogi, sogogi} is a
+server for the
+@uref{https://www.rfc-editor.org/rfc/rfc4918, WebDAV} protocol.
+
+@defvar sogogi-service-type
+This is the service type for sogogi.  Its value must be a
+@code{sogogi-configuration} object as in this example:
+
+@lisp
+(service sogogi-service-type
+         (sogogi-configuration
+           (listen ":8080")
+           (location
+             (list
+               (sogogi-location
+                 (path "/")
+                 (dir "/srv/http/")
+                 (grant '("all ro")))))))
+@end lisp
+@end defvar
+
+@deftp {Data Type} sogogi-configuration
+Available @code{sogogi-configuration} fields are:
+
+@table @asis
+@item @code{listen} (default: @code{"localhost:8080"}) (type: string)
+Listening address.
+
+@item @code{location} (default: @code{()}) (type: list-of-sogogi-location)
+Local directories to expose via a HTTP path
+
+@item @code{user} (default: @code{()}) (type: list-of-sogogi-user)
+Users with access to the location.
+
+@end table
+@end deftp
+
+@deftp {Data Type} sogogi-location
+Available @code{sogogi-location} fields are:
+
+@table @asis
+@item @code{path} (type: string)
+HTTP path at which the directory will be exposed.
+
+@item @code{dir} (type: string)
+Path to local directory to serve.
+
+@item @code{grant} (type: maybe-list-of-strings)
+Grant remote users access to the directory.
+
+@end table
+@end deftp
+
+@deftp {Data Type} sogogi-user
+Available @code{sogogi-user} fields are:
+
+@table @asis
+@item @code{name} (type: maybe-string)
+Name of the user.
+
+@item @code{password} (type: maybe-string)
+Password of the user.
+
+@end table
+@end deftp
+
 @subsubheading Mumi
 
 @cindex Mumi, Debbugs Web interface

gnu/services/web.scm

@@ -313,6 +313,15 @@
             patchwork-virtualhost
             patchwork-service-type
 
+            sogogi-service-type
+            sogogi-configuration
+            sogogi-config-file
+            sogogi-configuration?
+            sogogi-user
+            sogogi-user?
+            sogogi-location
+            sogogi-location?
+
             mumi-configuration
             mumi-configuration?
             mumi-configuration-mumi
@@ -2182,6 +2191,128 @@ WSGIPassAuthorization On
    (description
     "Patchwork patch tracking system.")))
 
+
+;;;
+;;; sogogi.
+;;;
+
+(define (sogogi-serialize-section section-name value fields)
+  (let ((first-field (car fields)))
+    #~(format #f "~a ~a {~%~a}~%"
+              #$(object->string section-name)
+              #$((configuration-field-getter first-field) value)
+              #$(serialize-configuration value (cdr fields)))))
+
+(define (sogogi-serialize-field field-name value)
+  (let ((field (object->string field-name)))
+    #~(format #f "~a ~a~%" #$field #$value)))
+
+(define sogogi-serialize-string sogogi-serialize-field)
+(define (sogogi-serialize-list-of-strings field-name value)
+  #~(string-append
+      #$@(map (cut sogogi-serialize-string field-name <>)
+              value)))
+
+(define-maybe string (prefix sogogi-))
+(define-maybe list-of-strings (prefix sogogi-))
+
+(define-configuration sogogi-user
+  (name
+    maybe-string
+    "Name of the user.")
+
+  (password
+    maybe-string
+    "Password of the user.")
+
+  (prefix sogogi-))
+
+(define (sogogi-serialize-sogogi-user field-name value)
+  (sogogi-serialize-section field-name value sogogi-user-fields))
+
+(define-configuration sogogi-location
+  (path
+    string
+    "HTTP path at which the directory will be exposed.")
+
+  (dir
+    string
+    "Path to local directory to serve.")
+
+  (grant
+   maybe-list-of-strings
+   "Grant remote users access to the directory.")
+
+  (prefix sogogi-))
+
+(define (sogogi-serialize-sogogi-location field-name value)
+  (sogogi-serialize-section field-name value sogogi-location-fields))
+
+(define (sogogi-serialize-list-of-sogogi-location field-name value)
+  #~(string-append #$@(map (cut sogogi-serialize-sogogi-location field-name <>) value)))
+
+(define (sogogi-serialize-list-of-sogogi-user field-name value)
+  #~(string-append #$@(map (cut sogogi-serialize-sogogi-user field-name <>) value)))
+
+(define list-of-sogogi-user? (list-of sogogi-user?))
+(define list-of-sogogi-location? (list-of sogogi-location?))
+
+(define-configuration sogogi-configuration
+  (listen
+    (string "localhost:8080")
+    "Listening address.")
+
+  (location
+    (list-of-sogogi-location '())
+    "Local directories to expose via a HTTP path.")
+
+  (user
+    (list-of-sogogi-user '())
+    "Users with access to the location.")
+
+  (prefix sogogi-))
+
+(define (sogogi-config-file config)
+  (mixed-text-file "sogogi.conf"
+    (serialize-configuration
+      config
+      sogogi-configuration-fields)))
+
+(define (sogogi-shepherd-service config)
+  (let ((config-file (sogogi-config-file config)))
+    (list (shepherd-service
+            (documentation "Sogogi daemon.")
+            (provision '(sogogi))
+            ;; sogogi may be bound to a particular IP address, hence
+            ;; only start it after the networking service has started.
+            (requirement '(user-processes networking))
+            (actions (list (shepherd-configuration-action config-file)))
+            (start #~(make-forkexec-constructor
+                       (list (string-append #$sogogi "/bin/sogogi")
+                             "-config" #$config-file)))
+            (stop #~(make-kill-destructor))))))
+
+(define sogogi-account-service
+  (list (user-group (name "sogogi") (system? #t))
+        (user-account
+         (name "sogogi")
+         (group "sogogi")
+         (system? #t)
+         (comment "Sogogi daemon user")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define sogogi-service-type
+  (service-type (name 'sogogi)
+                (description "Run the sogogi WebDAV server.")
+                (extensions
+                  (list (service-extension account-service-type
+                                           (const sogogi-account-service))
+                        (service-extension shepherd-root-service-type
+                                           sogogi-shepherd-service)))
+                (compose concatenate)
+                (default-value (sogogi-configuration))))
+
 
 ;;;
 ;;; Mumi.

gnu/tests/web.scm

@@ -60,6 +60,7 @@
             %test-anonip
             %test-go-webdav
             %test-patchwork
+            %test-sogogi
             %test-agate
             %test-miniflux-admin-string
             %test-miniflux-admin-file
@@ -780,6 +781,55 @@ HTTP-PORT."
    (description "Connect to a running Patchwork service.")
    (value (run-patchwork-test patchwork))))
 
+
+;;;
+;;; sogogi
+;;;
+
+(define %sogogi-os
+  (simple-operating-system
+    (service dhcpcd-service-type)
+    (simple-service 'make-http-root activation-service-type
+                    %make-http-root)
+    (service sogogi-service-type
+             (sogogi-configuration
+               (listen ":8080")
+               (user
+                 (list
+                   (sogogi-user
+                     (name "testuser")
+                     (password "testpass"))))
+               (location
+                 (list
+                   (sogogi-location
+                     (path "/")
+                     (dir "/srv/http/")
+                     (grant '("all ro" "user:testuser rw")))))))))
+
+(define %test-sogogi
+  (system-test
+    (name "sogogi")
+    (description "Test that the sogogi can handle HTTP requests.")
+    (value
+      (let ((http-port 8080))
+        (run-webserver-test name %sogogi-os
+          #:http-port http-port
+          #:extra-tests
+          #~(begin
+              (use-modules (srfi srfi-11) (srfi srfi-64)
+                           (gnu build marionette)
+                           (web uri)
+                           (web client)
+                           (web response))
+
+              (test-equal "unauthenticated delete"
+                401
+                (let-values
+                  (((response _)
+                    (http-delete #$(simple-format
+                                     #f "http://localhost:~A/index.html" http-port))))
+                  (response-code response)))))))))
+
 
 ;;;
 ;;; Agate