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

2 files changed, 181 insertions, 0 deletions

diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 7df1c66b9fa..8addaa8d5ac 100644
--- a/gnu/services/web.scm
+++ b/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
@@ -2184,6 +2193,128 @@ WSGIPassAuthorization On
 
 
 ;;;
+;;; 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.
 ;;;
 
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index 5c8905f62b8..b06cbcec115 100644
--- a/gnu/tests/web.scm
+++ b/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
@@ -782,6 +783,55 @@ HTTP-PORT."
 
 
 ;;;
+;;; 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
 ;;;