diff options
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
| -rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 410 |
1 files changed, 201 insertions, 209 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index a6c111e..14d8b81 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -21,12 +21,13 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc serve) - #:use-module (webid-oidc server create) - #:use-module (webid-oidc server read) - #:use-module (webid-oidc server update) - #:use-module (webid-oidc server delete) + #:use-module ((webid-oidc server create) #:prefix ldp:) + #:use-module ((webid-oidc server read) #:prefix ldp:) + #:use-module ((webid-oidc server update) #:prefix ldp:) + #:use-module ((webid-oidc server delete) #:prefix ldp:) #:use-module (webid-oidc server precondition) #:use-module (webid-oidc http-link) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (webid-oidc jti) #:use-module (webid-oidc access-token) @@ -51,8 +52,7 @@ (car (reverse (string-split text #\|))) out))) -(define*-public (make-authenticator jti-list - #:key +(define*-public (make-authenticator #:key (server-uri #f) (current-time current-time) (http-get http-get)) @@ -62,52 +62,45 @@ (let ((headers (request-headers request)) (uri (request-uri request)) (method (request-method request)) - (current-time - (let ((t current-time)) - (when (thunk? t) - (set! t (t))) - (when (integer? t) - (set! t (make-time time-utc 0 t))) - (when (time? t) - (set! t (time-utc->date t))) - t))) - (let ((authz (assoc-ref headers 'authorization)) - (dpop (assoc-ref headers 'dpop)) - (full-uri (build-uri (uri-scheme server-uri) - #:userinfo (uri-userinfo server-uri) - #:host (uri-host server-uri) - #:port (uri-port server-uri) - #:path (string-append - "/" - (encode-and-join-uri-path - (append - (split-and-decode-uri-path (uri-path server-uri)) - (split-and-decode-uri-path - (uri-path uri)))))))) - (and authz dpop - (eq? (car authz) 'dpop) - (with-exception-handler - (lambda (error) - (format (current-error-port) - (G_ "~a: authentication failure: ~a\n") - (date->string current-time) - (error->str error)) - #f) - (lambda () - (let* ((lit-access-token (symbol->string (cadr authz))) - (access-token - (access-token-decode lit-access-token - #:http-get http-get)) - (cnf/jkt (access-token-cnf/jkt access-token)) - (dpop-proof - (dpop-proof-decode - current-time jti-list method full-uri - dpop cnf/jkt #:access-token lit-access-token))) - (let ((subject (access-token-webid access-token)) - (issuer (access-token-iss access-token))) - (confirm-provider subject issuer #:http-get http-get) - subject))) - #:unwind? #t)))))) + (current-time ((p:current-date)))) + (parameterize ((p:current-date current-time)) ;; fix the date + (let ((authz (assoc-ref headers 'authorization)) + (dpop (assoc-ref headers 'dpop)) + (full-uri (build-uri (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (string-append + "/" + (encode-and-join-uri-path + (append + (split-and-decode-uri-path (uri-path server-uri)) + (split-and-decode-uri-path + (uri-path uri)))))))) + (and authz dpop + (eq? (car authz) 'dpop) + (with-exception-handler + (lambda (error) + (format (current-error-port) + (G_ "~a: authentication failure: ~a\n") + (date->string current-time) + (error->str error)) + #f) + (lambda () + (let* ((lit-access-token (symbol->string (cadr authz))) + (access-token + (access-token-decode lit-access-token + #:http-get http-get)) + (cnf/jkt (access-token-cnf/jkt access-token)) + (dpop-proof + (dpop-proof-decode + method full-uri + dpop cnf/jkt #:access-token lit-access-token))) + (let ((subject (access-token-webid access-token)) + (issuer (access-token-iss access-token))) + (confirm-provider subject issuer #:http-get http-get) + subject))) + #:unwind? #t))))))) (define (handle-errors f g) (call/ec @@ -175,171 +168,170 @@ (server-uri #f) (owner #f) (authenticator #f) - (current-time current-time) (http-get http-get)) (unless owner (error "The owner is not defined.")) (declare-link-header!) (unless authenticator (set! authenticator - (make-authenticator (make-jti-list) - #:server-uri server-uri - #:current-time current-time - #:http-get http-get))) + (make-authenticator + #:server-uri server-uri + #:http-get http-get))) (lambda (request request-body) - (let ((user (authenticator request request-body))) - (handle-errors - (lambda (return) - (let ((method (request-method request))) - (case method - ((GET HEAD OPTIONS) - (receive (headers content) - (read server-uri owner user - (uri-path (request-uri request)) - #:http-get http-get) - (let ((true-content-type - (car (assq-ref headers 'content-type))) - (other-headers - (filter - (lambda (h) - (not (eq? (car h) 'content-type))) - headers))) - (receive (negociated-content-type - negociated-content) - (convert (request-accept request #f) - server-uri - (uri-path (request-uri request)) - true-content-type - content) - (serve-get - return - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - negociated-content-type - negociated-content - (car (assq-ref headers 'etag)) - (cons `(content-type ,negociated-content-type) - other-headers) - user))))) - ((PUT) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (return - (build-response - #:headers - `((etag . (,(update server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - content-type - content - #:http-get http-get) - . #f)))) - "" - user))) - ((POST) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (let ((types - (map car - (filter - (lambda (link) - (equal? (assq-ref link 'rel) "type")) - (request-links request))))) + (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date + (let ((user (authenticator request request-body))) + (handle-errors + (lambda (return) + (let ((method (request-method request))) + (case method + ((GET HEAD OPTIONS) + (receive (headers content) + (ldp:read server-uri owner user + (uri-path (request-uri request)) + #:http-get http-get) + (let ((true-content-type + (car (assq-ref headers 'content-type))) + (other-headers + (filter + (lambda (h) + (not (eq? (car h) 'content-type))) + headers))) + (receive (negociated-content-type + negociated-content) + (convert (request-accept request #f) + server-uri + (uri-path (request-uri request)) + true-content-type + content) + (serve-get + return + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + negociated-content-type + negociated-content + (car (assq-ref headers 'etag)) + (cons `(content-type ,negociated-content-type) + other-headers) + user))))) + ((PUT) + (receive (content-type content) + (nonrdf-or-turtle server-uri request request-body) (return (build-response - #:code 201 #:reason-phrase "Created" #:headers - `((location . ,(create server-uri owner user - (uri-path (request-uri request)) - types - (assq-ref (request-headers request) 'slug) - content-type - content - #:http-get http-get)))) + `((etag . (,(ldp:update server-uri owner user + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + content-type + content + #:http-get http-get) + . #f)))) "" - user)))) - ((DELETE) - (delete server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - #:http-get http-get) - (return - (build-response) - "" - user))))) - (lambda (return error) - (if (cannot-fetch-group? error) - (format (current-error-port) (G_ "Warning: ~a\n") - (error->str error)) - (cond - ((uri-slash-semantics-error? error) - (return - (build-response - #:code 301 - #:reason-phrase "Found" - #:headers - `((location - . ,(build-uri - (uri-scheme server-uri) - #:userinfo (uri-userinfo server-uri) - #:host (uri-host server-uri) - #:port (uri-port server-uri) - #:path (uri-slash-semantics-error-expected-path error))))) - #f - user)) - ((or (path-not-found? error) - (auxiliary-resource-absent? error) - (forbidden? error)) - (if user - ;; That’s a forbidden - (return - (build-response #:code 403 #:reason-phrase "Forbidden") - #f - user) - (return - (build-response #:code 401 #:reason-phrase "Unauthorized" - #:headers `((www-authenticate . ((DPoP))))) - #f - user))) - ((or (cannot-delete-root? error)) - (return - (build-response - #:code 405 - #:reason-phrase "Method Not Allowed") - #f - user)) - ((or (container-not-empty? error) - (incorrect-containment-triples? error) - (path-is-auxiliary? error)) - (return - (build-response - #:code 409 - #:reason-phrase "Conflict") - #f - user)) - ((unsupported-media-type? error) - (return - (build-response - #:code 415 - #:reason-phrase "Unsupported Media Type") - #f - user)) - ((precondition-failed? error) - (return - (build-response - #:code 412 - #:reason-phrase "Precondition Failed") - #f - user)) - ((not-acceptable? error) - (return - (build-response - #:code 406 - #:reason-phrase "Not Acceptable") - #f - user)) - (else - (raise-exception error))))))))) + user))) + ((POST) + (receive (content-type content) + (nonrdf-or-turtle server-uri request request-body) + (let ((types + (map car + (filter + (lambda (link) + (equal? (assq-ref link 'rel) "type")) + (request-links request))))) + (return + (build-response + #:code 201 #:reason-phrase "Created" + #:headers + `((location . ,(ldp:create server-uri owner user + (uri-path (request-uri request)) + types + (assq-ref (request-headers request) 'slug) + content-type + content + #:http-get http-get)))) + "" + user)))) + ((DELETE) + (ldp:delete server-uri owner user + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + #:http-get http-get) + (return + (build-response) + "" + user))))) + (lambda (return error) + (if (cannot-fetch-group? error) + (format (current-error-port) (G_ "Warning: ~a\n") + (error->str error)) + (cond + ((uri-slash-semantics-error? error) + (return + (build-response + #:code 301 + #:reason-phrase "Found" + #:headers + `((location + . ,(build-uri + (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (uri-slash-semantics-error-expected-path error))))) + #f + user)) + ((or (path-not-found? error) + (auxiliary-resource-absent? error) + (forbidden? error)) + (if user + ;; That’s a forbidden + (return + (build-response #:code 403 #:reason-phrase "Forbidden") + #f + user) + (return + (build-response #:code 401 #:reason-phrase "Unauthorized" + #:headers `((www-authenticate . ((DPoP))))) + #f + user))) + ((or (cannot-delete-root? error)) + (return + (build-response + #:code 405 + #:reason-phrase "Method Not Allowed") + #f + user)) + ((or (container-not-empty? error) + (incorrect-containment-triples? error) + (path-is-auxiliary? error)) + (return + (build-response + #:code 409 + #:reason-phrase "Conflict") + #f + user)) + ((unsupported-media-type? error) + (return + (build-response + #:code 415 + #:reason-phrase "Unsupported Media Type") + #f + user)) + ((precondition-failed? error) + (return + (build-response + #:code 412 + #:reason-phrase "Precondition Failed") + #f + user)) + ((not-acceptable? error) + (return + (build-response + #:code 406 + #:reason-phrase "Not Acceptable") + #f + user)) + (else + (raise-exception error)))))))))) |