diff options
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
| -rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 175 |
1 files changed, 175 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index cef6a0c..c69bc51 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -4,6 +4,12 @@ #:use-module (webid-oidc provider-confirmation) #:use-module (webid-oidc jwk) #:use-module (webid-oidc dpop-proof) + #: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 precondition) + #:use-module (webid-oidc http-link) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (webid-oidc jti) #:use-module (webid-oidc access-token) @@ -17,6 +23,7 @@ #:use-module (ice-9 i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 control) #:use-module (sxml simple) #:use-module (srfi srfi-19)) @@ -84,3 +91,171 @@ (confirm-provider subject issuer #:http-get http-get) subject))) #: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)))))) + +(define*-public (make-resource-server + #:key + (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))) + (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) + (with-exception-handler + (lambda (error) + (return + (build-response + #:headers headers) + (if (eq? method 'GET) + content + ""))) + (lambda () + (unless (or (request-if-match request) + (request-if-none-match request)) + ;; Act as if the precondition failed + (raise-exception + (make-precondition-failed + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + (car (assq-ref headers 'etag))))) + (check-precondition + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + (car (assq-ref headers 'etag))) + (return + (build-response + #:code 304 + #:reason-phrase "Not Modified" + #:headers headers) + ""))))) + ((PUT) + (return + (build-response + #:headers + `((etag . (,(update server-uri owner user + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + (request-content-type request) + request-body + #:http-get http-get) + . #f)))) + "")) + ((POST) + (let ((types + (map car + (filter + (lambda (link) + (equal? (assq-ref link 'rel) "type")) + (request-links request))))) + (return + (build-response + #:headers + `((location . ,(create server-uri owner user + (uri-path (request-uri request)) + types + (assq-ref (request-headers request) 'slug) + (request-content-type request) + request-body + #:http-get http-get)))) + ""))) + ((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) + ""))))) + (lambda (return error) + (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") + "")))))))))) |