WAC: add auxiliary functions to check the well-known modes

1 files changed, 56 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm
index b9959f9..47748ca 100644
--- a/src/scm/webid-oidc/server/resource/wac.scm
+++ b/src/scm/webid-oidc/server/resource/wac.scm
@@ -26,6 +26,11 @@
 
    wac-get-modes
 
+   check-acl-can-read
+   check-acl-can-write
+   check-acl-can-append
+   check-acl-can-control
+
    ))
 
 (define (group-member? http-get group-uri agent)
@@ -233,3 +238,54 @@
         (sort all-modes
               (lambda (a b)
                 (string< (uri->string a) (uri->string b)))))))))
+
+(define (check-mode server-name path owner user http-get expected-mode)
+  (unless (equal? owner user)
+    (receive (base-path type)
+        (base-path path)
+      (when (equal? type (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby"))
+        ;; We’re checking the description resource, which is an alias
+        ;; for the real resource.
+        (set! path base-path))
+      (when (equal? type (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))
+        ;; We’re checking access modes for the ACL, so we’re looking
+        ;; for Control over the base resource.
+        (set! path base-path)
+        (set! expected-mode (string->uri "http://www.w3.org/ns/auth/acl#Control"))))
+    (let ((modes (wac-get-modes server-name path user #:http-get http-get)))
+      (define (check-modes modes)
+        (if (null? modes)
+            (raise-exception
+             (make-forbidden path user owner expected-mode))
+            (or
+             (equal? (car modes) expected-mode)
+             ;; It is also OK if we’re asking for acl:Append but
+             ;; acl:Write is provided.
+             (and (equal? expected-mode (string->uri "http://www.w3.org/ns/auth/acl#Append"))
+                  (equal? (car modes) (string->uri "http://www.w3.org/ns/auth/acl#Write")))
+             (check-modes (cdr modes)))))
+      (check-modes modes))))
+
+(define* (check-acl-can-read server-name path owner user
+                             #:key
+                             (http-get http-get))
+  (check-mode server-name path owner user http-get
+              (string->uri "http://www.w3.org/ns/auth/acl#Read")))
+
+(define* (check-acl-can-write server-name path owner user
+                             #:key
+                             (http-get http-get))
+  (check-mode server-name path owner user http-get
+              (string->uri "http://www.w3.org/ns/auth/acl#Write")))
+
+(define* (check-acl-can-append server-name path owner user
+                             #:key
+                             (http-get http-get))
+  (check-mode server-name path owner user http-get
+              (string->uri "http://www.w3.org/ns/auth/acl#Append")))
+
+(define* (check-acl-can-control server-name path owner user
+                             #:key
+                             (http-get http-get))
+  (check-mode server-name path owner user http-get
+              (string->uri "http://www.w3.org/ns/auth/acl#Control")))