;; 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 identity-provider)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc authorization-endpoint)
  #:use-module (webid-oidc token-endpoint)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc server endpoint identity-provider)
  #:use-module (webid-oidc oidc-configuration)
  #:use-module (webid-oidc jwk)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (webid-oidc jti)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (webid-oidc cache)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (webid-oidc web-i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (sxml simple)
  #:use-module (sxml match)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:export
  (

   make-identity-provider

   ))

(define-class <default> (<endpoint>))

(define-method (handle (endpoint <default>) request request-body)
  (raise-exception
   (make-exception
    (make-web-exception 404 (W_ "reason-phrase|Not Found"))
    (make-user-message
     (call-with-input-string
         (format #f (W_ "<p>Your request cannot be handled by the identity provider.</p>"))
       xml->sxml)))))

(define* (make-identity-provider
          issuer
          key-file
          subject
          encrypted-password
          jwks-uri
          authorization-endpoint-uri
          token-endpoint-uri)
  (let ((discovery
         (make <oidc-discovery>
           #:path "/.well-known/openid-configuration"
           #:configuration
           (make <oidc-configuration>
             #:jwks-uri jwks-uri
             #:authorization-endpoint authorization-endpoint-uri
             #:token-endpoint token-endpoint-uri)))
        (authz
         (make <authorization-endpoint>
           #:subject subject
           #:encrypted-password encrypted-password
           #:key-file key-file
           #:path (uri-path authorization-endpoint-uri)))
        (token
         (make <token-endpoint>
           #:path (uri-path token-endpoint-uri)
           #:issuer issuer
           #:key-file key-file))
        (jwks
         (make <jwks-endpoint>
           #:path (uri-path jwks-uri)
           #:key-file key-file)))
    (let ((idp (make <identity-provider>
                 #:oidc-discovery discovery
                 #:authorization-endpoint authz
                 #:token-endpoint token
                 #:jwks-endpoint jwks
                 #:default (make <default>))))
      (lambda (request 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 identity provider 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 idp request request-body)
                (values response response-body)))
            #:unwind? #t))))))