diff options
Diffstat (limited to 'src/scm')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 2 | ||||
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 21 | ||||
-rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 145 | ||||
-rw-r--r-- | src/scm/webid-oidc/serve.scm | 73 |
4 files changed, 179 insertions, 62 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 867d2ee..bdb3af8 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -26,6 +26,7 @@ dist_webidoidcmod_DATA += \ %reldir%/jti.scm \ %reldir%/dpop-proof.scm \ %reldir%/fetch.scm \ + %reldir%/serve.scm \ %reldir%/client-manifest.scm \ %reldir%/authorization-code.scm \ %reldir%/refresh-token.scm \ @@ -57,6 +58,7 @@ webidoidcgo_DATA += \ %reldir%/jti.go \ %reldir%/dpop-proof.go \ %reldir%/fetch.go \ + %reldir%/serve.go \ %reldir%/client-manifest.go \ %reldir%/authorization-code.go \ %reldir%/refresh-token.go \ diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index c969a40..522e563 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -1036,6 +1036,22 @@ precondition-failed-if-none-match precondition-failed-real-etag) +(define-exception-type + ¬-acceptable + &external-error + make-not-acceptable + not-acceptable? + (client-accepts not-acceptable-client-accepts) + (path not-acceptable-path) + (content-type not-acceptable-content-type)) + +(export ¬-acceptable + make-not-acceptable + not-acceptable? + not-acceptable-client-accepts + not-acceptable-path + not-acceptable-content-type) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -1422,6 +1438,11 @@ (get 'path) (get 'if-match) (get 'if-none-match) (get 'real-etag)) (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has no representation") (get 'path) (get 'if-match) (get 'if-none-match)))) + ((¬-acceptable) + (format #f (G_ "the client wanted a response with a content type among ~s, but the resource at ~s has content-type ~s which cannot be converted to one of them") + (get 'client-accepts) + (get 'path) + (get 'content-type))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) 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))))))))) diff --git a/src/scm/webid-oidc/serve.scm b/src/scm/webid-oidc/serve.scm new file mode 100644 index 0000000..4f54495 --- /dev/null +++ b/src/scm/webid-oidc/serve.scm @@ -0,0 +1,73 @@ +;; webid-oidc, implementation of the Solid specification +;; Copyright (C) 2021 Vivien Kraus + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +(define-module (webid-oidc serve) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc fetch) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (ice-9 exceptions) + #:use-module (rnrs bytevectors) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (rdf rdf) + #:use-module (turtle fromrdf) + #:use-module (nquads fromrdf) + #:export + ( + convert + )) + +(define (convert client-accepts server-name path content-type content) + (let ((data-as-rdf + (false-if-exception + (fetch + (build-uri (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path) + #:http-get + (lambda args + (values (build-response + #:headers `((content-type ,content-type))) + content)))))) + (if client-accepts + ;; Content negociation is asked + (let try-satisfy ((accepts client-accepts)) + (if (null? accepts) + (raise-exception (make-not-acceptable client-accepts path content-type)) + (let ((request (caar accepts))) + (cond + ((or (eq? request content-type) + (eq? request '*/*)) + (values content-type content)) + ((and (eq? request 'text/turtle) data-as-rdf) + (values 'text/turtle + (rdf->turtle data-as-rdf))) + ((and (or (eq? request 'application/n-quads) + (eq? request 'text/x-nquads)) + data-as-rdf) + (values request + (rdf->nquads + (make-rdf-dataset data-as-rdf '())))) + ;; Add other conversion strategies here + (else + (try-satisfy (cdr accepts))))))) + ;; Content negociation is unwanted + (values content-type content)))) |