(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)))))))))