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

2 files changed, 66 insertions, 0 deletions

diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi
index ccb6e25..5900256 100644
--- a/doc/webid-oidc.texi
+++ b/doc/webid-oidc.texi
@@ -643,6 +643,16 @@ whatsoever, bypassing WAC. Otherwise, it is possible to steal control
 away from the data owner.
 @end deffn
 
+@deffn function check-acl-can-read @var{server-name} @var{path} @var{owner} @var{user} @var{[#:http-get]}
+@deffnx function check-acl-can-write @var{server-name} @var{path} @var{owner} @var{user} @var{[#:http-get]}
+@deffnx function check-acl-can-append @var{server-name} @var{path} @var{owner} @var{user} @var{[#:http-get]}
+@deffnx function check-acl-can-control @var{server-name} @var{path} @var{owner} @var{user} @var{[#:http-get]}
+Assert that the resource at @var{path} on @var{server-name} is owned
+by @var{owner}, and check that @var{user} has the proper
+authorization. Otherwise, raise an exception of type
+@code{&forbidden}.
+@end deffn
+
 @node Running a client
 @chapter Running a client
 
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")))