;; 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 token-endpoint)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc authorization-code)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc oidc-id-token)
  #:use-module (webid-oidc access-token)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 control)
  #:use-module (srfi srfi-19)
  #:use-module (rnrs bytevectors))

(define (try-handle-web-failure thunk)
  (define (error->str err)
    (if (record? err)
        (let* ((type (record-type-descriptor err))
               (get
                (lambda (slot)
                  ((record-accessor type slot) err)))
               (recurse
                (lambda (err)
                  (error->str err))))
          (case (record-type-name type)
            ((&cannot-decode-dpop-proof)
             (format #f "the DPoP proof is invalid"))
            ((&no-authorization-code)
             (format #f "there is no authorization code in the request"))
            ((&no-refresh-token)
             (format #f "there is no refresh token in the request"))
            ((&cannot-decode-authorization-code)
             (format #f "the authorization code is invalid"))
            ((&invalid-refresh-token)
             (format #f "the refresh token is invalid"))
            ((&invalid-key-for-refresh-token)
             (format #f "the refresh token is bound to another key"))
            ((&unsupported-grant-type)
             (format #f "the grant type ~s is not supported" (get 'value)))
            (else
             (raise-exception err))))
        (throw err)))
  (call/ec
   (lambda (return)
     (with-exception-handler
         (lambda (error)
           (return
            (build-response
             #:code 400
             #:reason-phrase (string-append "Bad Request: " (error->str error)))
            (error->str error)
            #f
            error))
       thunk
       #:unwind? #t))))

(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity)
  (lambda* (request request-body)
    (try-handle-web-failure
     (lambda ()
       (when (bytevector? request-body)
         (set! request-body (utf8->string request-body)))
       (parameterize ((p:current-date ((p:current-date))))
         (let ((current-time ((p:current-date))) ;; thunk parameter
               (form-args
                (if (and (request-content-type request)
                         (eq? (car (request-content-type request))
                              'application/x-www-form-urlencoded))
                    (filter
                     (lambda (x) x)
                     (map (lambda (kv)
                            (let ((parsed
                                   (list->vector
                                    (map (lambda (x)
                                           (uri-decode x #:decode-plus-to-space? #t))
                                         (string-split kv #\=)))))
                              (if (eq? (vector-length parsed) 2)
                                  `(,(vector-ref parsed 0) . ,(vector-ref parsed 1))
                                  #f)))
                          (string-split request-body #\&)))
                    '()))
               (method (request-method request))
               ;; Maybe we’re behind a reverse proxy, so the authority of
               ;; (request-uri request) is meaningless.
               (uri (build-uri (uri-scheme token-endpoint-uri)
                               #:userinfo (uri-userinfo token-endpoint-uri)
                               #:host (uri-host token-endpoint-uri)
                               #:port (uri-port token-endpoint-uri)
                               #:path (uri-path (request-uri request))
                               #:query (uri-query (request-uri request)))))
           (let ((grant-type (assoc-ref form-args "grant_type"))
                 (dpop (dpop-proof-decode
                        method uri
                        (assq-ref (request-headers request) 'dpop)
                        (lambda (jkt) #t))))
             (unless (and grant-type (string? grant-type))
               (raise-unsupported-grant-type #f))
             (receive (webid client-id)
                 (case (string->symbol grant-type)
                   ((authorization_code)
                    (let ((code
                           (let ((str (assoc-ref form-args "code")))
                             (unless str
                               (raise-no-authorization-code))
                             (authorization-code-decode str jwk))))
                      (values (authorization-code-webid code)
                              (authorization-code-client-id code))))
                   ((refresh_token)
                    (let ((refresh-token (assoc-ref form-args "refresh_token")))
                      (unless refresh-token
                        (raise-no-refresh-token))
                      (refresh:with-refresh-token
                       refresh-token
                       (dpop-proof-jwk dpop)
                       values)))
                   (else
                    (raise-unsupported-grant-type grant-type)))
               (let* ((iat (time-second (date->time-utc current-time)))
                      (exp (+ iat validity)))
                 (let ((id-token
                        (issue-id-token
                         jwk
                         #:alg alg
                         #:webid (uri->string webid)
                         #:sub (uri->string webid)
                         #:iss (uri->string iss)
                         #:aud (uri->string client-id)
                         #:validity 3600))
                       (access-token
                        (issue-access-token
                         jwk
                         #:alg alg
                         #:webid (uri->string webid)
                         #:iss (uri->string iss)
                         #:validity 3600
                         #:client-key (dpop-proof-jwk dpop)
                         #:client-id (uri->string client-id)))
                       (refresh-token
                        (if (equal? grant-type "refresh_token")
                            (assoc-ref form-args "refresh_token")
                            (refresh:issue-refresh-token webid client-id
                                                         (jkt (dpop-proof-jwk dpop))))))
                   (values
                    (build-response #:headers '((content-type application/json)
                                                (cache-control (no-cache no-store)))
                                    #:port #f)
                    (stubs:scm->json-string
                     `((id_token . ,id-token)
                       (access_token . ,access-token)
                       (token_type . "DPoP")
                       (expires_in . ,validity)
                       (refresh_token . ,refresh-token)))
                    client-id
                    #f)))))))))))