diff options
Diffstat (limited to 'src/scm/webid-oidc/client/accounts.scm')
| -rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 197 |
1 files changed, 110 insertions, 87 deletions
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 98fef85..447f760 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -17,6 +17,7 @@ #:use-module (web uri) #:use-module (web response) #:use-module (rnrs bytevectors) + #:declarative? #t #:export ( <account> @@ -79,17 +80,24 @@ (response token-request-response) (response-body token-request-response-body)) +(define-exception-type + &refresh-token-expired + &external-error + make-refresh-token-expired + refresh-token-expired?) + (define authorization-process (make-parameter (lambda* (uri #:key issuer) - (raise-exception - (make-exception - (make-authorization-code-required uri) - (make-exception-with-message - (G_ (format #f "An authorization code is required to log in with ~s, it can be obtained at ~s." - (uri->string issuer) - (uri->string uri))))) - #:continuable? #t)))) + (let ((final-message + (G_ (format #f "An authorization code is required to log in with ~s, it can be obtained at ~s." + (uri->string issuer) + (uri->string uri))))) + (raise-exception + (make-exception + (make-authorization-code-required uri) + (make-exception-with-message final-message)) + #:continuable? #t))))) (define-record-type <account> (make-account subject issuer id-token access-token refresh-token keypair) @@ -118,16 +126,17 @@ ((hd tl ...) (sxml-match hd - ((disfluid:id-token (@ (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp))) + ((disfluid:id-token (@ (alg ,alg) (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp))) (collect-arguments - (id:the-id-token-payload - `((webid . ,(uri->string subject)) - (iss . ,(uri->string issuer)) - (sub . ,sub) - (aud . ,aud) - (nonce . ,nonce) - (iat . ,(string->number iat)) - (exp . ,(string->number exp)))) + (id:the-id-token + `(((alg . ,alg)) + . ((webid . ,(uri->string subject)) + (iss . ,(uri->string issuer)) + (sub . ,sub) + (aud . ,aud) + (nonce . ,nonce) + (iat . ,(string->number iat)) + (exp . ,(string->number exp))))) access-token refresh-token keypair @@ -240,7 +249,8 @@ '()) (issuer ,(uri->string issuer))) ,@(if id-token - `((id-token (@ (sub ,(id:id-token-sub id-token)) + `((id-token (@ (alg ,(symbol->string (id:id-token-alg id-token))) + (sub ,(id:id-token-sub id-token)) (aud ,(uri->string (id:id-token-aud id-token))) (nonce ,(id:id-token-nonce id-token)) (iat @@ -404,105 +414,118 @@ (save-account (invalidate-refresh-token (make-account subject issuer #f #f #f #f)))) - (raise-exception - (make-refresh-token-expired) - (make-exception-with-message - (G_ (format #f "The refresh token has expired."))))) + (let ((final-message + (format #f (G_ "The refresh token has expired.")))) + (raise-exception + (make-exception + (make-refresh-token-expired) + (make-exception-with-message final-message))))) (unless (eqv? (response-code response) 200) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token request failed with code ~s (~s).") - (response-code response) - (response-reason-phrase response)))))) + (let ((final-message + (G_ (format #f "The token request failed with code ~s (~s).") + (response-code response) + (response-reason-phrase response)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (unless (response-content-type response) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response did not set the content type.")))))) + (let ((final-message + (format #f (G_ "The token response did not set the content type.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (with-exception-handler (lambda (encoding-error) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token endpoint did not respond in UTF-8."))) - encoding-error))) + (let ((final-message + (format #f (G_ "The token endpoint did not respond in UTF-8.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + encoding-error)))) (lambda () (when (bytevector? response-body) (set! response-body (utf8->string response-body))))) (unless (eq? (car (response-content-type response)) 'application/json) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response has content-type ~s, not application/json.") - (response-content-type response)))))) + (let ((final-message + (format #f (G_ "The token response has content-type ~s, not application/json.") + (response-content-type response)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (let ((data (with-exception-handler (lambda (json-error) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response is not valid JSON."))) - json-error))) + (let ((final-message + (format #f (G_ "The token response is not valid JSON.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + json-error)))) (lambda () (stubs:json-string->scm response-body))))) (let ((id-token (assq-ref data 'id_token)) (access-token (assq-ref data 'access_token)) (refresh-token (assq-ref data 'refresh_token))) (unless id-token - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response did not include an ID token: ~s") - data))))) + (let ((final-message + (format #f (G_ "The token response did not include an ID token: ~s") + data))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (unless access-token - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response did not include an access token: ~s + (let ((final-message + (format #f (G_ "The token response did not include an access token: ~s ") - data))))) + data))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (with-exception-handler (lambda (decoding-error) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The ID token signature is invalid."))) - decoding-error))) + (let ((final-message + (if (exception-with-message? decoding-error) + (format #f (G_ "the ID token signature is invalid: ~a") + (exception-message decoding-error)) + (format #f (G_ "the ID token signature is invalid"))))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + decoding-error)))) (lambda () - (match (id:id-token-decode id-token #:http-get http-get) - ((header . payload) - (set! id-token payload))))) + (set! id-token (id:id-token-decode id-token #:http-get http-get)))) ;; We are not interested in the ID token ;; signature anymore, because it won’t be ;; transmitted to other parties and we know that ;; it is valid. (when (and subject (not (equal? subject (id:id-token-webid id-token)))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The ID token delivered by the identity provider for ~s has ~s as webid.") - (uri->string subject) - (id:id-token-webid id-token)))))) + (let ((final-message + (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid") + (uri->string subject) + (id:id-token-webid id-token)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (when (not (equal? issuer (id:id-token-iss id-token))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The ID token delivered by the identity provider ~s is for issuer ~s.") - (uri->string issuer) - (id:id-token-iss id-token)))))) + (let ((final-message + (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.") + (uri->string issuer) + (id:id-token-iss id-token)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (make-account (id:id-token-webid id-token) issuer |