diff options
Diffstat (limited to 'src/scm/webid-oidc/identity-provider.scm')
| -rw-r--r-- | src/scm/webid-oidc/identity-provider.scm | 150 |
1 files changed, 70 insertions, 80 deletions
diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index de56228..5970574 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -18,6 +18,8 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc authorization-endpoint) #:use-module (webid-oidc token-endpoint) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint identity-provider) #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc jwk) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -39,6 +41,7 @@ #:use-module (sxml simple) #:use-module (sxml match) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:duplicates (merge-generics) @@ -50,9 +53,16 @@ )) -(define* (same-uri? a b #:key (skip-query #f)) - (and (equal? (uri-path a) (uri-path b)) - (or skip-query (equal? (uri-query a) (uri-query b))))) +(define-class <default> (<endpoint>)) + +(define-method (handle (endpoint <default>) request request-body) + (raise-exception + (make-exception + (make-web-exception 404 (W_ "reason-phrase|Not Found")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Your request cannot be handled by the identity provider.</p>")) + xml->sxml))))) (define* (make-identity-provider issuer @@ -62,84 +72,64 @@ jwks-uri authorization-endpoint-uri token-endpoint-uri) - (let ((key - (catch #t - (lambda () - (call-with-input-file key-file - (lambda (port) - (jwk->key - (stubs:json->scm port))))) - (lambda error - (format (current-error-port) - (G_ "Warning: generating a new key pair.")) - (let ((k (generate-key #:n-size 2048))) - (stubs:call-with-output-file* - key-file - (lambda (port) - (stubs:scm->json (key->jwk k) port #:pretty #t))) - k))))) - (let ((authorization-endpoint - (make-authorization-endpoint subject encrypted-password key)) - (token-endpoint - (make-token-endpoint token-endpoint-uri issuer key)) - (openid-configuration + (let ((discovery + (make <oidc-discovery> + #:path "/.well-known/openid-configuration" + #:configuration (make <oidc-configuration> #:jwks-uri jwks-uri #:authorization-endpoint authorization-endpoint-uri - #:token-endpoint token-endpoint-uri)) - (openid-configuration-uri - (build-uri 'https - #:host (uri-host issuer) - #:path "/.well-known/openid-configuration"))) + #:token-endpoint token-endpoint-uri))) + (authz + (make <authorization-endpoint> + #:subject subject + #:encrypted-password encrypted-password + #:key-file key-file + #:path (uri-path authorization-endpoint-uri))) + (token + (make <token-endpoint> + #:path (uri-path token-endpoint-uri) + #:issuer issuer + #:key-file key-file)) + (jwks + (make <jwks-endpoint> + #:path (uri-path jwks-uri) + #:key-file key-file))) + (let ((idp (make <identity-provider> + #:oidc-discovery discovery + #:authorization-endpoint authz + #:token-endpoint token + #:jwks-endpoint jwks + #:default (make <default>)))) (lambda (request request-body) - (let ((uri (request-uri request)) - (current-time ((p:current-date)))) - (parameterize ((web-locale request)) - (cond ((same-uri? uri openid-configuration-uri) - (let* ((current-sec (time-second (date->time-utc current-time))) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve openid-configuration exp))) - ((same-uri? uri jwks-uri) - (let* ((current-sec (time-second (date->time-utc current-time))) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve (make <jwks> #:keys (list key)) exp))) - ((same-uri? uri authorization-endpoint-uri #:skip-query #t) - (authorization-endpoint request request-body)) - ((same-uri? uri token-endpoint-uri) - (token-endpoint request request-body)) - ((same-uri? uri subject) - (values - (build-response #:headers '((content-type text/turtle)) - #:port #f) - (format #f - "@prefix foaf: <http://xmlns.com/foaf/0.1/> . -@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> . - -<#~a> a foaf:Person ; - rdfs:comment \"It works. Now you should use another service to serve that resource.\" . -" - (uri-fragment subject)))) - (else - (values - (build-response #:code 404 - #:reason-phrase (W_ "reason-phrase|Not Found") - #:headers '((content-type application/xhtml+xml))) - (with-output-to-string - (lambda () - (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 - ,(sxml-match - (xml->sxml - (W_ (format #f "<h1>Resource not found</h1>"))) - ((*TOP* ,title) title)) - ,(sxml-match - (xml->sxml - (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>"))) - ((*TOP* ,p) p))))))))))))))))) + (parameterize ((web-locale request)) + (with-exception-handler + (lambda (exn) + (unless (web-exception? exn) + (raise-exception exn)) + (values + (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 identity provider 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 idp request request-body) + (values response response-body))) + #:unwind? #t)))))) |