Check client conditional request

3 files changed, 102 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 80a4f37..5f07644 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -1002,6 +1002,24 @@
         forbidden-owner
         forbidden-mode)
 
+(define-exception-type
+  &precondition-failed
+  &external-error
+  make-precondition-failed
+  precondition-failed?
+  (path precondition-failed-path)
+  (if-match precondition-failed-if-match)
+  (if-none-match precondition-failed-if-none-match)
+  (real-etag precondition-failed-real-etag))
+
+(export &precondition-failed
+        make-precondition-failed
+        precondition-failed?
+        precondition-failed-path
+        precondition-failed-if-match
+        precondition-failed-if-none-match
+        precondition-failed-real-etag)
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -1378,6 +1396,12 @@
            (format #f (G_ "the operation on ~s by ~s is refused, because it’s not by ~s and the access control forbids the following mode of operation: ~s")
                    (get 'path) (uri->string (get 'user)) (uri->string (get 'owner))
                    (uri->string (get 'mode))))
+          ((&precondition-failed)
+           (if (get 'real-etag)
+               (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has a representation of ~s")
+                       (get 'path) (get 'if-match) (get 'if-none-match) (get 'real-etag))
+               (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has no representation")
+                       (get 'path) (get 'if-match) (get 'if-none-match))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/server/Makefile.am b/src/scm/webid-oidc/server/Makefile.am
index 2f14df5..f6627e5 100644
--- a/src/scm/webid-oidc/server/Makefile.am
+++ b/src/scm/webid-oidc/server/Makefile.am
@@ -1,9 +1,11 @@
 dist_serverwebidoidcmod_DATA += \
   %reldir%/create.scm \
-  %reldir%/read.scm
+  %reldir%/read.scm \
+  %reldir%/precondition.scm
 
 serverwebidoidcgo_DATA += \
   %reldir%/create.go \
-  %reldir%/read.go
+  %reldir%/read.go \
+  %reldir%/precondition.go
 
 include %reldir%/resource/Makefile.am
diff --git a/src/scm/webid-oidc/server/precondition.scm b/src/scm/webid-oidc/server/precondition.scm
new file mode 100644
index 0000000..94c6ae1
--- /dev/null
+++ b/src/scm/webid-oidc/server/precondition.scm
@@ -0,0 +1,74 @@
+(define-module (webid-oidc server precondition)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc server resource path)
+  #:use-module (webid-oidc server resource content)
+  #:use-module (webid-oidc cache)
+  #:use-module (webid-oidc fetch)
+  #:use-module (webid-oidc http-link)
+  #:use-module (webid-oidc server resource wac)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (webid-oidc rdf-index)
+  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (rdf rdf)
+  #:use-module (turtle tordf)
+  #:use-module (turtle fromrdf)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 threads)
+  #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:export
+  (
+
+   check-precondition
+
+   ))
+
+(define (the-etag object)
+  ;; Sometimes the user passes a pair as an etag (just like what
+  ;; request-if-match may return).
+  (if (pair? object)
+      (car object)
+      object))
+
+(define (check-if-match if-match real-etag)
+  ;; if-match is #f if no filter is used
+  (or (not if-match)
+      (eq? if-match '*)
+      (let check-rest ((precondition if-match))
+        (and (not (null? precondition))
+             (let ((first (the-etag (car precondition)))
+                   (rest (cdr precondition)))
+               (or (equal? first real-etag)
+                   (check-rest rest)))))))
+
+(define (check-if-none-match if-none-match real-etag)
+  ;; if-none-match is #f if there is no filter
+  (or (not if-none-match)
+      (if (eq? if-none-match '*)
+          (not real-etag)
+          ;; if-none-match is a list
+          (let check-rest ((forbidden if-none-match))
+            (or (null? forbidden)
+                (let ((first (the-etag (car forbidden)))
+                      (rest (cdr forbidden)))
+                  (and (not (equal? first real-etag))
+                       (check-rest rest))))))))
+
+(define (check-precondition path if-match if-none-match real-etag)
+  (unless (and (check-if-match if-match real-etag)
+               (check-if-none-match if-none-match real-etag))
+    (let ((error
+           (make-precondition-failed path if-match if-none-match real-etag)))
+      (unless real-etag
+        (set! error
+              (make-exception error (make-path-not-found path))))
+      (raise-exception error))))