diff options
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
| -rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 86 |
1 files changed, 26 insertions, 60 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 77c0a81..65d64f0 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -28,6 +28,8 @@ #:use-module ((webid-oidc server resource path) #:prefix ldp:) #:use-module ((webid-oidc server resource content) #:prefix ldp:) #:use-module (webid-oidc server precondition) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint authentication) #:use-module (webid-oidc http-link) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -47,6 +49,8 @@ #:use-module (ice-9 exceptions) #:use-module (sxml simple) #:use-module (srfi srfi-19) + #:use-module (oop goops) + #:duplicates (merge-generics) #:declarative? #t #:export ( @@ -54,69 +58,31 @@ make-resource-server )) +(define-class <stub-endpoint> (<endpoint>)) + +(define return + (make-parameter #f)) + +(define-method (handle (endpoint <stub-endpoint>) request request-body) + ((return) (assq-ref (request-meta request) 'user))) + (define* (make-authenticator #:key (server-uri #f)) (unless (and server-uri (uri? server-uri)) (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))) - (lambda (request request-body) - (let ((headers (request-headers request)) - (uri (request-uri request)) - (method (request-method request)) - (current-time ((p:current-date)))) - (parameterize ((web-locale request) - (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) - (if (exception-with-message? error) - (format (current-error-port) - (G_ "~a: authentication failure: ~a\n") - (date->string current-time) - (exception-message error)) - (format (current-error-port) - (G_ "~a: authentication failure\n") - (date->string current-time))) - #f) - (lambda () - ;; Sometimes the access is the cadr as a symbol, - ;; sometimes it is the cdr as a string. It depends - ;; whether the response has been written and read, - ;; or preserved as a guile object. - (let* ((lit-access-token - (match authz - ;; That’s when the request is parsed: - (('dpop (? symbol? symbol-value)) - (symbol->string symbol-value)) - ;; That’s when it’s not: - (('dpop . (? string? string-value)) - string-value))) - (access-token - (decode <access-token> lit-access-token)) - (cnf/jkt (cnf/jkt access-token)) - (dpop-proof - (decode <dpop-proof> dpop - #:method method - #:uri full-uri - #:cnf/check cnf/jkt - #:access-token lit-access-token))) - (let ((subject (webid access-token)) - (issuer (iss access-token))) - (confirm-provider subject issuer) - subject))) - #:unwind? #t))))))) + (let* ((backend (make <stub-endpoint>)) + (endpoint (make <authenticator> + #:backend backend + #:server-uri server-uri))) + (lambda (request request-body) + (parameterize ((web-locale request)) + (with-exception-handler + (lambda (error) + #f) + (lambda () + (let/ec ret + (parameterize ((return ret)) + (handle endpoint request request-body)))) + #:unwind? #t))))) (define (handle-errors f g) (call/ec |