path: root/src/scm/webid-oidc/dpop-proof.scm

;; 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 <https://www.gnu.org/licenses/>.

(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
            (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))