;; 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 resource-server)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc serve)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc server endpoint authentication)
  #:use-module (webid-oidc server endpoint resource-server)
  #:use-module ((webid-oidc server create) #:prefix ldp:)
  #:use-module ((webid-oidc server read) #:prefix ldp:)
  #:use-module ((webid-oidc server update) #:prefix ldp:)
  #:use-module ((webid-oidc server delete) #:prefix ldp:)
  #:use-module ((webid-oidc server resource wac) #:prefix wac:)
  #:use-module ((webid-oidc server resource path) #:prefix ldp:)
  #:use-module ((webid-oidc server resource content) #:prefix ldp:)
  #:use-module (webid-oidc server precondition)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc server endpoint authentication)
  #:use-module (webid-oidc http-link)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (webid-oidc jti)
  #:use-module (webid-oidc access-token)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #: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 control)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (sxml simple)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:export
  (
   make-authenticator
   make-resource-server
   ))

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

(define return
  (make-parameter #f))

(define-method (handle (endpoint <stub-endpoint>) request request-body)
  ((return) (assq-ref (request-meta request) 'user)))

(define* (make-authenticator #:key (server-uri #f))
  (unless (and server-uri (uri? server-uri))
    (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri).")))
  (let* ((backend (make <stub-endpoint>))
         (endpoint (make <authenticator>
                     #:backend backend
                     #:server-uri server-uri)))
    (lambda (request request-body)
      (parameterize ((web-locale request))
        (with-exception-handler
            (lambda (error)
              #f)
          (lambda ()
            (let/ec ret
              (parameterize ((return ret))
                (handle endpoint request request-body))))
          #:unwind? #t)))))

(define* (make-resource-server
          #:key
          (server-uri #f)
          (owner #f)
          (authenticator #f))
  (unless owner
    (fail (G_ "The owner is not defined.")))
  (declare-link-header!)
  (define resource-server
    (make <resource-server>
      #:server-name server-uri
      #:owner owner))
  (define authenticator
    (make <authenticator>
      #:backend resource-server
      #:server-uri server-uri))
  (lambda (request request-body)
    (let/ec return
      (parameterize ((web-locale request))
        (with-exception-handler
            (lambda (exn)
              (unless (web-exception? exn)
                (raise-exception exn))
              (return
               (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 resource server 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 authenticator request request-body)
              (return response response-body)))
          #:unwind? #t)))))