diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-07 22:45:06 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-13 01:06:38 +0200 |
commit | db55d55e5c36c940986f437d26da1ff3c601c3b4 (patch) | |
tree | 0ecec5b2bd0b0bc6a02981a7c3b9ccafbb891c3b /src/scm/webid-oidc/client/accounts.scm | |
parent | 0b5d0622e11c1f919ce660893067d3121e2583a0 (diff) |
Make a better client API
Diffstat (limited to 'src/scm/webid-oidc/client/accounts.scm')
-rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 534 |
1 files changed, 534 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm new file mode 100644 index 0000000..98fef85 --- /dev/null +++ b/src/scm/webid-oidc/client/accounts.scm @@ -0,0 +1,534 @@ +(define-module (webid-oidc client accounts) + #:use-module (sxml simple) + #:use-module (sxml match) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 i18n) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc oidc-id-token) #:prefix id:) + #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:) + #:use-module ((webid-oidc jwk) #:prefix jwk:) + #:use-module ((webid-oidc dpop-proof) #:prefix dpop:) + #:use-module (web uri) + #:use-module (web response) + #:use-module (rnrs bytevectors) + #:export + ( + <account> + make-account + account? + account-subject + account-issuer + account-id-token + account-access-token + account-refresh-token + account-keypair + + authorization-process + + &authorization-code-required + make-authorization-code-required + authorization-code-required? + authorization-code-required-uri + + &refresh-token-expired + make-refresh-token-expired + refresh-token-expired? + + &token-request-failed + make-token-request-failed + token-request-failed? + token-request-response + token-request-response-body + + read-accounts + save-account + delete-account + invalidate-access-token + invalidate-refresh-token + login + ) + #:declarative? #t) + +(define (G_ text) + (let ((out (gettext text))) + (if (string=? out text) + ;; No translation, disambiguate + (car (reverse (string-split text #\|))) + out))) + +;; This exception is continuable! Continue with the authorization +;; code. +(define-exception-type + &authorization-code-required + &external-error + make-authorization-code-required + authorization-code-required? + (uri authorization-code-required-uri)) + +(define-exception-type + &token-request-failed + &external-error + make-token-request-failed + token-request-failed? + (response token-request-response) + (response-body token-request-response-body)) + +(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)))) + +(define-record-type <account> + (make-account subject issuer id-token access-token refresh-token keypair) + account? + (subject account-subject) + (issuer account-issuer) + (id-token account-id-token) + (access-token account-access-token) + (refresh-token account-refresh-token) + (keypair account-keypair)) + +(define (load-account-arguments subject issuer arguments) + (let collect-arguments ((id-token #f) + (access-token #f) + (refresh-token #f) + (keypair #f) + (arguments arguments)) + (match arguments + (() + (make-account subject + issuer + id-token + access-token + refresh-token + keypair)) + ((hd tl ...) + (sxml-match + hd + ((disfluid:id-token (@ (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)))) + access-token + refresh-token + keypair + tl)) + ((disfluid:access-token (@ (access-token ,access-token))) + (collect-arguments + id-token + access-token + refresh-token + keypair + tl)) + ((disfluid:refresh-token (@ (refresh-token ,refresh-token))) + (collect-arguments + id-token + access-token + refresh-token + keypair + tl)) + ((disfluid:rsa-keypair (@ (n ,n) (e (,e "AQAB")) + (d ,d) (p ,p) (q ,q) (dp ,dp) (dq ,dq) (qi ,qi))) + (collect-arguments + id-token + access-token + refresh-token + `(,@(jwk:make-rsa-public-key n e) + ,@(jwk:make-rsa-private-key d p q dp dq qi)) + tl)) + ((disfluid:ec-keypair (@ (crv ,crv) (x ,x) (y ,y) (d ,d))) + (collect-arguments + id-token + access-token + refresh-token + `(,@(jwk:make-ec-point crv x y) + ,@(jwk:make-ec-scalar crv d))))))))) + +(define (read-accounts) + (let generate-list + ((content + (catch #t + (lambda () + (call-with-input-file (string-append (p:data-home) "/profiles.xml") + (lambda (port) + (xml->sxml port + #:namespaces '((disfluid . "https://disfluid.planete-kraus.eu/client-account/v1")) + #:trim-whitespace? #t)))) + (lambda error + '(*TOP* + (disfluid:accounts))))) + (parsed-accounts '())) + (sxml-match + content + ((*TOP* + (disfluid:accounts)) + (reverse parsed-accounts)) + ((*TOP* + (disfluid:accounts + (disfluid:account + (@ (subject ,subject) + (issuer ,issuer)) + ,arguments ...) + ,other-accounts ...)) + (let ((account (load-account-arguments + (string->uri subject) + (string->uri issuer) arguments))) + (generate-list + `(*TOP* (disfluid:accounts ,@other-accounts)) + `(,account ,@parsed-accounts)))) + ((*TOP* + (disfluid:accounts + (disfluid:account + ;; the subject is not set yet + (@ (issuer ,issuer)) + ,arguments ...) + ,other-accounts ...)) + (let ((account (load-account-arguments + #f (string->uri issuer) arguments))) + (generate-list + `(*TOP* (disfluid:accounts ,@other-accounts)) + `(,account ,@parsed-accounts)))) + ((*TOP* + (disfluid:accounts + ,whatever + ,other-accounts ...)) + (generate-list `(*TOP* (disfluid:accounts ,@other-accounts)) parsed-accounts)) + ((*TOP* + ,whatever) + (generate-list `(*TOP* (disfluid:accounts)) parsed-accounts))))) + +(define (update-accounts transformer) + (stubs:atomically-update-file + (string-append (p:data-home) "/profiles.xml") + (string-append (p:data-home) "/profiles.xml.lock") + (lambda (port) + (let ((old-accounts (read-accounts))) + (let ((new-accounts (transformer old-accounts))) + (chmod port #o600) + (sxml->xml + `(*TOP* + (accounts + (@ (xmlns "https://disfluid.planete-kraus.eu/client-account/v1")) + ,@(map (match-lambda + (($ <account> subject issuer id-token access-token refresh-token keypair) + (when (string? subject) + (set! subject (string->uri subject))) + (when (string? issuer) + (set! issuer (string->uri issuer))) + `(account + (@ ,@(if subject + `((subject ,(uri->string subject))) + '()) + (issuer ,(uri->string issuer))) + ,@(if id-token + `((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 + ,(number->string + (time-second + (date->time-utc + (id:id-token-iat id-token))))) + (exp + ,(number->string + (time-second + (date->time-utc + (id:id-token-exp id-token)))))))) + '()) + ,@(if access-token + `((access-token (@ (access-token ,access-token)))) + '()) + ,@(if refresh-token + `((refresh-token (@ (refresh-token ,refresh-token)))) + '()) + ,@(if keypair + (case (jwk:kty keypair) + ((RSA) + `((rsa-keypair (@ (n ,(assq-ref keypair 'n)) + (e ,(assq-ref keypair 'e)) + (d ,(assq-ref keypair 'd)) + (p ,(assq-ref keypair 'p)) + (q ,(assq-ref keypair 'q)) + (dp ,(assq-ref keypair 'dp)) + (dq ,(assq-ref keypair 'dq)) + (qi ,(assq-ref keypair 'qi)))))) + ((EC) + `((ec-keypair (@ (crv ,(symbol->string (assq-ref keypair 'crv))) + (x ,(assq-ref keypair 'x)) + (y ,(assq-ref keypair 'y)) + (d ,(assq-ref keypair 'd))))))))))) + new-accounts))) + port)))))) + +(define (filter-out account old-accounts) + (match account + (($ <account> subject issuer _ _ _ _) + (filter + (match-lambda + (($ <account> other-subject other-issuer _ _ _ _) + ;; Keep it only if this is not the same user + (or (not (equal? other-subject subject)) + (not (equal? other-issuer issuer))))) + old-accounts)))) + +(define (save-account account) + (update-accounts + (lambda (old-accounts) + `(,account + ,@(filter-out account old-accounts)))) + account) + +(define (delete-account account) + (update-accounts + (lambda (old-accounts) + (filter-out account old-accounts)))) + +(define invalidate-access-token + (match-lambda + (($ <account> subject issuer _ _ refresh-token keypair) + (make-account subject issuer #f #f refresh-token keypair)))) + +(define invalidate-refresh-token + (match-lambda + (($ <account> subject issuer id-token access-token _ keypair) + (make-account subject issuer id-token access-token #f keypair)))) + +;; subject is optional. If the user is unknown, ask for an issuer and +;; pass #f as subject. +(define* (login subject issuer + #:key + (http-get http-get) + (http-post http-post) + (state #f) + client-id + client-key + redirect-uri) + (let ((all-accounts (if subject + ;; we’re expected to know the subject + (read-accounts) + ;; we’re not expected to know the subject + ;; anyway. + '()))) + (let find-access-token ((accounts (read-accounts)) + (available-refresh-token #f)) + (match accounts + (() ;; No access token available (or no ID token, or no key): + ;; requires authorization. + (receive (authorization-endpoint token-endpoint) + (let ((configuration + (cfg:get-oidc-configuration + (uri-host issuer) + #:userinfo (uri-userinfo issuer) + #:port (uri-port issuer) + #:http-get http-get))) + (values + (cfg:oidc-configuration-authorization-endpoint configuration) + (cfg:oidc-configuration-token-endpoint configuration))) + (let ((grant-type + (if available-refresh-token + "refresh_token" + "authorization_code")) + (grant + (or available-refresh-token + ;; Negociate an authorization code + (let ((authorization-uri + (build-uri + (uri-scheme authorization-endpoint) + #:userinfo (uri-userinfo authorization-endpoint) + #:host (uri-host authorization-endpoint) + #:port (uri-port authorization-endpoint) + #:path (uri-path authorization-endpoint) + #:query + (string-join + (map (match-lambda + ((key . value) + (string-join `(,(symbol->string key) + ,(uri-encode value)) + "="))) + `((client_id . ,(uri->string client-id)) + (redirect_uri . ,(uri->string redirect-uri)) + ,@(if state + `((state . ,state)) + '()))) + "&")))) + ((authorization-process) authorization-uri #:issuer issuer)))) + (dpop-proof + (dpop:issue-dpop-proof + client-key + #:alg (case (jwk:kty client-key) + ((EC) 'ES256) + ((RSA) 'RS256)) + #:htm 'POST + #:htu token-endpoint))) + ;; Post the token request with the correct grant: + (receive (response response-body) + (http-post token-endpoint + #:body + (string-join + (map + (match-lambda + ((key . value) + (string-append (uri-encode key) + "=" + (uri-encode value)))) + `(("grant_type" . ,grant-type) + (,(if available-refresh-token + "refresh_token" + "code") . ,grant))) + "&") + #:headers + `((content-type application/x-www-form-urlencoded) + (dpop . ,dpop-proof))) + ;; Check that the token endpoint responded correctly. + (when (eqv? (response-code response) 403) + (when subject + (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."))))) + (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)))))) + (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.")))))) + (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))) + (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 ((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))) + (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))))) + (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 +") + data))))) + (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))) + (lambda () + (match (id:id-token-decode id-token #:http-get http-get) + ((header . payload) + (set! id-token payload))))) + ;; 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)))))) + (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)))))) + (make-account + (id:id-token-webid id-token) + issuer + id-token + access-token + refresh-token + client-key))))))) + ;; There is an account with an access token that was still + ;; valid last time we used it. + ((($ <account> hd-subject hd-issuer hd-id-token hd-access-token hd-refresh-token hd-keypair) tl ...) + (cond + ((and (equal? hd-subject subject) + (equal? hd-issuer issuer) + hd-id-token + hd-access-token + hd-keypair) + ;; We can use it as is. + (make-account hd-subject hd-issuer + hd-id-token hd-access-token hd-refresh-token hd-keypair)) + ((and (equal? hd-subject subject) + (equal? hd-issuer issuer)) + ;; We know that user, but the access token has been + ;; invalidated. If it still has a refresh token, maybe try + ;; it. + (find-access-token '() hd-refresh-token)) + (else + ;; We can’t even use this refresh token, so we will try + ;; with the previous one. + (find-access-token tl available-refresh-token)))))))) |