;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 simulation)
  #:use-module ((webid-oidc client) #:prefix client:)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc server create) #:prefix server:)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 match)
  #:use-module (ice-9 control)
  #:use-module (srfi srfi-26)
  #:use-module (sxml simple)
  #:use-module (oop goops)
  #:export
  (
   <simulation>
   endpoint
   log

   scroll-log!

   request
   get
   post

   grant-authorization
   )
  #:declarative? #t)

(define-class <simulation> ()
  (endpoint #:init-keyword #:endpoint #:getter endpoint)
  (log-rev #:getter log-rev #:init-value '()))

(define-method (log (simulation <simulation>))
  (reverse (log-rev simulation)))

(define-method (scroll-log! (simulation <simulation>))
  (let ((the-log (log simulation)))
    (slot-set! simulation 'log-rev '())
    the-log))

(define* (request simulation uri
                  #:key
                  (method 'GET)
                  (body #f)
                  (version '(1 . 1))
                  (headers '()))
  (let ((rq
         (build-request uri
                        #:method method
                        #:version version
                        #:headers headers
                        #:port (open-output-string)))
        (rq-body body))
    (receive (response response-body)
        (let/ec return
          (with-exception-handler
              (lambda (error)
                (when (web-exception? error)
                  (return
                   (build-response #:code (web-exception-code error)
                                   #:reason-phrase (web-exception-reason-phrase error)
                                   #: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")))
                                   (head
                                    (title ,(W_ "An error happened…")))
                                   (body
                                    ,(call-with-input-string
                                         (format #f (W_ "<p>Sorry, an error happened.</p>"))
                                       xml->sxml)
                                    ,(user-message-sxml error))))
                           <>))))
                ;; Other kind of exception
                (raise-exception error))
            (lambda ()
              (receive (response response-body response-meta)
                  (handle (endpoint simulation) rq rq-body)
                (values response response-body)))))
      (unless (response-date response)
        ;; We need to set a date.
        (set! response
              (build-response #:version (response-version response)
                              #:code (response-code response)
                              #:reason-phrase (response-reason-phrase response)
                              #:headers `((date . ,((p:current-date)))
                                          ,@(response-headers response))
                              #:port (response-port response))))
      (slot-set! simulation 'log-rev
                 `((,rq ,rq-body ,response ,response-body)
                   ,@(slot-ref simulation 'log-rev)))
      (values response response-body))))

(define* (get simulation uri . args)
  (apply request simulation uri #:method 'GET args))

(define* (post simulation uri . args)
  (apply request simulation uri #:method 'POST args))

(define (grant-authorization simulation authorization-uri)
  (receive (response response-body)
      (request simulation authorization-uri
               #:method 'POST
               #:body "password=password"
               #:headers '((content-type application/x-www-form-urlencoded)))
    (unless (and (eqv? (response-code response) 302)
                 (response-location response)
                 (uri-query (response-location response))
                 (string-prefix? "code=" (uri-query (response-location response))))
      (fail (format #f (G_ "invalid credentials: response ~s ~s")
                    (response-code response)
                    (response-reason-phrase response))))
    (let* ((uri (response-location response))
           (query (uri-query uri))
           (code (substring query (string-length "code="))))
      code)))