Make a better client API

2 files changed, 555 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/client/Makefile.am b/src/scm/webid-oidc/client/Makefile.am
new file mode 100644
index 0000000..ccb7e35
--- /dev/null
+++ b/src/scm/webid-oidc/client/Makefile.am
@@ -0,0 +1,21 @@
+# disfluid, implementation of the Solid specification
+# Copyright (C) 2021  Vivien Kraus
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU Affero General Public License as
+# published by the Free Software Foundation, either version 3 of the
+# License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU Affero General Public License for more details.
+
+# You should have received a copy of the GNU Affero General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+dist_clientwebidoidcmod_DATA += \
+  %reldir%/accounts.scm
+
+clientwebidoidcgo_DATA += \
+  %reldir%/accounts.go
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))))))))