;; 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 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 web-i18n)
  #: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 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 (ice-9 exceptions)
  #:use-module (srfi srfi-19)
  #:use-module (rnrs bytevectors)
  #:use-module (sxml simple)
  #:use-module (sxml match)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:export
  (
   &unsupported-grant-type
   make-unsupported-grant-type
   unsupported-grant-type?
   unsupported-grant-type-grant-type

   &no-authorization-code
   make-no-authorization-code
   no-authorization-code?

   &no-refresh-token
   make-no-refresh-token
   no-refresh-token?

   make-token-endpoint
   ))

(define-exception-type
  &unsupported-grant-type
  &external-error
  make-unsupported-grant-type
  unsupported-grant-type?
  (grant-type unsupported-grant-type-grant-type))

(define-exception-type
  &no-authorization-code
  &external-error
  make-no-authorization-code
  no-authorization-code?)

(define-exception-type
  &no-refresh-token
  &external-error
  make-no-refresh-token
  no-refresh-token?)

(define (try-handle-web-failure thunk)
  (call/ec
   (lambda (return)
     (with-exception-handler
         (lambda (error)
           (unless (or (unsupported-grant-type? error)
                       (no-authorization-code? error)
                       (no-refresh-token? error)
                       (refresh:invalid-refresh-token? error)
                       (invalid-authorization-code? error))
             (let ((final-message
                    (if (exception-with-message? error)
                        (format #f (G_ "while handling web failure for the token endpoint: ~a")
                                (exception-message error))
                        (format #f (G_ "an error happened during the token endpoint failure handling")))))
               (raise-exception
                (make-exception
                 (make-exception-with-message final-message)
                 error))))
           (cond
            ((refresh:invalid-refresh-token? error)
             (return
              (build-response
               #:code 403
               #:reason-phrase (G_ "reason-phrase|Forbidden")
               #:headers '((content-type application/xhtml-xml)))
              (call-with-output-string
                (lambda (port)
                  (sxml->xml
                   `(*TOP*
                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                              (xml:lang ,(W_ "xml-lang|en")))
                           (body
                            ,(sxml-match
                              (xml->sxml
                               (W_ (format #f "<h1>Invalid refresh token</h1>")))
                              ((*TOP* ,title) title))
                            ,(sxml-match
                              (xml->sxml
                               (W_ (format #f "<p>The refresh token you sent is invalid, or it is already bound to another key.</p>")))
                              ((*TOP* ,p) p))
                            ,@(if (message-for-the-user? error)
                                  (user-message error)
                                  '()))))
                   port)))))
            ((invalid-authorization-code? error)
             (return
              (build-response
               #:code 400
               #:reason-phrase (G_ "reason-phrase|Bad Request")
               #:headers '((content-type application/xhtml-xml)))
              (call-with-output-string
                (lambda (port)
                  (sxml->xml
                   `(*TOP*
                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                              (xml:lang ,(W_ "xml-lang|en")))
                           (body
                            ,(sxml-match
                              (xml->sxml
                               (W_ (format #f "<h1>Invalid authorization code</h1>")))
                              ((*TOP* ,title) title))
                            ,(sxml-match
                              (xml->sxml
                               (W_ (format #f "<p>The authorization code is forged, or expired.</p>")))
                              ((*TOP* ,p) p))
                            ,@(if (message-for-the-user? error)
                                  (user-message error)
                                  '()))))
                   port)))))
            ;; Other bad request
            (else
             (return
              (build-response
               #:code 400
               #:reason-phrase (G_ "reason-phrase|Bad Request")
               #:headers '((content-type application/xhtml+xml)))
              (call-with-output-string
                (lambda (port)
                  (sxml->xml
                   `(*TOP*
                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                              (xml:lang ,(W_ "xml-lang|en")))
                           (body
                            ,(sxml-match
                              (xml->sxml
                               (W_ (format #f "<h1>Bad token request</h1>")))
                              ((*TOP* ,title) title))
                            ,(sxml-match
                              (xml->sxml
                               (W_ (format #f "<p>The token request failed.</p>")))
                              ((*TOP* ,p) p))
                            ,@(if (message-for-the-user? error)
                                  (user-message error)
                                  '()))))
                   port)))))))
       thunk))))

(define (make-token-endpoint token-endpoint-uri iss issuer-key)
  (lambda (request request-body)
    (when (bytevector? request-body)
      (set! request-body (utf8->string request-body)))
    (try-handle-web-failure
     (lambda ()
       (parameterize ((p:current-date ((p:current-date)))
                      (web-locale request))
         (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 (decode <dpop-proof> (assq-ref (request-headers request) 'dpop)
                               #:method method
                               #:uri uri
                               #:cnf/check
                               (lambda (jkt) #t))))
             (unless (and grant-type (string? grant-type))
               (let ((final-message 
                      (format #f (G_ "missing grant type")))
                     (final-user-message
                      (sxml-match
                       (xml->sxml
                        (format #f (W_ "<p>You did not specify a grant_type for this request.</p>")))
                       ((*TOP* ,p) p))))
                 (raise-exception
                  (make-exception
                   (make-unsupported-grant-type #f)
                   (make-exception-with-message final-message)
                   (make-message-for-the-user final-user-message)))))
             (receive (webid client-id)
                 (case (string->symbol grant-type)
                   ((authorization_code)
                    (let ((code
                           (let ((str (assoc-ref form-args "code")))
                             (unless str
                               (let ((final-message
                                      (format #f (G_ "missing authorization code")))
                                     (final-user-message
                                      (sxml-match
                                       (xml->sxml
                                        (format #f (W_ "<p>You want to grant an authorization code, but you did not set one.</p>")))
                                       ((*TOP* ,p) p))))
                                 (raise-exception
                                  (make-exception
                                   (make-no-authorization-code)
                                   (make-exception-with-message final-message)
                                   (make-message-for-the-user final-user-message)))))
                             (with-exception-handler
                                 (lambda (error)
                                   (raise-exception
                                    (make-exception
                                     (make-invalid-authorization-code)
                                     error)))
                               (lambda ()
                                 (decode <authorization-code> str
                                         #:issuer-key issuer-key))))))
                      (values (webid code) (client-id code))))
                   ((refresh_token)
                    (let ((refresh-token (assoc-ref form-args "refresh_token")))
                      (unless refresh-token
                        (let ((final-message
                               (format #f (G_ "missing refresh token")))
                              (final-user-message
                               (sxml-match
                                (xml->sxml
                                 (format #f (W_ "<p>You want to grant a refresh token, but you did not set one.</p>")))
                                ((*TOP* ,p) p))))
                          (raise-exception
                           (make-exception
                            (make-no-refresh-token)
                            (make-exception-with-message final-message)
                            (make-message-for-the-user final-user-message)))))
                      (refresh:with-refresh-token
                       refresh-token
                       (jwk dpop)
                       values)))
                   (else
                    (let ((final-message
                           (format #f (G_ "unsupported grant type: ~s")
                                   grant-type))
                          (final-user-message
                           (sxml-match
                            (xml->sxml
                             (format #f (W_ "<p>You want to use <pre>~s</pre> as a grant type, but this is not supported.</p>")
                                     grant-type))
                            ((*TOP* ,p) p))))                       
                      (raise-exception
                       (make-exception
                        (make-unsupported-grant-type grant-type)
                        (make-exception-with-message final-message)
                        (make-message-for-the-user final-user-message))))))
               (let ((id-token
                      (issue <id-token>
                             issuer-key
                             #:webid webid
                             #:iss iss
                             #:aud client-id))
                     (access-token
                      (issue <access-token>
                             issuer-key
                             #:webid webid
                             #:iss iss
                             #:client-key (jwk dpop)
                             #:client-id client-id))
                     (refresh-token
                      (if (equal? grant-type "refresh_token")
                          (assoc-ref form-args "refresh_token")
                          (refresh:issue-refresh-token webid client-id
                                                       (jkt (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 . ,(p:oidc-token-default-validity))
                     (refresh_token . ,refresh-token)))
                  client-id
                  #f))))))))))