path: root/src/scm/webid-oidc/client/accounts.scm

(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 (web client)
  #:use-module (rnrs bytevectors)
  #:declarative? #t
  #: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-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 <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 (@ (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))
          tl)))))))

(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
        ,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
                         (@ (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
    (($ <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))))

(define (http-request->http-get http-request)
  (lambda* (uri . all-args)
    (apply http-request uri #:method 'GET all-args)))

;; subject is optional. If the user is unknown, ask for an issuer and
;; pass #f as subject.
(define* (login subject issuer
                #:key
                (http-request http-request)
                (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-request->http-get http-request))))
               (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-request token-endpoint
                               #:method 'POST
                               #: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
                        (format #f (G_ "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-request->http-get http-request)))))
                   ;; 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.
        ((($ <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))))))))