;; 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 authorization-endpoint)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc server endpoint identity-provider)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc authorization-code)
  #:use-module (webid-oidc client-manifest)
  #:use-module (webid-oidc web-i18n)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 match)
  #:use-module (sxml simple)
  #:use-module (oop goops)
  #:declarative? #t
  #:duplicates (merge-generics)
  #:export
  (

   make-authorization-endpoint

   ))

(define (make-authorization-endpoint subject encrypted-password jwk-file)
  (define endpoint
    (make <authorization-endpoint>
      #:subject subject
      #:encrypted-password encrypted-password
      #:key-file jwk-file))
  (lambda (request request-body)
    (when (bytevector? request-body)
      (set! request-body (utf8->string request-body)))
    (parameterize ((web-locale request))
      (with-exception-handler
          (lambda (exn)
            (unless (web-exception? exn)
              (raise-exception exn))
            (values
             (build-response
              #:code (web-exception-code exn)
              #:reason-phrase (web-exception-reason-phrase exn)
              #:headers `((content-type application/xhtml+xml)))
             (call-with-output-string
               (cute 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
                              ,(call-with-input-string
                                   (format #f (W_ "<h1>The authorization request failed</h1>"))
                                 xml->sxml)
                              ,(if (user-message? exn)
                                   (user-message-sxml exn)
                                   (call-with-input-string
                                       (format #f (W_ "<p>No more information.</p>"))
                                     xml->sxml)))))
                     <>))))
        (lambda ()
          (receive (response response-body response-meta)
              (handle endpoint request request-body)
            (values response response-body)))
        #:unwind? #t))))