Better structuring between webdav modules.

4 files changed, 87 insertions, 52 deletions

diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm
index 781a85d9..7cbdd32e 100644
--- a/module/calp/server/webdav.scm
+++ b/module/calp/server/webdav.scm
@@ -26,6 +26,7 @@
   :use-module (calp webdav property)
   :use-module (calp webdav propfind)
   :use-module (calp webdav proppatch)
+  :use-module (calp webdav util)
   :use-module (oop goops)
   :export (; run-run
            run-propfind
@@ -156,33 +157,6 @@
 
 
 
-(define (parse-dav-line str)
-  (map (lambda (item)
-         (cond ((string-match "^[0-9]+$" item)
-                => (lambda (m) (number->string (match:substring m))))
-               ((string-match "^<(.*)>$" item)
-                => (lambda (m) (string->uri (match:substring m 1))))
-               (else (string->symbol item))))
-       (map string-trim-both (string-split str #\,))))
-
-(define (validate-dav-line lst)
-  (every (lambda (item)
-           (or (and (number? item) (<= 1 item 3))
-               (uri? item)
-               ;; Possibly check against list of valid tokens
-               (symbol? item)))
-         lst))
-
-(define (write-dav-line lst port)
-  (display
-   (string-join (map (lambda (item)
-                       (cond ((number? item) (number->string item))
-                             ((uri? item) (string-append "<" (uri->string item) ">"))
-                             (else (symbol->string item))))
-                     lst)
-                ", " 'infix)
-   port))
-
 (declare-header! "DAV"
   parse-dav-line
   validate-dav-line
diff --git a/module/calp/webdav/util.scm b/module/calp/webdav/util.scm
new file mode 100644
index 00000000..e65ecfc5
--- /dev/null
+++ b/module/calp/webdav/util.scm
@@ -0,0 +1,40 @@
+(define-module (calp webdav util)
+  :use-module (srfi srfi-1)
+  :use-module (ice-9 regex)
+  :use-module (web uri)
+  :export (parse-dav-line
+           validate-dav-line
+           write-dav-line)
+  )
+
+;;; Parse a DAV HTTP header's content as specified in RFC 4918 §10.1
+;;; For example:
+;;;     DAV: 1, 2, access-control, calendar-access
+(define (parse-dav-line str)
+  (map (lambda (item)
+         (cond ((string-match "^[0-9]+$" item)
+                => (lambda (m) (string->number (match:substring m))))
+               ((string-match "^<(.*)>$" item)
+                => (lambda (m) (string->uri (match:substring m 1))))
+               (else (string->symbol item))))
+       (map string-trim-both (string-split str #\,))))
+
+(define (validate-dav-line lst)
+  (every (lambda (item)
+           (or (and (number? item) (<= 1 item 3))
+               (uri? item)
+               ;; Possibly check against list of valid tokens
+               (symbol? item)))
+         lst))
+
+
+
+(define (write-dav-line lst port)
+  (display
+   (string-join (map (lambda (item)
+                       (cond ((number? item) (number->string item))
+                             ((uri? item) (string-append "<" (uri->string item) ">"))
+                             (else (symbol->string item))))
+                     lst)
+                ", " 'infix)
+   port))
diff --git a/tests/unit/webdav/webdav-resource.scm b/tests/unit/webdav/webdav-resource.scm
new file mode 100644
index 00000000..73a434be
--- /dev/null
+++ b/tests/unit/webdav/webdav-resource.scm
@@ -0,0 +1,31 @@
+(define-module (test webdav-resource)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-64 test-error)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (calp webdav resource base))
+
+(test-group "string->href"
+  (test-equal "Root path becomes null"
+    '() (string->href "/"))
+  (test-equal "Trailing slashes are ignored"
+    '("a" "b") (string->href "/a/b/")))
+
+(test-group "href->string"
+  (test-equal "Null case becomes root path"
+    "/" (href->string '()))
+  (test-equal "Trailing slashes are not added"
+    "/a/b" (href->string '("a" "b"))))
+
+(test-group "href-relative"
+  (test-equal '("a" "b") (href-relative '() '("a" "b")))
+  (test-equal '("b") (href-relative '("a") '("a" "b")))
+  (test-equal '() (href-relative '("a" "b") '("a" "b")))
+
+  (test-error 'misc-error
+    (href-relative '("c") '("a" "b")))
+
+  (test-error 'misc-error
+    (href-relative '("c") '())))
+
+'((calp webdav resource base))
diff --git a/tests/unit/webdav/webdav-util.scm b/tests/unit/webdav/webdav-util.scm
index c4e16536..64c916ec 100644
--- a/tests/unit/webdav/webdav-util.scm
+++ b/tests/unit/webdav/webdav-util.scm
@@ -1,31 +1,21 @@
-(define-module (test webdav-util)
+(define-module (test webdav-test)
   :use-module (srfi srfi-64)
-  :use-module (srfi srfi-64 test-error)
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
-  :use-module (calp webdav resource base))
+  :use-module (web uri)
+  :use-module (calp webdav util)
+   )
 
-(test-group "string->href"
-  (test-equal "Root path becomes null"
-    '() (string->href "/"))
-  (test-equal "Trailing slashes are ignored"
-    '("a" "b") (string->href "/a/b/")))
+(test-equal "Parse-dav-line"
+  `(1 2 access-control ,(string->uri "http://example.com/uri"))
+  (parse-dav-line "1, 2, access-control, <http://example.com/uri>"))
 
-(test-group "href->string"
-  (test-equal "Null case becomes root path"
-    "/" (href->string '()))
-  (test-equal "Trailing slashes are not added"
-    "/a/b" (href->string '("a" "b"))))
+(test-equal "write-dav-line"
+  "1, 2, access-control, <http://example.com/uri>"
+  (call-with-output-string
+    (lambda (port)
+      (write-dav-line
+       `(1 2 access-control ,(string->uri "http://example.com/uri"))
+       port))))
 
-(test-group "href-relative"
-  (test-equal '("a" "b") (href-relative '() '("a" "b")))
-  (test-equal '("b") (href-relative '("a") '("a" "b")))
-  (test-equal '() (href-relative '("a" "b") '("a" "b")))
-
-  (test-error 'misc-error
-    (href-relative '("c") '("a" "b")))
-
-  (test-error 'misc-error
-    (href-relative '("c") '())))
-
-'((calp webdav resource base))
+'((calp webdav util))