;; 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 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 (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (oop goops)
#:declarative? #t
#:export
(
&invalid-dpop-proof
make-invalid-dpop-proof
invalid-dpop-proof?
the-dpop-proof
dpop-proof?
dpop-proof-alg
dpop-proof-typ
dpop-proof-jwk
dpop-proof-jti
dpop-proof-htm
dpop-proof-htu
dpop-proof-iat
dpop-proof-ath
&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?
dpop-proof-decode
issue-dpop-proof
))
(define-exception-type
&invalid-dpop-proof
&external-error
make-invalid-dpop-proof
invalid-dpop-proof?)
(define (parse-jwk data)
(false-if-exception
(jwk->key data)))
(define (the-dpop-proof x)
(with-exception-handler
(lambda (error)
(let ((final-message
(cond
((invalid-jws? error)
(if (exception-with-message? error)
(format #f (G_ "this is not a DPoP proof, because it is not even a JWS: ~a")
(exception-message error))
(format #f (G_ "this is not a DPoP proof, because it is not even a JWS"))))
(else
(if (exception-with-message? error)
(format #f (G_ "this is not an access token: ~a")
(exception-message error))
(format #f (G_ "this is not an access token")))))))
(raise-exception
(make-exception
(make-invalid-dpop-proof)
(make-exception-with-message final-message)
error))))
(lambda ()
(match (the-jws x)
((header . payload)
(let examine-header ((header header)
(alg #f)
(typ #f)
(jwk #f)
(other-header-fields '()))
(match header
(()
(let examine-payload ((payload payload)
(jti #f)
(htm #f)
(htu #f)
(iat #f)
(ath #f)
(other-payload-fields '()))
(match payload
(()
(unless (and alg typ jwk jti htm htu iat)
(fail (format #f (G_ "the DPoP proof is missing ~s")
`(,@(if alg '() '("alg"))
,@(if typ '() '("typ"))
,@(if jwk '() '("jwk"))
,@(if jti '() '("jti"))
,@(if htm '() '("htm"))
,@(if htu '() '("htu"))
,@(if iat '() '("iat"))))))
`(((alg . ,(symbol->string alg))
(typ . "dpop+jwt")
(jwk . ,(key->jwk (public-key jwk)))
,@other-header-fields)
. ((jti . ,jti)
(htm . ,(symbol->string htm))
(htu . ,(uri->string htu))
(iat . ,(time-second (date->time-utc iat)))
,@(if ath `((ath . ,ath)) '())
,@other-payload-fields)))
((('jti . (? string? given-jti)) payload ...)
(examine-payload payload
(or jti given-jti) htm htu iat ath
other-payload-fields))
((('jti . incorrect) payload ...)
(fail (format #f (G_ "the \"jti\" field should be a string, not ~s")
incorrect)))
((('htm . (? string? given-htm)) payload ...)
(examine-payload payload jti
(or htm (string->symbol given-htm))
htu iat ath other-payload-fields))
((('htm . incorrect) payload ...)
(fail (format #f (G_ "the \"htm\" field should be a string, not ~s")
incorrect)))
((('htu . (? string? (= string->uri (? uri? given-htu)))) payload ...)
(examine-payload payload jti htm
(or htu given-htu)
iat ath other-payload-fields))
((('htu . incorrect) payload ...)
(fail (format #f (G_ "the \"htu\" field should be an URI, not ~s")
incorrect)))
((('iat . (? (cute >= <> 0) (? integer? given-iat))) payload ...)
(examine-payload payload jti htm htu
(or iat (time-utc->date (make-time time-utc 0 given-iat)))
ath other-payload-fields))
((('iat . incorrect) payload ...)
(fail (format #f (G_ "the \"iat\" field should be a timestamp, not ~s")
incorrect)))
((('ath . (? string? given-ath)) payload ...)
(examine-payload payload jti htm htu iat
(or ath given-ath)
other-payload-fields))
((('ath . incorrect) payload ...)
(fail (format #f (G_ "the \"ath\" field should be an encoded JWT, not ~s")
incorrect)))
((field payload ...)
(examine-payload payload jti htm htu iat ath
`(,field ,@other-payload-fields))))))
((('alg . (? string? given-alg)) header ...)
(examine-header header (or alg (string->symbol given-alg))
typ jwk other-header-fields))
((('alg . incorrect) header ...)
(fail (format #f (G_ "the \"alg\" field should be a string, not ~s")
incorrect)))
((('typ . "dpop+jwt") header ...)
(examine-header header alg #t jwk other-header-fields))
((('typ . incorrect) header ...)
(fail (format #f (G_ "the \"typ\" field should be \"dpop+jwt\", not ~s")
incorrect)))
((('jwk . (= parse-jwk (? (cute is-a? <> ) given-jwk))) header ...)
(examine-header header alg typ (or jwk given-jwk)
other-header-fields))
((('jwk . (= parse-jwk (? (cute is-a? <> ) given-jwk))) header ...)
(fail (format #f (G_ "the \"jwk\" field should not contain the private key"))))
((('jwk . incorrect) header ...)
(fail (format #f (G_ "the \"jwk\" field should be a valid public key, not ~s")
incorrect)))
((field header ...)
(examine-header header alg typ jwk `(,field ,@other-header-fields))))))))))
(define (dpop-proof? x)
(false-if-exception (the-dpop-proof x)))
(define (dpop-proof-alg proof)
(match (the-dpop-proof proof)
((header . _)
(symbol->string (assq-ref header 'alg)))))
(define (dpop-proof-typ proof)
(match (the-dpop-proof proof)
((header . _)
(assq-ref header 'typ))))
(define (dpop-proof-jwk proof)
(match (the-dpop-proof proof)
((header . _)
(jwk->key (assq-ref header 'jwk)))))
(define (dpop-proof-jti proof)
(match (the-dpop-proof proof)
((_ . payload)
(assq-ref payload 'jti))))
(define (dpop-proof-htm proof)
(match (the-dpop-proof proof)
((_ . payload)
(string->symbol (assq-ref payload 'htm)))))
(define (dpop-proof-htu proof)
(match (the-dpop-proof proof)
((_ . payload)
(string->uri (assq-ref payload 'htu)))))
(define (dpop-proof-iat proof)
(match (the-dpop-proof proof)
((_ . payload)
(time-utc->date
(make-time time-utc 0 (assq-ref payload 'iat))))))
(define (dpop-proof-ath proof)
(match (the-dpop-proof proof)
((_ . payload)
(assq-ref payload 'ath))))
(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* (dpop-proof-decode method uri str cnf/check
#:key
(access-token #f))
(let* ((current-date ((p:current-date)))
(current-time
(time-second (date->time-utc current-date))))
(with-exception-handler
(lambda (error)
(let ((final-message
(if (exception-with-message? error)
(format #f (G_ "the DPoP proof cannot be decoded: ~a")
(exception-message error))
(format #f (G_ "the DPoP proof cannot be decoded")))))
(raise-exception
(make-exception
(make-invalid-dpop-proof)
(make-exception-with-message final-message)
error))))
(lambda ()
(let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk))))
(unless (eq? method (dpop-proof-htm decoded))
(let ((final-message
(format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s")
(dpop-proof-htm decoded) method)))
(raise-exception
(make-exception
(make-dpop-method-mismatch (dpop-proof-htm decoded) method)
(make-exception-with-message final-message)))))
(uris-compatible (dpop-proof-htu decoded)
(if (string? uri)
(string->uri uri)
uri))
(let ((iat (dpop-proof-iat decoded)))
(let ((iat-s (time-second (date->time-utc iat))))
(unless (>= current-time (- iat-s 5))
(let ((final-message
(format #f (G_ "the DPoP proof is signed in the future, ~a, relative to the current date, ~a")
(date->string iat)
(date->string current-date))))
(raise-exception
(make-exception
(make-signed-in-future iat current-date)
(make-exception-with-message final-message)))))
(unless (<= current-time (+ iat-s 120)) ;; valid for 2 minutes
(let ((final-message
(format #f (G_ "the DPoP proof is too old, it was signed ~a and now it is ~a")
(date->string iat)
(date->string current-date))))
(raise-exception
(make-exception
(make-expired (time-utc->date (make-time time-utc 0 (+ iat-s 120)))
current-date)
(make-exception-with-message final-message)))))))
(when access-token
(let ((h (stubs:hash 'SHA-256 access-token)))
(unless (equal? (dpop-proof-ath decoded) h)
(let ((final-message
(format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s")
(dpop-proof-ath decoded) access-token)))
(raise-exception
(make-exception
(make-dpop-invalid-ath (dpop-proof-ath decoded) access-token)
(make-exception-with-message final-message)))))))
(if (string? cnf/check)
(unless (equal? cnf/check (jkt (dpop-proof-jwk decoded)))
(let ((final-message
(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)))))
(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 (dpop-proof-jwk decoded)))
;; You should throw an error instead!
(fail (G_ "the cnf/check function returned #f"))))))
(parameterize ((p:current-date current-date))
;; jti-check should use the same date.
(jti-check (dpop-proof-jti decoded) 120))
decoded)))))
(define (dpop-proof-encode dpop-proof key)
(with-exception-handler
(lambda (error)
(let ((final-message
(if (exception-with-message? error)
(format #f (G_ "cannot encode a DPoP proof: ~a")
(exception-message error))
(format #f (G_ "cannot encode a DPoP proof")))))
(raise-exception
(make-exception
(make-exception-with-message final-message)
error))))
(lambda ()
(jws-encode dpop-proof key))))
(define* (issue-dpop-proof
client-key
#:key
(alg #f)
(htm #f)
(htu #f)
(access-token #f))
(dpop-proof-encode
(the-dpop-proof
`(((alg . ,(symbol->string alg))
(typ . "dpop+jwt")
(jwk . ,(key->jwk (public-key client-key))))
. ((jti . ,(stubs:random 12))
(htm . ,(symbol->string htm))
(htu . ,(uri->string htu))
(iat . ,(time-second (date->time-utc ((p:current-date)))))
,@(if access-token
`((ath . ,(stubs:hash 'SHA-256 access-token)))
'()))))
client-key))