;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 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 dpop-proof)
#:use-module (webid-oidc jws)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc jti)
#:use-module (webid-oidc serializable)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (webid-oidc web-i18n)
#:use-module (web uri)
#:use-module (ice-9 optargs)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (oop goops)
#:declarative? #t
#:re-export
(
alg iat exp nonce (nonce . jti)
token->jwt
decode
encode
issue
)
#:export
(
&invalid-dpop-proof
make-invalid-dpop-proof
invalid-dpop-proof?
&dpop-method-mismatch
make-dpop-method-mismatch
dpop-method-mismatch?
dpop-method-mismatch-advertised
dpop-method-mismatch-actual
&dpop-uri-mismatch
make-dpop-uri-mismatch
dpop-uri-mismatch?
dpop-uri-mismatch-advertised
dpop-uri-mismatch-actual
&dpop-invalid-ath
make-dpop-invalid-ath
dpop-invalid-ath?
dpop-invalid-ath-hash
dpop-invalid-ath-access-token
&dpop-unconfirmed-key
make-dpop-unconfirmed-key
dpop-unconfirmed-key?
typ jwk htm htu ath
))
(define-exception-type
&invalid-dpop-proof
&external-error
make-invalid-dpop-proof
invalid-dpop-proof?)
(define-exception-type
&dpop-method-mismatch
&external-error
make-dpop-method-mismatch
dpop-method-mismatch?
(advertised dpop-method-mismatch-advertised)
(actual dpop-method-mismatch-actual))
(define-exception-type
&dpop-uri-mismatch
&external-error
make-dpop-uri-mismatch
dpop-uri-mismatch?
(advertised dpop-uri-mismatch-advertised)
(actual dpop-uri-mismatch-actual))
(define (uris-compatible a b)
;; a is what is signed, b is the request
(unless
(and (eq? (uri-scheme a)
(uri-scheme b))
(equal? (uri-userinfo a)
(uri-userinfo b))
(equal? (uri-port a)
(uri-port b))
(equal? (split-and-decode-uri-path
(uri-path a))
(split-and-decode-uri-path
(uri-path b))))
(let ((final-message
(format #f (G_ "the DPoP proof is signed for ~s, but it is issued to ~s")
(uri->string a) (uri->string b))))
(raise-exception
(make-exception
(make-dpop-uri-mismatch a b)
(make-exception-with-message final-message))))))
(define-exception-type
&dpop-invalid-ath
&external-error
make-dpop-invalid-ath
dpop-invalid-ath?
(hash dpop-invalid-ath-hash)
(access-token dpop-invalid-ath-access-token))
(define-exception-type
&dpop-unconfirmed-key
&external-error
make-dpop-unconfirmed-key
dpop-unconfirmed-key?)
(define-class ()
(typ #:init-keyword #:typ #:accessor typ)
(jwk #:init-keyword #:jwk #:accessor jwk)
(htm #:init-keyword #:htm #:accessor htm)
(htu #:init-keyword #:htu #:accessor htu #:->sxml uri->string)
(ath #:init-keyword #:ath #:accessor ath)
#:module-name '(webid-oidc dpop-proof))
(define-method (default-validity (proof ))
(p:dpop-proof-validity))
(define-method (has-explicit-exp? (proof ))
#f)
(define-method (nonce-field-name (proof ))
'jti)
(define-method (initialize (token ) initargs)
(with-exception-handler
(lambda (error)
(raise-exception
(make-exception
(make-invalid-dpop-proof)
(make-exception-with-message
(if (exception-with-message? error)
(format #f (G_ "invalid DPoP proof: ~a")
(exception-message error))
(G_ "invalid DPoP proof token")))
error)))
(lambda ()
(next-method)
;; Override the validity
(slot-set! token 'exp
(let ((iat (time-second (date->time-utc (iat token)))))
(time-utc->date
(make-time time-utc 0
(+ iat (p:dpop-proof-validity))))))
(let-keywords
initargs #t
((typ "dpop+jwt")
(jwk #f)
(htm #f)
(htu #f)
(ath #f)
(access-token #f)
(jwt-header #f)
(jwt-payload #f))
(let do-initialize ((typ typ)
(jwk jwk)
(htm htm)
(htu htu)
(ath ath)
(access-token access-token)
(jwt-header jwt-header)
(jwt-payload jwt-payload))
(cond
((string? htu)
(do-initialize typ jwk htm (string->uri htu) ath access-token jwt-header jwt-payload))
((string? htm)
(do-initialize typ jwk (string->symbol htm) htu ath access-token jwt-header jwt-payload))
((and (not ath) access-token)
(do-initialize typ jwk htm htu (stubs:hash 'SHA-256 access-token) #f jwt-header jwt-payload))
((and typ jwk htm htu)
(unless (equal? typ "dpop+jwt")
(scm-error 'wrong-type-arg "make"
(G_ "#:typ should be exactly \"dpop+jwt\"")
'()
(list typ)))
(unless (is-a? jwk )
(scm-error 'wrong-type-arg "make"
(G_ "#:jwk should be a public key")
'()
(list jwk)))
(unless (symbol? htm)
(scm-error 'wrong-type-arg "make"
(G_ "#:htm should be a symbol")
'()
(list htm)))
(when ath
(unless (string? ath)
(scm-error 'wrong-type-arg "make"
(G_ "when present, #:ath should be a string")
'()
(list ath))))
(slot-set! token 'typ typ)
(slot-set! token 'jwk jwk)
(slot-set! token 'htm htm)
(slot-set! token 'htu htu)
(slot-set! token 'ath ath))
((and jwt-header jwt-payload)
(do-initialize
(assq-ref jwt-header 'typ)
(jwk->key (assq-ref jwt-header 'jwk))
(assq-ref jwt-payload 'htm)
(assq-ref jwt-payload 'htu)
(assq-ref jwt-payload 'ath)
#f #f #f))
(else
(raise-exception
(make-exception
(make-invalid-jws)
(make-exception-with-message
(G_ "when making a DPoP proof, either its required fields (#:typ, #:jwk, #:htm and #:htu) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
(define-method (token->jwt (token ))
;; exp should be implicit, and nonce should be replaced by jti
(receive (base-header base-payload) (next-method)
(values
`((typ . ,(typ token))
(jwk . ,(key->jwk (jwk token)))
,@base-header)
`((htm . ,(symbol->string (htm token)))
(htu . ,(uri->string (htu token)))
,@(let ((ath (ath token)))
(if ath
`((ath . ,ath))
'()))
,@base-payload))))
(define-method (verify (token ) args)
(next-method)
(let-keywords
args #t
((access-token #f)
(method #f)
(uri #f)
(cnf/check #f))
(begin
(when (string? uri)
(set! uri (string->uri uri)))
(unless (eq? (htm token) method)
(raise-exception
(make-exception
(make-dpop-method-mismatch (htm token) method)
(make-exception-with-message
(format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s")
(htm token) method)))))
(uris-compatible (htu token) uri)
(when access-token
(let ((h (stubs:hash 'SHA-256 access-token)))
(unless (equal? (ath token) h)
(raise-exception
(make-exception
(make-dpop-invalid-ath (ath token) access-token)
(make-exception-with-message
(format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s")
(ath token) access-token)))))))
(if (string? cnf/check)
(unless (equal? cnf/check (jkt (jwk token)))
(raise-exception
(make-exception
(make-dpop-unconfirmed-key)
(make-exception-with-message
(format #f (G_ "the DPoP proof is signed with the wrong key"))))))
(with-exception-handler
(lambda (error)
(let ((final-message
(if (exception-with-message? error)
(format #f (G_ "the DPoP proof is signed with the wrong key: ~a")
(exception-message error))
(format #f (G_ "the DPoP proof is signed with the wrong key")))))
(raise-exception
(make-exception
(make-dpop-unconfirmed-key)
(make-exception-with-message final-message)
error))))
(lambda ()
(unless (cnf/check (jkt (jwk token)))
;; You should throw an error instead!
(fail (G_ "the cnf/check function returned #f")))))))))
(define-method (lookup-keys (token ) args)
(jwk token))