diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/scm/webid-oidc/errors.scm | 20 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/Makefile.am | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/wac.scm | 226 |
3 files changed, 250 insertions, 2 deletions
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 60e45f7..c6802d7 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -920,6 +920,20 @@ container-not-empty? container-not-empty-path) +(define-exception-type + &cannot-fetch-group + &warning + make-cannot-fetch-group + cannot-fetch-group? + (group-uri cannot-fetch-group-group-uri) + (cause cannot-fetch-group-cause)) + +(export &cannot-fetch-group + make-cannot-fetch-group + cannot-fetch-group? + cannot-fetch-group-group-uri + cannot-fetch-group-cause) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -1276,6 +1290,10 @@ ((&container-not-empty) (format #f (G_ "the container ~s should be emptied before being deleted") (get 'path))) + ((&cannot-fetch-group) + (format #f (G_ "the group ~s cannot be fetched (because ~a)" + (uri->string (get 'group-uri)) + (recurse (get 'cause))))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) @@ -1312,6 +1330,8 @@ (get 'code))) ((&non-continuable) (format #f (G_ "the program cannot recover from this exception"))) + ((&external-error) + (format #f (G_ "there is an external error"))) ((&error) (format #f (G_ "there is an error"))) (else diff --git a/src/scm/webid-oidc/server/resource/Makefile.am b/src/scm/webid-oidc/server/resource/Makefile.am index 49cc912..efc41ce 100644 --- a/src/scm/webid-oidc/server/resource/Makefile.am +++ b/src/scm/webid-oidc/server/resource/Makefile.am @@ -1,7 +1,9 @@ dist_resourceserverwebidoidcmod_DATA += \ %reldir%/content.scm \ - %reldir%/path.scm + %reldir%/path.scm \ + %reldir%/wac.scm resourceserverwebidoidcgo_DATA += \ %reldir%/content.go \ - %reldir%/path.go + %reldir%/path.go \ + %reldir%/wac.go diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm new file mode 100644 index 0000000..e482ce4 --- /dev/null +++ b/src/scm/webid-oidc/server/resource/wac.scm @@ -0,0 +1,226 @@ +(define-module (webid-oidc server resource wac) + #: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 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 (rdf rdf) + #:use-module (turtle tordf) + #: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 + ( + + wac-get-modes + + )) + +(define (group-member? http-get group-uri agent) + (when (string? group-uri) + (set! group-uri (string->uri group-uri))) + (when (string? agent) + (set! group-uri (string->uri agent))) + (let ((group-doc-uri + (build-uri (uri-scheme group-uri) + #:userinfo (uri-userinfo group-uri) + #:host (uri-host group-uri) + #:port (uri-port group-uri) + #:path (uri-path group-uri) + #:query (uri-query group-uri)))) + (with-exception-handler + (lambda (error) + (raise-exception + (make-cannot-fetch-group group-uri error) + #:continuable? #t) + #f) + (lambda () + (let ((data (fetch group-doc-uri #:http-get http-get))) + (with-index + data + (lambda (rdf-match) + (not (null? + (rdf-match (uri->string group-uri) + "http://www.w3.org/2006/vcard/ns#hasMember" + (uri->string agent)))))))) + #:unwind? #t + #:unwind-for-type &cannot-fetch-linked-data))) + +(define (with-rdf-source server-name path content-type static-content f) + (with-index + (case content-type + ((text/turtle) + (turtle->rdf (string-append + "# This is not a file name\n" + (utf8->string static-content)) + (uri->string + (build-uri (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (string-append path ".acl")))))) + f)) + +(define (check-authorization path check-default? server-name final-path http-get user rdf-match id) + ;; The authorization should give accessTo path, + ;; or to a prefix of final-path; and it should + ;; be for agent user, or a group that contains + ;; user. + (let ((access-to-ok + (and + ;; We’re looking for acl:accessTo targetting path + (not + (null? + (rdf-match id "http://www.w3.org/ns/auth/acl#accessTo" + (uri->string + (build-uri (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path))))) + (or (not check-default?) + ;; We’re also looking for acl:default statement + ;; targetting a prefix of final-path + (let ((defaults + (map rdf-triple-object + (rdf-match id "http://www.w3.org/ns/auth/acl#default" #f)))) + (define (default-ok? uri) + (and (string? uri) + (string->uri uri) + (let ((uri (string->uri uri))) + (and (eq? (uri-scheme uri) + (uri-scheme server-name)) + (equal? (uri-userinfo uri) + (uri-userinfo server-name)) + (equal? (uri-host uri) + (uri-host server-name)) + (equal? (uri-port uri) + (uri-port server-name)) + (let ((final-path-components + (split-and-decode-uri-path final-path)) + (default-components + (split-and-decode-uri-path (uri-path uri)))) + (define (prefix? x y) + (or (null? x) + (and (not (null? y)) + (equal? (car x) (car y)) + (prefix? (cdr x) (cdr y))))) + (prefix? default-components final-path-components)))))) + (not (null? (filter default-ok? defaults))))))) + (agent-ok + (let ((groups + (map rdf-triple-object + (rdf-match id + "http://www.w3.org/ns/auth/acl#agentGroup" + #f))) + (specific-agent-ok? + (and user + (not (null? + (rdf-match id + "http://www.w3.org/ns/auth/acl#agent" + (uri->string user)))))) + (public-access? + (not (null? + (rdf-match id + "http://www.w3.org/ns/auth/acl#agentClass" + "http://xmlns.com/foaf/0.1/Agent")))) + (authenticated-access? + (not (null? + (rdf-match id + "http://www.w3.org/ns/auth/acl#agentClass" + "http://www.w3.org/ns/auth/acl#AuthenticatedAgent"))))) + (or public-access? + (and user authenticated-access?) + specific-agent-ok? + (and user + (not (null? + (filter (lambda (group) + (group-member? http-get group user)) + groups)))))))) + (or + (and access-to-ok + agent-ok + (filter + (lambda (x) x) + (map (lambda (triple) + (let ((mode (rdf-triple-object triple))) + (and (string? mode) + (string->uri mode)))) + (rdf-match id + "http://www.w3.org/ns/auth/acl#mode" + #f)))) + '()))) + +(define (check-authorizations path check-default? server-name final-path http-get user rdf-match + allowed-modes authorizations) + (if (null? authorizations) + (reverse allowed-modes) + (let ((new-modes + (check-authorization path check-default? server-name final-path http-get user rdf-match + (car authorizations)))) + (check-authorizations + path check-default? server-name final-path http-get user rdf-match + (append (reverse new-modes) allowed-modes) + (cdr authorizations))))) + +(define acl-aux (string->uri "http://www.w3.org/ns/auth/acl#accessControl")) + +(define* (wac-get-modes server-name final-path user + #:key + (http-get http-get)) + (with-session + (lambda (content-type contained static-content create delete) + (define (wac-check-recursive path check-default?) + (receive (main-etag auxiliary) (read-path path) + (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 http-get 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 + (lambda (a b) + (string< (uri->string a) (uri->string b))))))))) |