From 225749ff12fb1e78ae956296c9b42eca10489615 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Fri, 25 Jun 2021 17:04:07 +0200
Subject: Paths: parse auxiliary path types

---
 src/scm/webid-oidc/server/resource/path.scm | 58 +++++++++++++++++++++++++++++
 1 file changed, 58 insertions(+)

diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm
index 59ec9e0..8dc2dec 100644
--- a/src/scm/webid-oidc/server/resource/path.scm
+++ b/src/scm/webid-oidc/server/resource/path.scm
@@ -20,6 +20,15 @@
    read-path
    update-path
 
+   base-path
+
+   derive-path
+
+   auxiliary-path?
+   acl-path?
+   container-path?
+   root-path?
+
    ))
 
 (define (default-dir)
@@ -195,3 +204,52 @@
     (for-each
      delete
      (hash-map->list (lambda (garbage false) garbage) garbage))))
+
+(define (base-path path)
+  (define (check-suffix suffix type)
+    (let ((total-length (string-length path))
+          (suffix-length (string-length suffix)))
+      (if (string-suffix? suffix path)
+          (values
+           (substring path 0 (- total-length suffix-length))
+           type)
+          (values #f #f))))
+  (define (all-checks candidates)
+    (if (null? candidates)
+        (values path #f)
+        (receive (base type)
+            (check-suffix (caar candidates) (cdar candidates))
+          (if base
+              (values base type)
+              (all-checks (cdr candidates))))))
+  (all-checks
+   `((".acl"
+      . ,(string->uri "http://www.w3.org/ns/auth/acl#accessControl"))
+     (".meta"
+      . ,(string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby")))))
+
+(define (derive-path path type)
+  (receive (base base-type)
+      (base-path path)
+    (cond
+     ((equal? type (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))
+      (string-append base ".acl"))
+     ((equal? type (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby"))
+      (string-append base ".meta")))))
+
+(define (auxiliary-path? path)
+  (receive (base type)
+      (base-path path)
+    (values type base)))
+
+(define (acl-path? path)
+  (receive (base type)
+      (base-path path)
+    (and type
+         (equal? type (string->uri "http://www.w3.org/ns/auth/acl#accessControl")))))
+
+(define (container-path? path)
+  (string-suffix? "/" path))
+
+(define (root-path? path)
+  (equal? path "/"))
-- 
cgit v1.2.3