diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-30 10:30:40 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-04 22:51:36 +0200 |
commit | 4a144d76950ac002996c3941c1eb4a5a6de6a661 (patch) | |
tree | cb7d3ec06647d1ceff2cb638064fc650c0f98622 /src/scm/webid-oidc/server/resource/wac.scm | |
parent | 668aa5736b2709e15e3ea14381e010c8646a4c38 (diff) |
Content API: use GOOPS for the cache
Diffstat (limited to 'src/scm/webid-oidc/server/resource/wac.scm')
-rw-r--r-- | src/scm/webid-oidc/server/resource/wac.scm | 108 |
1 files changed, 53 insertions, 55 deletions
diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm index d3f4adf..fd0d81e 100644 --- a/src/scm/webid-oidc/server/resource/wac.scm +++ b/src/scm/webid-oidc/server/resource/wac.scm @@ -242,61 +242,59 @@ (define acl-aux (string->uri "http://www.w3.org/ns/auth/acl#accessControl")) (define (wac-get-modes server-name final-path user) - (with-session - (lambda (content-type contained static-content create delete) - (define (wac-check-recursive path check-default?) - (receive (main-etag auxiliary) - (with-exception-handler - (lambda (error) - (unless (path-not-found? error) - (raise-exception error)) - (values #f '())) - (lambda () - (read-path path)) - #:unwind? #t - #:unwind-for-type &path-not-found) - (let ((acl-etag (assoc-ref auxiliary acl-aux))) - (if acl-etag - (with-rdf-source - server-name path (content-type acl-etag) (static-content acl-etag) - (lambda (rdf-match) - (check-authorizations - path check-default? server-name final-path user rdf-match - '() - (map rdf-triple-subject - (rdf-match #f - "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" - "http://www.w3.org/ns/auth/acl#Authorization"))))) - ;; No existing ACL. - (let ((parent-path - (string-append - "/" - (encode-and-join-uri-path - (reverse - (cdr - (reverse - (split-and-decode-uri-path path))))) - "/"))) - (when (equal? parent-path "//") - ;; The parent is the root - (set! parent-path "/")) - (wac-check-recursive parent-path #t)))))) - (let ((all-modes (wac-check-recursive final-path #f))) - (define (accumulate-unique accumulated list) - (cond - ((null? list) - (reverse accumulated)) - ((or (null? accumulated) (not (equal? (car accumulated) (car list)))) - (accumulate-unique (cons (car list) accumulated) (cdr list))) - (else - (accumulate-unique accumulated (cdr list))))) - (accumulate-unique - '() - (sort all-modes - (match-lambda* - (((? uri? (= uri->string a)) - (? uri? (= uri->string b))) - (string< a b))))))))) + (define (wac-check-recursive path check-default?) + (receive (main auxiliary) + (with-exception-handler + (lambda (error) + (unless (path-not-found? error) + (raise-exception error)) + (values #f '())) + (lambda () + (read-path path)) + #:unwind? #t + #:unwind-for-type &path-not-found) + (let ((acl (assoc-ref auxiliary acl-aux))) + (if acl + (with-rdf-source + server-name path (content-type acl) (static-content acl) + (lambda (rdf-match) + (check-authorizations + path check-default? server-name final-path user rdf-match + '() + (map rdf-triple-subject + (rdf-match #f + "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" + "http://www.w3.org/ns/auth/acl#Authorization"))))) + ;; No existing ACL. + (let ((parent-path + (string-append + "/" + (encode-and-join-uri-path + (reverse + (cdr + (reverse + (split-and-decode-uri-path path))))) + "/"))) + (when (equal? parent-path "//") + ;; The parent is the root + (set! parent-path "/")) + (wac-check-recursive parent-path #t)))))) + (let ((all-modes (wac-check-recursive final-path #f))) + (let accumulate-unique ((accumulated '()) + (list (sort all-modes + (match-lambda* + (((? uri? (= uri->string a)) + (? uri? (= uri->string b))) + (string< a b)))))) + (match list + (() (reverse accumulated)) + ((hd list ...) + (match accumulated + ((or () ;; Nothing accumulated, can’t be unique + ((? (lambda (head) (not (equal? head hd)))) _ ...)) + (accumulate-unique `(,hd ,@accumulated) list)) + (else + (accumulate-unique accumulated list)))))))) (define (check-mode server-name path owner user expected-mode) (unless (equal? owner user) |