;; 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 (tests token-endpoint-refresh)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc server endpoint identity-provider)
  #:use-module (webid-oidc authorization-code)
  #:use-module (webid-oidc refresh-token)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc access-token)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc jti)
  #:use-module (webid-oidc testing)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (srfi srfi-19)
  #:use-module (web response)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t)

(with-test-environment
 "token-endpoint-refresh"
 (lambda ()
   (define key (generate-key #:n-size 2048))
   (call-with-output-file (string-append (p:data-home) "/key-file.jwk")
     (lambda (port)
       (stubs:scm->json
        (key->jwk key)
        port
        #:pretty #t)))
   (define client-key (generate-key #:n-size 2048))
   (define subject (string->uri "https://token-endpoint-refresh.scm/profile/card#me"))
   (define client (string->uri "https://token-endpoint-refresh.scm/client/card#app"))
   (define issuer (string->uri "https://issuer.token-endpoint-refresh.scm"))
   (define refresh-code
     (issue-refresh-token subject client (jkt client-key)))
   (define endpoint
     (make <token-endpoint>
       #:issuer "https://issuer.token-endpoint-refresh.scm"
       #:key-file (string-append (p:data-home) "/key-file.jwk")))
   (with-exception-handler
       (lambda (exn)
         (unless (and (web-exception? exn)
                      (eqv? (web-exception-code exn) 400))
           (raise-exception
            (make-exception
             (make-exception-with-message
              (format #f "the error code should be 400"))
             exn))))
     (lambda ()
       ;; The refresh token is fake!
       (let ((dpop
              (parameterize ((p:current-date 0))
                (issue <dpop-proof>
                       client-key
                       #:jwk (public-key client-key)
                       #:htm 'POST
                       #:htu (string->uri
                              "https://token-endpoint-refresh.scm/token")))))
         (parameterize ((p:current-date 0))
           (handle endpoint
                   (build-request (string->uri
                                   "http://localhost:8080/token")
                                  #:headers `((content-type application/x-www-form-urlencoded)
                                              (dpop . ,dpop))
                                  #:method 'POST
                                  #:port #t)
                   "refresh_token=fake")))
       (exit 3))
     #:unwind? #t
     #:unwind-for-type &web-exception)
   (receive (response response-body response-meta)
       (let ((dpop
              (parameterize ((p:current-date 10))
                (issue <dpop-proof>
                       client-key
                       #:jwk (public-key client-key)
                       #:htm 'POST
                       #:htu (string->uri
                              "https://token-endpoint-refresh.scm/token")))))
         (parameterize ((p:current-date 10))
           (handle endpoint
                   (build-request (string->uri
                                   "http://localhost:8080/token")
                                  #:headers `((content-type application/x-www-form-urlencoded)
                                              (dpop . ,dpop))
                                  #:method 'POST
                                  #:port #t)
                   (string-append "grant_type=refresh_token&refresh_token=" refresh-code))))
     (unless (eq? (response-code response) 200)
       (exit 4))
     (unless (eq? (car (response-content-type response)) 'application/json)
       (exit 5))
     (let ((response (stubs:json-string->scm response-body)))
       (let ((access-token-enc (assq-ref response 'access_token))
             (refresh-token-enc (assq-ref response 'refresh_token)))
         (unless access-token-enc
           (exit 6))
         (unless refresh-token-enc
           (exit 7))
         (let ((access-token
                (parameterize ((p:current-date 20)
                               (p:anonymous-http-request
                                (lambda* (uri . args)
                                  (cond
                                   ((equal? uri (string->uri "https://issuer.token-endpoint-refresh.scm/.well-known/openid-configuration"))
                                    (values (build-response #:headers '((content-type application/json)))
                                            "{
  \"jwks_uri\": \"https://token-endpoint-refresh.scm/keys\",
  \"token_endpoint\": \"https://token-endpoint-refresh.scm/token\",
  \"authorization_endpoint\": \"https://token-endpoint-refresh.scm/authorize\",
  \"solid_oidc_supported\": \"https://solidproject.org/TR/solid-oidc\"
}"))
                                   ((equal? uri (string->uri "https://token-endpoint-refresh.scm/keys"))
                                    (values (build-response #:headers '((content-type application/json)))
                                            (stubs:scm->json-string `((keys . ,(list->vector (list (key->jwk key))))))))
                                   (else
                                    (exit 8))))))
                  (decode <access-token> access-token-enc))))
           (unless access-token
             (exit 9))
           (let ((access-token-cnf/jkt (cnf/jkt access-token)))
             (unless access-token-cnf/jkt
               (exit 10))
             (unless (string=? access-token-cnf/jkt (jkt client-key))
               (exit 11))))
         (unless (string=? refresh-token-enc refresh-code)
           (exit 12)))))))