(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) #:declarative? #t #:export ( 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-exception-type &refresh-token-expired &external-error make-refresh-token-expired refresh-token-expired?) (define authorization-process (make-parameter (lambda* (uri #:key issuer) (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 (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 (@ (alg ,alg) (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp))) (collect-arguments (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 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 (($ 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 (@ (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 ,(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 (($ subject issuer _ _ _ _) (filter (match-lambda (($ 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 (($ subject issuer _ _ refresh-token keypair) (make-account subject issuer #f #f refresh-token keypair)))) (define invalidate-refresh-token (match-lambda (($ 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)))) (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) (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) (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) (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) (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) (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 (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 (let ((final-message (format #f (G_ "The token response did not include an access token: ~s ") data))) (raise-exception (make-exception (make-token-request-failed response response-body) (make-exception-with-message final-message))))) (with-exception-handler (lambda (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 () (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)))) (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))) (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 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. ((($ 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))))))))