diff options
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
| -rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 145 |
1 files changed, 83 insertions, 62 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 9988cba..7f9c8f9 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc provider-confirmation) #: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) @@ -148,12 +149,27 @@ #:http-get http-get) (with-exception-handler (lambda (error) - (return - (build-response - #:headers headers) - (if (eq? method 'GET) - content - ""))) + (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) + (return + (build-response + #:headers (cons `(content-type ,negociated-content-type) + other-headers)) + (if (eq? method 'GET) + negociated-content + ""))))) (lambda () (unless (or (request-if-match request) (request-if-none-match request)) @@ -220,59 +236,64 @@ (if (cannot-fetch-group? error) (format (current-error-port) (G_ "Warning: ~a\n") (error->str error)) - (begin - (format (current-error-port) (G_ "Error: ~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))))) - "")) - ((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") - "") - (return - (build-response #:code 401 #:reason-phrase "Unauthorized" - #:headers `((www-authenticate . ((DPoP))))) - ""))) - ((or (cannot-delete-root? error)) - (return - (build-response - #:code 405 - #:reason-phrase "Method Not Allowed") - "")) - ((or (container-not-empty? error) - (incorrect-containment-triples? error) - (path-is-auxiliary? error)) - (return - (build-response - #:code 409 - #:reason-phrase "Conflict") - "")) - ((unsupported-media-type? error) - (return - (build-response - #:code 415 - #:reason-phrase "Unsupported Media Type") - "")) - ((precondition-failed? error) - (return - (build-response - #:code 412 - #:reason-phrase "Precondition Failed") - "")))))))))) + (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)) + ((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) + (return + (build-response #:code 401 #:reason-phrase "Unauthorized" + #:headers `((www-authenticate . ((DPoP))))) + #f))) + ((or (cannot-delete-root? error)) + (return + (build-response + #:code 405 + #:reason-phrase "Method Not Allowed") + #f)) + ((or (container-not-empty? error) + (incorrect-containment-triples? error) + (path-is-auxiliary? error)) + (return + (build-response + #:code 409 + #:reason-phrase "Conflict") + #f)) + ((unsupported-media-type? error) + (return + (build-response + #:code 415 + #:reason-phrase "Unsupported Media Type") + #f)) + ((precondition-failed? error) + (return + (build-response + #:code 412 + #:reason-phrase "Precondition Failed") + #f)) + ((not-acceptable? error) + (return + (build-response + #:code 406 + #:reason-phrase "Not Acceptable") + #f)) + (else + (raise-exception error))))))))) |