;; 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 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?

   <dpop-proof> 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 <dpop-proof> (<single-use-token>)
  (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 <dpop-proof>))
  (p:dpop-proof-validity))

(define-method (has-explicit-exp? (proof <dpop-proof>))
  #f)

(define-method (nonce-field-name (proof <dpop-proof>))
  'jti)

(define-method (initialize (token <dpop-proof>) 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 <public-key>)
             (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 <dpop-proof>))
  ;; 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 <dpop-proof>) 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 <dpop-proof>) args)
  (jwk token))