;; 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 identity-provider)
  #:use-module (webid-oidc resource-server)
  #: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)
  #:export
  (
   <simulation>
   make-simulation
   simulation?
   simulation-scroll-log!

   request
   get
   post

   grant-authorization
   add-server!
   add-client!
   )
  #:declarative? #t)

(define-record-type <simulation>
  (make-full-simulation handlers-rev log-rev)
  simulation?
  (handlers-rev simulation-handlers-rev simulation-handlers-rev-set!)
  (log-rev simulation-log-rev simulation-log-rev-set!))

(define (make-simulation)
  (make-full-simulation '() '()))

(define (simulation-scroll-log! simulation)
  (let ((log (reverse (simulation-log-rev simulation))))
    (simulation-log-rev-set! simulation '())
    log))

(define* (request simulation uri
                  #:key
                  (method 'GET)
                  (body #f)
                  (version '(1 . 1))
                  (headers '()))
  (let ((server-uri
         (build-uri (uri-scheme uri)
                    #:userinfo (uri-userinfo uri)
                    #:host (uri-host uri)
                    #:port (uri-port uri)))
        (rq
         (build-request uri
                        #:method method
                        #:version version
                        #:headers headers
                        #:port (open-output-string)))
        (rq-body body))
    (receive (response response-body)
        (let find-handler ((handlers
                            (reverse
                             (simulation-handlers-rev simulation))))
          (match handlers
            (()
             (values
              (build-response #:code 404
                              #:reason-phrase "Not Found")
              "Resource not found."))
            (((server . handler) tl ...)
             (if (equal? server server-uri)
                 (receive (response response-body . _)
                     (handler rq rq-body)
                   (if (eqv? (response-code response) 404)
                       (find-handler tl)
                       (values response response-body)))
                 (find-handler tl)))))
      (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))))
      (simulation-log-rev-set!
       simulation
       `((,rq ,rq-body ,response ,response-body)
         ,@(simulation-log-rev simulation)))
      (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)))

(define (add-server! simulation server-uri owner)
  (define (with-path uri path)
    (build-uri (uri-scheme uri)
               #:userinfo (uri-userinfo uri)
               #:host (uri-host uri)
               #:port (uri-port uri)
               #:path path))
  (let ((identity-provider
         (make-identity-provider
          server-uri
          (string-append (p:data-home)
                         "/"
                         (uri-encode (uri->string server-uri))
                         "/key.jwk")
          owner
          (crypt "password" "xxx")
          (with-path server-uri "/keys")
          (with-path server-uri "/authorize")
          (with-path server-uri "/token")
          #:http-get
          (lambda* (uri . args)
            (apply request simulation uri #:method 'GET args))))
        (server
         (make-resource-server
          #:server-uri server-uri
          #:owner owner
          #:http-get
          (lambda* (uri . args)
            (apply request simulation uri #:method 'GET args)))))
    (define (handle request body)
      (let ((path (uri-path (request-uri request))))
        (if (member path
                    '("/.well-known/openid-configuration"
                      "/keys"
                      "/authorize"
                      "/token"))
            (identity-provider request body)
            (server request body))))
    ;; Ensure that the profile exists
    (server:create-root server-uri owner)
    (simulation-handlers-rev-set!
     simulation 
     `((,server-uri . ,handle)
       ,@(simulation-handlers-rev simulation)))))

(define (add-client! simulation server-uri client-id redirect-uri name uri)
  (simulation-handlers-rev-set!
   simulation 
   `((,server-uri
      . ,(client:serve-application client-id redirect-uri
                                   #:client-name name
                                   #:client-uri uri))
     ,@(simulation-handlers-rev simulation))))