;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 (tests dpop-proof-no-explicit-exp)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc access-token)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc testing)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (srfi srfi-19)
  #:use-module (web response)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (oop goops)
  #:declarative? #t)

(define-class <dpop-proof-with-exp> (<dpop-proof>)
  #:module-name '(tests dpop-proof-no-explicit-exp))

(define-method (initialize (token <dpop-proof-with-exp>) initargs)
  (next-method)
  ;; Override exp
  (let-keywords
   initargs #t
   ((validity #f))
   (slot-set! token 'exp
              (let ((iat (time-second (date->time-utc (iat token)))))
                (time-utc->date
                 (make-time time-utc 0
                            (+ iat validity)))))))

(define malicious-jwt-created? #f)

(define-method (token->jwt (token <dpop-proof-with-exp>))
  (set! malicious-jwt-created? #t)
  (receive (header payload) (next-method)
    (let ((exp (time-second (date->time-utc (exp token)))))
      (unless (equal? exp 3600)
        (exit 3))
      (values header
              `((exp . ,exp)
                ,@payload)))))

(with-test-environment
 "dpop-proof-no-explicit-exp"
 (lambda ()
   (define jwk (generate-key #:n-size 2048))
   (define idp-key (generate-key #:n-size 2048))
   (define cnf (jkt jwk))
   (define access-token
     (parameterize ((p:current-date 0))
       (issue <access-token>
              idp-key
              #:webid (string->uri "https://data.provider/subject")
              #:iss (string->uri "https://identity.provider")
              #:client-key jwk
              #:client-id (string->uri "https://client"))))
   (define proof
     (parameterize ((p:current-date 0))
       (issue <dpop-proof-with-exp>
              jwk
              #:jwk (public-key jwk)
              #:htm 'GET
              #:htu (string->uri "https://example.com/res?query")
              #:validity 3600 ;; Obviously too long: the decoder
              ;; should ignore this value and make it
              ;; obsolete after 120 seconds.
              #:access-token access-token)))
   (unless malicious-jwt-created?
     (exit 1))
   (with-exception-handler
       (lambda (error)
         (unless (and (expired? error)
                      (eqv? (time-second (date->time-utc (error-expiration-date error)))
                            30)
                      (eqv? (time-second (date->time-utc (error-current-date error)))
                            60))
           (raise-exception error)))
     (lambda ()
       (parameterize ((p:current-date 60))
         (decode <dpop-proof> proof
                 #:method 'GET
                 #:uri (string->uri "https://example.com/res?query")
                 #:cnf/check cnf
                 #:access-token access-token))
       (exit 2))
     #:unwind? #t
     #:unwind-for-type &expired)))