;; 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/>.

(use-modules (webid-oidc token-endpoint)
             (webid-oidc authorization-code)
             (webid-oidc dpop-proof)
             (webid-oidc jwk)
             (webid-oidc jws)
             (webid-oidc jti)
             (webid-oidc testing)
             ((webid-oidc stubs) #:prefix stubs:)
             ((webid-oidc parameters) #:prefix p:)
             (web uri)
             (web request)
             (web response)
             (srfi srfi-19)
             (web response)
             (ice-9 optargs)
             (ice-9 receive))

(with-test-environment
 "token-endpoint-issue"
 (lambda ()
   (define alg 'RS256)
   (define key (generate-key #:n-size 2048))
   (define client-key (generate-key #:n-size 2048))
   (define subject (string->uri "https://token-endpoint-issue.scm/profile/card#me"))
   (define client (string->uri "https://token-endpoint-issue.scm/client/card#app"))
   (define issuer (string->uri "https://issuer.token-endpoint-issue.scm"))
   (define validity 3600)
   (define authz
     (issue-authorization-code
      alg key
      (time-utc->date (make-time time-utc 0 120))
      subject
      client))
   (define endpoint
     (make-token-endpoint
      (string->uri "https://token-endpoint-issue.scm/token")
      issuer alg key validity))
   (receive (response response-body user error)
       ;; The code is fake!
       (let ((dpop
              (parameterize ((p:current-date 0))
                (issue-dpop-proof
                 client-key
                 #:alg alg
                 #:htm 'POST
                 #:htu (string->uri
                        "https://token-endpoint-issue.scm/token")))))
         (parameterize ((p:current-date 0))
           (endpoint
            (build-request (string->uri
                            "http://localhost:8080/token")
                           #:headers `((content-type application/x-www-form-urlencoded)
                                       (dpop . ,dpop))
                           #:method 'POST
                           #:port #t)
            "grant_type=authorization_code&code=fake")))
     (unless (eq? (response-code response) 400)
       (exit 3))
     (receive (response response-body user error)
         (let ((dpop
                (parameterize ((p:current-date 10))
                  (issue-dpop-proof
                   client-key
                   #:alg alg
                   #:htm 'POST
                   #:htu (string->uri
                          "https://token-endpoint-issue.scm/token")))))
           (parameterize ((p:current-date 10))
             (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=authorization_code&code=" authz))))
       (unless (eq? (response-code response) 200)
         (write response)
         (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 (jws-decode access-token-enc
                                           (lambda (h) key))))
             (unless access-token
               (exit 8))
             (let ((access-token-cnf (assq-ref (jws-payload access-token)
                                               'cnf)))
               (unless access-token-cnf
                 (exit 9))
               (let ((access-token-cnf/jkt (assq-ref access-token-cnf 'jkt)))
                 (unless access-token-cnf/jkt
                   (exit 10))
                 (unless (string=? access-token-cnf/jkt (jkt client-key))
                   (exit 11)))))))))))