diff options
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
| -rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 295 |
1 files changed, 44 insertions, 251 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 65d64f0..95fa78a 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -20,6 +20,9 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc serve) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint authentication) + #:use-module (webid-oidc server endpoint resource-server) #:use-module ((webid-oidc server create) #:prefix ldp:) #:use-module ((webid-oidc server read) #:prefix ldp:) #:use-module ((webid-oidc server update) #:prefix ldp:) @@ -49,6 +52,7 @@ #:use-module (ice-9 exceptions) #:use-module (sxml simple) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (oop goops) #:duplicates (merge-generics) #:declarative? #t @@ -84,78 +88,6 @@ (handle endpoint request request-body)))) #:unwind? #t))))) -(define (handle-errors f g) - (call/ec - (lambda (do-return) - (define (return . args) - (apply do-return args)) - (with-exception-handler - (lambda (error) - (g return error)) - (lambda () - (f return)) - #:unwind? #t)))) - -(define (nonrdf-or-turtle server-uri request request-body) - ;; If the request is an exotic RDF serialization - ;; format, we want to convert it to Turtle, - ;; otherwise we will consider it non-rdf. - (convert '(text/turtle */*) - server-uri - (uri-path (request-uri request)) - (match (request-content-type request) - ((or (? symbol? content-type) - ((? symbol? content-type) _ ...)) - content-type)) - request-body)) - -(define (serve-get return path if-match if-none-match content-type content etag headers user) - (define (respond-normal) - (return - (build-response - #:headers headers) - content - user)) - (if if-match - ;; If the precondition failed, then we should respond with 412 - (with-exception-handler - (lambda (error) - (unless (precondition-failed? error) - (raise-exception error)) - (return - (build-response - #:code 412 - #:reason-phrase (W_ "reason-phrase|Precondition Failed")) - #f - user)) - (lambda () - (check-precondition path if-match if-none-match etag) - (respond-normal))) - ;; If the precondition succeeds (if-none-match is effectively - ;; invalid), we return 200 - (with-exception-handler - (lambda (error) - (unless (precondition-failed? error) - (raise-exception error)) - (return - (build-response - #:code 304 - #:reason-phrase (W_ "reason-phrase|Not Modified") - #:headers - (filter - (lambda (h) - (case (car h) - ((cache-control content-location date etag expires vary) - #t) - (else #f))) - headers)) - #f - user)) - (lambda () - (when if-none-match - (check-precondition path if-match if-none-match etag)) - (respond-normal))))) - (define* (make-resource-server #:key (server-uri #f) @@ -164,183 +96,44 @@ (unless owner (fail (G_ "The owner is not defined."))) (declare-link-header!) - (unless authenticator - (set! authenticator - (make-authenticator - #:server-uri server-uri))) + (define resource-server + (make <resource-server> + #:server-name server-uri + #:owner owner)) + (define authenticator + (make <authenticator> + #:backend resource-server + #:server-uri server-uri)) (lambda (request request-body) - (parameterize ((p:current-date ((p:current-date))) ;; Fix the date - (web-locale request)) - (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))) - (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) - (unless content - (return - (build-response - #:code 400 - #:reason-phrase (W_ "Bad Request")) - "" - user)) - (let ((updated - (ldp:update server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - content-type - content))) - (return - (build-response - #:headers - `((etag . (,(ldp:etag updated) . #f)))) - "" - user)))) - ((POST) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (unless content - (return - (build-response - #:code 400 - #:reason-phrase (W_ "Bad Request")) - "" - user)) - (let ((types - (map target-iri - (filter - (lambda (link) - (equal? (relation-type link) "type")) - (request-links request))))) - (return - (build-response - #:code 201 #:reason-phrase (W_ "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)))) - "" - user)))) - ((DELETE) - (ldp:delete server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request)) - (return - (build-response) - "" - user))))) - (lambda (return error) - (if (wac:cannot-fetch-group? error) - (if (exception-with-message? error) - (format (current-error-port) - (G_ "~a: ignoring a group that cannot be fetched: ~a\n") - (date->string ((p:current-date))) - (exception-message error)) - (format (current-error-port) - (G_ "~a: ignoring a group that cannot be fetched\n") - (date->string ((p:current-date))))) - (cond - ((ldp:uri-slash-semantics-error? error) - (return - (build-response - #:code 301 - #:reason-phrase (W_ "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 (ldp:uri-slash-semantics-error-existing error))))) - #f - user)) - ((or (ldp:path-not-found? error) - (ldp:auxiliary-resource-absent? error) - (wac:forbidden? error)) - (if user - ;; That’s a forbidden - (return - (build-response #:code 403 #:reason-phrase (W_ "reason-phrase|Forbidden")) - #f - user) - (return - (build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized") - #:headers `((www-authenticate . ((DPoP))))) - #f - user))) - ((ldp:cannot-delete-root? error) - (return - (build-response - #:code 405 - #:reason-phrase (W_ "reason-phrase|Method Not Allowed")) - #f - user)) - ((or (ldp:container-not-empty? error) - (ldp:incorrect-containment-triples? error) - (ldp:path-is-auxiliary? error)) - (return - (build-response - #:code 409 - #:reason-phrase (W_ "reason-phrase|Conflict")) - #f - user)) - ((ldp:unsupported-media-type? error) - (return - (build-response - #:code 415 - #:reason-phrase (W_ "reason-phrase|Unsupported Media Type")) - #f - user)) - ((precondition-failed? error) - (return - (build-response - #:code 412 - #:reason-phrase (W_ "reason-phrase|Precondition Failed")) - #f - user)) - ((not-acceptable? error) - (return - (build-response - #:code 406 - #:reason-phrase (W_ "reason-phrase|Not Acceptable")) - #f - user)) - (else - (raise-exception error)))))))))) + (let/ec return + (parameterize ((web-locale request)) + (with-exception-handler + (lambda (exn) + (unless (web-exception? exn) + (raise-exception exn)) + (return + (build-response + #:code (web-exception-code exn) + #:reason-phrase (web-exception-reason-phrase exn) + #:headers `((content-type application/xhtml+xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(call-with-input-string + (format #f (W_ "<h1>The resource server request failed</h1>")) + xml->sxml) + ,(if (user-message? exn) + (user-message-sxml exn) + (call-with-input-string + (format #f (W_ "<p>No more information.</p>")) + xml->sxml))))) + <>)))) + (lambda () + (receive (response response-body response-meta) + (handle authenticator request request-body) + (return response response-body))) + #:unwind? #t))))) |