;; 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) #: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 (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 . ,(strip 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 . (? jwk-public? given-jwk)) header ...) (examine-header header alg typ (or jwk (the-public-jwk given-jwk)) other-header-fields)) ((('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 . _) (the-public-jwk (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 (stubs: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 (stubs: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-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 . ,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))