;; 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 .
(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
(
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
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:)
(define id:)
;; 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 ()
(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
#:module-name '(webid-oidc client accounts))
(define-method (equal? (a ) (b ))
(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 ) 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
#: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
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-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 "
(G_ "The issuer is required.")
'()
(list issuer)))
(else
(scm-error 'wrong-type-arg "make "
(G_ "The optional subject and required issuer should be strings or URI.")
'()
(list subject issuer))))))
(define-class ()
(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 ) (username ) (password ))
(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 ) 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 ) 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 ) id-token)
(let ((ret (shallow-clone a)))
(slot-set! ret 'id-token id-token)
ret))
(define-method (set-access-token (a ) access-token)
(let ((ret (shallow-clone a)))
(slot-set! ret 'access-token access-token)
ret))
(define-method (set-refresh-token (a ) refresh-token)
(let ((ret (shallow-clone a)))
(slot-set! ret 'refresh-token refresh-token)
ret))
(define-method (set-key-pair (a ) (key-pair ))
(let ((ret (shallow-clone a)))
(slot-set! ret 'key-pair key-pair)
ret))
(define-method (set-username (a ) username)
(let ((ret (shallow-clone a)))
(slot-set! ret 'username username)
ret))
(define-method (set-encrypted-password (a ) encrypted-password)
(let ((ret (shallow-clone a)))
(slot-set! ret 'encrypted-password encrypted-password)
ret))
(define-method (invalidate-access-token (a ))
(set-id-token
(set-access-token a #f)
#f))
(define-method (invalidate-refresh-token (a ))
(set-refresh-token a #f))
(define-method (refresh (a ))
;; Fill the holes made by invalidate-access-token
(let ((full
(make
#: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 ) port)
(format port "< 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)))