diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-06-24 20:24:40 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-06-27 00:19:33 +0200 |
commit | 636476eb01d93e222a22b55152a5eef1bb3329d3 (patch) | |
tree | 93bb1bec3e28ab6324af158d5c281b05c9d4c43e /src/scm | |
parent | d4ba8350e1c821e8a262ab3e84e440069069e34a (diff) |
Check client conditional request
Diffstat (limited to 'src/scm')
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 24 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/precondition.scm | 74 |
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)))) |