diff options
Diffstat (limited to 'src/scm/webid-oidc/authorization-endpoint.scm')
| -rw-r--r-- | src/scm/webid-oidc/authorization-endpoint.scm | 135 |
1 files changed, 42 insertions, 93 deletions
diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index cbf91cf..74417aa 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -16,10 +16,12 @@ (define-module (webid-oidc authorization-endpoint) #:use-module (webid-oidc errors) - #:use-module (webid-oidc authorization-page) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint identity-provider) #:use-module (webid-oidc jwk) #:use-module (webid-oidc authorization-code) #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web request) @@ -30,6 +32,7 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (ice-9 match) + #:use-module (sxml simple) #:use-module (oop goops) #:declarative? #t #:duplicates (merge-generics) @@ -40,97 +43,43 @@ )) -(define (verify-password encrypted-password password) - (let ((c (crypt password encrypted-password))) - (string=? c encrypted-password))) - -(define (make-authorization-endpoint subject encrypted-password jwk) - (define (parse-arg x decode-plus-to-space?) - (map (lambda (x) (uri-decode - x - #:decode-plus-to-space? decode-plus-to-space?)) - (string-split x #\=))) - (lambda* (request request-body) +(define (make-authorization-endpoint subject encrypted-password jwk-file) + (define endpoint + (make <authorization-endpoint> + #:subject subject + #:encrypted-password encrypted-password + #:key-file jwk-file)) + (lambda (request request-body) (when (bytevector? request-body) (set! request-body (utf8->string request-body))) - (let* ((uri (request-uri request)) - (method (request-method request)) - (query (uri-query uri)) - (query-parts (if query - (string-split query #\&) - '())) - (get-args (map (cute parse-arg <> #f) query-parts)) - (form-args - (match (request-content-type request) - ((application/x-www-form-urlencoded . _) - (map (cute parse-arg <> #t) - (string-split request-body #\&))) - (else '()))) - (accept-language - (sort (request-accept-language request) - (lambda (x y) (>= (car x) (car y))))) - (locale - (match accept-language - (((_ . lng) _ ...) lng) - (else "C")))) - (let ((client-id - (match (assoc-ref get-args "client_id") - (((? string->uri client-id) . _) - (string->uri client-id)) - (else #f))) - (redirect-uri - (match (assoc-ref get-args "redirect_uri") - (((? string->uri redirect-uri) . _) - (string->uri redirect-uri)) - (else #f))) - (password - (match (assoc-ref form-args "password") - ((password . _) - password) - (else #f))) - (state - (match (assoc-ref get-args "state") - ((state . _) - state) - (else #f)))) - (cond - ((not client-id) - (error-no-client-id locale)) - ((not redirect-uri) - (error-no-redirect-uri locale)) - ((and (eq? method 'POST) - (string? password) - (verify-password encrypted-password password)) - (with-exception-handler - (lambda (error) - (error-application locale error)) - (lambda () - (let ((code (issue <authorization-code> - jwk - #:webid subject - #:client-id client-id)) - (mf (make <client-manifest> - #:client-id client-id))) - (check-redirect-uri mf redirect-uri) - (let ((query - (if state - (format #f "code=~a&state=~a" - (uri-encode code) - (uri-encode state)) - (format #f "code=~a" - (uri-encode code))))) - (let ((uri - (build-uri 'https - #:userinfo (uri-userinfo redirect-uri) - #:host (uri-host redirect-uri) - #:port (uri-port redirect-uri) - #:path (uri-path redirect-uri) - #:query query))) - (redirection locale client-id uri))))) - #:unwind? #t)) - (else - (authorization-page locale - (not (and password - (verify-password encrypted-password password))) - client-id - uri))))))) + (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 authorization 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 endpoint request request-body) + (values response response-body))) + #:unwind? #t)))) |