;; webid-oidc, 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 (web uri)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-19))

(define-public (the-dpop-proof-header x)
  (with-exception-handler
      (lambda (error)
        (raise-not-a-dpop-proof-header x error))
    (lambda ()
      (let ((x (the-jws-header x)))
        (let ((alg (assq-ref x 'alg))
              (typ (assq-ref x 'typ))
              (jwk (assq-ref x 'jwk)))
          (unless (and alg (string? alg))
            (raise-unsupported-alg alg))
          (case (string->symbol alg)
            ((RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512)
             #t)
            (else
             (raise-unsupported-alg alg)))
          (unless (equal? typ "dpop+jwt")
            (raise-incorrect-typ-field typ))
          (with-exception-handler
              (lambda (error)
                (raise-incorrect-jwk-field jwk error))
            (lambda ()
              (the-public-jwk jwk)))
          x)))))

(define-public (dpop-proof-header? x)
  (false-if-exception
   (and (the-dpop-proof-header x) #t)))

(define-public (the-dpop-proof-payload x)
  (with-exception-handler
      (lambda (error)
        (raise-not-a-dpop-proof-payload x error))
    (lambda ()
      (let ((x (the-jws-payload x)))
        (let ((jti (assq-ref x 'jti))
              (htm (assq-ref x 'htm))
              (htu (assq-ref x 'htu))
              (iat (assq-ref x 'iat))
              (ath (assq-ref x 'ath)))
          (unless (and jti (string? jti))
            (raise-incorrect-jti-field jti))
          (unless (and htm (string? htm))
            (raise-incorrect-htm-field htm))
          (unless (and htu (string? htu) (string->uri htu))
            (raise-incorrect-htu-field htu))
          (unless (and iat (integer? iat))
            (raise-incorrect-iat-field iat))
          (unless (or (not ath) (string? ath))
            (raise-incorrect-ath-field ath))
          x)))))

(define-public (dpop-proof-payload? x)
  (false-if-exception
   (and (the-dpop-proof-payload x) #t)))

(define-public (the-dpop-proof x)
  (with-exception-handler
      (lambda (error)
        (raise-not-a-dpop-proof x error))
    (lambda ()
      (cons (the-dpop-proof-header (car x))
            (the-dpop-proof-payload (cdr x))))))

(define-public (dpop-proof? x)
  (false-if-exception
   (and (the-dpop-proof x) #t)))

(define-public (make-dpop-proof header payload)
  (the-dpop-proof (cons header payload)))

(define-public (make-dpop-proof-header alg jwk)
  (when (symbol? alg)
    (set! alg (symbol->string alg)))
  (the-dpop-proof-header
   `((alg . ,alg)
     (typ . "dpop+jwt")
     (jwk . ,(stubs:strip-key jwk)))))

(define-public (make-dpop-proof-payload jti htm htu iat ath)
  (when (symbol? htm)
    (set! htm (symbol->string htm)))
  (when (uri? htu)
    (set! htu (uri->string htu)))
  (when (date? iat)
    (set! iat (date->time-utc iat)))
  (when (time? iat)
    (set! iat (time-second iat)))
  (the-dpop-proof-payload
   `((jti . ,jti)
     (htm . ,htm)
     (htu . ,htu)
     (iat . ,iat)
     ,@(if ath
           `((ath . ,ath))
           '()))))

(define-public (dpop-proof-header dpop)
  (car (the-dpop-proof dpop)))

(define-public (dpop-proof-payload dpop)
  (cdr (the-dpop-proof dpop)))

(define-public (dpop-proof-alg code)
  (when (dpop-proof? code)
    (set! code (dpop-proof-header code)))
  (jws-alg (the-dpop-proof-header code)))

(define-public (dpop-proof-jwk dpop)
  (when (dpop-proof? dpop)
    (set! dpop (dpop-proof-header dpop)))
  (assq-ref (the-dpop-proof-header dpop) 'jwk))

(define-public (dpop-proof-jti dpop)
  (when (dpop-proof? dpop)
    (set! dpop (dpop-proof-payload dpop)))
  (assq-ref (the-dpop-proof-payload dpop) 'jti))

(define-public (dpop-proof-htm dpop)
  (when (dpop-proof? dpop)
    (set! dpop (dpop-proof-payload dpop)))
  (string->symbol
   (assq-ref (the-dpop-proof-payload dpop)
             'htm)))

(define-public (dpop-proof-htu dpop)
  (when (dpop-proof? dpop)
    (set! dpop (dpop-proof-payload dpop)))
  (string->uri
   (assq-ref (the-dpop-proof-payload dpop)
             'htu)))

(define-public (dpop-proof-iat dpop)
  (when (dpop-proof? dpop)
    (set! dpop (dpop-proof-payload dpop)))
  (time-utc->date
   (make-time time-utc
              0
              (assq-ref (the-dpop-proof-payload dpop)
                        'iat))))

(define-public (dpop-proof-ath dpop)
  (when (dpop-proof? dpop)
    (set! dpop (dpop-proof-payload dpop)))
  (assq-ref (the-dpop-proof-payload dpop)
            'ath))

(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))))
    (raise-dpop-uri-mismatch a b)))

(define*-public (dpop-proof-decode method uri str cnf/check
                                   #:key
                                   (access-token #f))
  (let ((current-time
         (time-second (date->time-utc ((p:current-date))))))
    (with-exception-handler
        (lambda (error)
          (raise-cannot-decode-dpop-proof str error))
      (lambda ()
        (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk))))
          (unless (eq? method (dpop-proof-htm decoded))
            (raise-dpop-method-mismatch (dpop-proof-htm decoded) method))
          (uris-compatible (dpop-proof-htu decoded)
                           (if (string? uri)
                               (string->uri uri)
                               uri))
          (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded)))))
            (unless (>= current-time (- iat 5))
              (raise-dpop-signed-in-future iat current-time))
            (unless (<= current-time (+ iat 120)) ;; Valid for 2 min
              (raise-dpop-too-old iat current-time)))
          (when access-token
            (let ((h (stubs:hash 'SHA-256 access-token)))
              (unless (equal? (dpop-proof-ath decoded) h)
                (raise-exception
                 (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token)))))
          (if (string? cnf/check)
              (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded)))
                (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f))
              (with-exception-handler
                  (lambda (error)
                    (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error))
                (lambda ()
                  (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded)))
                    ;; deprecated; throw an error instead!
                    (error "the cnf/check function returned #f")))))
          (parameterize ((p:current-date current-time))
            ;; jti-check should use the same date.
            (unless (jti-check (dpop-proof-jti decoded) 120)
              (with-exception-handler
                  (lambda (error)
                    (raise-jti-found (dpop-proof-jti decoded) error))
                (lambda ()
                  (error "the jti-check function returned #f"))))
            decoded))))))

(define-public (dpop-proof-encode dpop-proof key)
  (with-exception-handler
      (lambda (error)
        (raise-cannot-encode-dpop-proof dpop-proof key error))
    (lambda ()
      (jws-encode dpop-proof key))))

(define*-public (issue-dpop-proof
                 client-key
                 #:key
                 (alg #f)
                 (htm #f)
                 (htu #f)
                 (access-token #f))
  (dpop-proof-encode
   (make-dpop-proof (make-dpop-proof-header alg client-key)
                    (make-dpop-proof-payload (stubs:random 12) htm htu ((p:current-date))
                                             (and access-token
                                                  (stubs:hash 'SHA-256 access-token))))
   client-key))