;; 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 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 ((webid-oidc client client) #:prefix client:)
#:use-module (web uri)
#:use-module (web response)
#:use-module (web client)
#: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
anonymous-http-request
&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
->sexp
)
#:declarative? #t)
(define jwk:)
;; 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 authorization-state
(make-parameter #f))
(define anonymous-http-request
(make-parameter http-request))
(define (http-request->http-get http-request)
(lambda* (uri . all-args)
(apply http-request uri #:method 'GET all-args)))
(define (http-get-implementation)
(http-request->http-get (anonymous-http-request)))
(define-class ()
(subject #:init-keyword #:subject #:getter subject)
(issuer #:init-keyword #:issuer #:getter issuer)
(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))
(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-method (->sexp (account ))
`(begin
(use-modules (oop goops) (webid-oidc client accounts) (webid-oidc jwk))
(make
#:subject ,(uri->string (subject account))
#:issuer ,(uri->string (issuer account))
,@(let ((id-token (id-token account)))
(if id-token
`(#:id-token (quote ,id-token))
'()))
,@(let ((access-token (access-token account)))
(if access-token
`(#:access-token ,access-token)
'()))
,@(let ((refresh-token (refresh-token account)))
(if refresh-token
`(#:refresh-token ,refresh-token)
'()))
#:key-pair (jwk->key (quote ,(key->jwk (key-pair account)))))))
(define-method (write (account ) port)
(let ((code (->sexp account)))
(pretty-print code port)))
(define-method (display (account ) port)
(format port "#< subject=~a issuer=~a id-token?=~a access-token?=~a refresh-token?=~a>"
(uri->string (subject account))
(uri->string (issuer account))
(and (id-token account) #t)
(and (access-token account) #t)
(and (refresh-token account) #t)))
(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
(cfg:get-oidc-configuration
(uri-host issuer)
#:userinfo (uri-userinfo issuer)
#:port (uri-port issuer)
#:http-get (http-get-implementation))))
(values
(cfg:oidc-configuration-authorization-endpoint configuration)
(cfg:oidc-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:client-redirect-uri client)))
,@(let ((state (authorization-state)))
(if state
`((state . ,state))
'()))))
"&"))))
((authorization-process) authorization-uri #:issuer issuer))))
(unless key-pair
(set! key-pair (client:client-key-pair client)))
(let ((dpop-proof
(dpop:issue-dpop-proof
key-pair
#:alg (case (jwk:kty key-pair)
((EC) 'ES256)
((RSA) 'RS256))
#:htm 'POST
#:htu token-endpoint)))
(receive (response response-body)
((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
(id:id-token-decode id-token
#:http-get
(http-request->http-get (anonymous-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)))))
(set! subject (id:id-token-webid id-token))
(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)))))
(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))
(define-method (->sexp (account ))
(match (next-method)
(('begin
'(use-modules (oop goops) (webid-oidc client accounts))
('make ' initializers ...))
`(begin
(use-modules (oop goops) (webid-oidc client accounts))
(make
#:username ,(username account)
#:encrypted-password ,(encrypted-password account)
,@initializers)))))
(define-method (display (account ) port)
(format port "#< subject=~a issuer=~a username=~a id-token?=~a access-token?=~a refresh-token?=~a>"
(uri->string (subject account))
(uri->string (issuer account))
(username account)
(and (id-token account) #t)
(and (access-token account) #t)
(and (refresh-token account) #t)))
(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))