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

;; 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/>.

(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 (ice-9 optargs)
  #:use-module (ice-9 pretty-print)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc serializable)
  #: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)
  #:use-module ((webid-oidc jwk) #:prefix jwk:)
  #:use-module (webid-oidc dpop-proof)
  #:use-module ((webid-oidc client client) #:prefix client:)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (
   <account>
   subject set-subject
   issuer set-issuer
   id-token set-id-token
   access-token set-access-token
   refresh-token set-refresh-token
   key-pair set-key-pair

   <protected-account>
   username set-username
   encrypted-password set-encrypted-password
   check-credentials

   authorization-process
   authorization-state

   &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

   &login-failed
   make-login-failed
   login-failed?

   invalidate-access-token
   invalidate-refresh-token
   refresh
   )
  #:declarative? #t)

(define <jwk:key-pair> jwk:<key-pair>)
(define <id:id-token> id:<id-token>)

;; 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 (reason #f))
     (let ((final-message
            (if reason
                (format #f (G_ "an authorization code is required: ~s, it can be obtained at ~s")
                        reason
                        (uri->string uri))
                (format #f (G_ "an authorization code is required, it can be obtained at ~s")
                        (uri->string uri)))))
       (raise-exception
        (make-exception
         (make-authorization-code-required uri)
         (make-exception-with-message final-message))
        #:continuable? #t)))))

(define authorization-state
  (make-parameter #f))

(define-class <account> ()
  (subject #:init-keyword #:subject #:getter subject #:->sxml uri->string)
  (issuer #:init-keyword #:issuer #:getter issuer #:->sxml uri->string)
  (id-token #:init-keyword #:id-token #:getter id-token #:init-value #f)
  (access-token #:init-keyword #:access-token #:getter access-token #:init-value #f)
  (refresh-token #:init-keyword #:refresh-token #:getter refresh-token #:init-value #f)
  (key-pair #:init-keyword #:key-pair #:getter key-pair)
  #:metaclass <plugin-class>
  #:module-name '(webid-oidc client accounts))

(define-method (equal? (a <account>) (b <account>))
  (and (equal? (subject a) (subject b))
       (equal? (issuer a) (issuer b))
       (equal? (id-token a) (id-token b))
       (equal? (access-token a) (access-token b))
       (equal? (refresh-token a) (refresh-token b))
       (equal? (key-pair a) (key-pair b))))

(define-exception-type
  &login-failed
  &external-error
  make-login-failed
  login-failed?)

(define-method (initialize (account <account>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((subject #f)
    (issuer #f)
    (id-token #f)
    (access-token #f)
    (refresh-token #f)
    (key-pair #f))
   (match `(,subject ,issuer)
     (((or (? string? (= string->uri (? uri? subject)))
           (? uri? subject))
       (or (? string? (= string->uri (? uri? issuer)))
           (? uri? issuer)))
      (slot-set! account 'subject subject)
      (slot-set! account 'issuer issuer))
     ((#f
       (or (? string? (= string->uri (? uri? issuer)))
           (? uri? issuer)))
      ;; Create the account
      (let ((client (client:client)))
        (receive (authorization-endpoint token-endpoint)
            (let ((configuration
                   (make <oidc-configuration>
                     #:server issuer)))
              (values
               (authorization-endpoint configuration)
               (token-endpoint configuration)))
          (receive (grant-type grant)
              (if refresh-token
                  (values "refresh_token" refresh-token)
                  (values
                   "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:client-id client)))
                                   (redirect_uri . ,(uri->string (client:redirect-uri client)))
                                   ,@(let ((state (authorization-state)))
                                       (if state
                                           `((state . ,state))
                                           '()))))
                            "&"))))
                     ((authorization-process) authorization-uri
                      #:reason (format #f (G_ "the application wants to manage your account at ~s")
                                       (uri->string issuer))))))
            (unless key-pair
              (set! key-pair (client:key-pair client)))
            (let ((dpop-proof
                   (issue <dpop-proof>
                          key-pair
                          #:jwk (jwk:public-key key-pair)
                          #:htm 'POST
                          #:htu token-endpoint)))
              (receive (response response-body)
                  ((p:anonymous-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 (equal? grant-type "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)
                  (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)))))
                  (set! id-token (assq-ref data 'id_token))
                  (set! access-token (assq-ref data 'access_token))
                  (set! 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
                            (decode <id:id-token> id-token))))
                  ;; 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: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:webid id-token))))
                      (raise-exception
                       (make-exception
                        (make-token-request-failed response response-body)
                        (make-exception-with-message final-message)))))
                  (set! subject (id:webid id-token))
                  (when (not (equal? issuer (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:iss id-token))))
                      (raise-exception
                       (make-exception
                        (make-token-request-failed response response-body)
                        (make-exception-with-message final-message)))))
                  (slot-set! account 'subject subject)
                  (slot-set! account 'issuer issuer)
                  (slot-set! account 'id-token id-token)
                  (slot-set! account 'access-token access-token)
                  (slot-set! account 'refresh-token refresh-token)
                  (slot-set! account 'key-pair key-pair))))))))
     ((#f #f)
      (scm-error 'wrong-type-arg "make <account>"
                 (G_ "The issuer is required.")
                 '()
                 (list issuer)))
     (else
      (scm-error 'wrong-type-arg "make <account>"
                 (G_ "The optional subject and required issuer should be strings or URI.")
                 '()
                 (list subject issuer))))))

(define-class <protected-account> (<account>)
  (username #:init-keyword #:username #:getter username)
  (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password)
  #:module-name '(webid-oidc client accounts))

(define-method (check-credentials (account <protected-account>) (username <string>) (password <string>))
  (let ((c (crypt password (encrypted-password account))))
    (unless (string=? c (encrypted-password account))
      (raise-exception
       (make-exception
        (make-login-failed)
        (make-exception-with-message
         (G_ "Cannot check the username and/or password.")))))))

(define-method (set-subject (a <account>) uri)
  (let ((ret (shallow-clone a))
        (uri
         (match uri
           ((? uri? uri) uri)
           ((? string? (= string->uri (? uri? uri))) uri)
           (else
            (scm-error 'wrong-type-arg "set-subject"
                       (G_ "The subject should be a string or URI.")
                       '()
                       (list subject))))))
    (slot-set! ret 'subject uri)
    ret))

(define-method (set-issuer (a <account>) uri)
  (let ((ret (shallow-clone a))
        (uri
         (match uri
           ((? uri? uri) uri)
           ((? string? (= string->uri (? uri? uri))) uri)
           (else
            (scm-error 'wrong-type-arg "set-issuer"
                       (G_ "The issuer should be a string or URI.")
                       '()
                       (list issuer))))))
    (slot-set! ret 'issuer uri)
    ret))

(define-method (set-id-token (a <account>) id-token)
  (let ((ret (shallow-clone a)))
    (slot-set! ret 'id-token id-token)
    ret))

(define-method (set-access-token (a <account>) access-token)
  (let ((ret (shallow-clone a)))
    (slot-set! ret 'access-token access-token)
    ret))

(define-method (set-refresh-token (a <account>) refresh-token)
  (let ((ret (shallow-clone a)))
    (slot-set! ret 'refresh-token refresh-token)
    ret))

(define-method (set-key-pair (a <account>) (key-pair <jwk:key-pair>))
  (let ((ret (shallow-clone a)))
    (slot-set! ret 'key-pair key-pair)
    ret))

(define-method (set-username (a <protected-account>) username)
  (let ((ret (shallow-clone a)))
    (slot-set! ret 'username username)
    ret))

(define-method (set-encrypted-password (a <protected-account>) encrypted-password)
  (let ((ret (shallow-clone a)))
    (slot-set! ret 'encrypted-password encrypted-password)
    ret))

(define-method (invalidate-access-token (a <account>))
  (set-id-token
   (set-access-token a #f)
   #f))

(define-method (invalidate-refresh-token (a <account>))
  (set-refresh-token a #f))

(define-method (refresh (a <account>))
  ;; Fill the holes made by invalidate-access-token
  (let ((full
         (make <account>
           #:issuer (issuer a)
           #:refresh-token (refresh-token a)
           #:key-pair (key-pair a))))
    (unless (equal? (subject a) (subject full))
      (set! a (set-subject a (subject full))))
    (unless (equal? (issuer a) (issuer full))
      (set! a (set-issuer a (issuer full))))
    (unless (equal? (id-token a) (id-token full))
      (set! a (set-id-token a (id-token full))))
    (unless (equal? (access-token a) (access-token full))
      (set! a (set-access-token a (access-token full))))
    (unless (equal? (refresh-token a) (refresh-token full))
      (set! a (set-refresh-token a (refresh-token full))))
    (unless (equal? (key-pair a) (key-pair full))
      (set! a (set-key-pair a (key-pair full))))
    a))

(define-method (display (account <account>) port)
  (format port "<<account> subject: ~a, issuer: ~a, key-pair ID: ~a, id-token? ~a, access-token? ~a, refresh-token? ~a>"
          (uri->string (subject account))
          (uri->string (issuer account))
          (jwk:jkt (key-pair account))
          (if (id-token account) 'yes 'no)
          (if (access-token account) 'yes 'no)
          (if (refresh-token account) 'yes 'no)))