(cond-expand
 (chicken (import (scheme base)
                  (chicken base)
                  (only (chicken port) call-with-input-string)
                  (srfi 28)
                  (srfi 64)
                  utf8))
 (guile (import (except (scheme base)
                        cond-expand
                        error
                        for-each
                        assoc
                        include
                        raise)
                (srfi srfi-18)
                (srfi srfi-64)))
 (gambit (import (_test))))

(cond-expand
 (gambit (import (only (srfi 13) string-trim-right)))
 (else))

(import (json-rpc)
        (json-rpc lolevel)
        (json-rpc private compat)
        (json-rpc private)
        (srfi 180))

(json-rpc-log-level 'error)
(define server-in-file (make-parameter #f))
(define server-out-file (make-parameter #f))

(cond-expand
 (gambit
  ;; TODO: why only fully-qualified library names work?
  (define json-rpc-dispatch
    codeberg.org/rgherdt/scheme-json-rpc/json-rpc/lolevel#json-rpc-dispatch)
  (define json-rpc-compute-response
    codeberg.org/rgherdt/scheme-json-rpc/json-rpc/lolevel#json-rpc-compute-response))
 (guile (define json-rpc-dispatch
          (@@ (json-rpc lolevel) json-rpc-dispatch))
        (define json-rpc-compute-response
          (@@ (json-rpc lolevel) json-rpc-compute-response)))
 (chicken (define json-rpc-dispatch
            json-rpc.lolevel#json-rpc-dispatch)
          (define json-rpc-compute-response
            json-rpc.lolevel#json-rpc-compute-response)))

(define-request-handler (hello-handler "hello" params)
  (let ((name (cdr (assoc 'name params))))
    (string-append "Hello " name)))

(define-request-handler (gruess-handler "grüß" params)
  (let ((name (cdr (assoc 'name params))))
    (string-append "Grüß " name)))

(define-request-handler (subtract-handler "subtract" params)
  (- (vector-ref params 0)
     (vector-ref params 1)))

(define-notification-handler (update-handler "update" params)
  #f)

(define-notification-handler (exit-handler "exit" params)
  (json-rpc-exit))

(define (process-request in-port out-port)
  (let* ((req (json-read in-port))
         (res (json-rpc-dispatch req)))
    (when res
      (json-write res out-port))))

(define (notification? body)
  (let ((msg-id (assoc 'id body)))
    (or (not msg-id)
        (eq? (car msg-id) 'null))))

(define (contains-error-object? res)
  (alist-ref 'error res))

(define (run-test body expected-result expected-error)
  (define client-out-port (open-output-string))
  (define server-out-port (open-output-string))
  (define msg-id (alist-ref 'id body))
  (json-write body client-out-port)

  (let* ((client-out-str (get-output-string client-out-port))
         (server-in-port (open-input-string client-out-str)))
    (process-request server-in-port server-out-port)

    (let ((res-str (get-output-string server-out-port)))
      (when (not (equal? res-str ""))
        (let* ((client-in-port (open-input-string res-str))
               (res (json-read client-in-port)))
          (cond ((notification? body)
                 (test-assert (and (not expected-result)
                                   (not expected-error)
                                   (not res))))
                ((and expected-result res)
                 (test-equal expected-result (alist-ref 'result res))
                 (test-equal msg-id (alist-ref 'id res))
                 (test-equal json-rpc-version (alist-ref 'jsonrpc res))
                 (test-eq #f (alist-ref 'error res)))
                ((and expected-error res)
                 (test-equal (alist-ref 'code expected-error)
                             (alist-ref 'code (alist-ref 'error res)))
                 (test-eq #f (alist-ref 'result res)))
                (else
                 (test-assert (and (not res) (not expected-result)))))
          (close-input-port client-in-port)
          (close-input-port server-in-port)
          (close-output-port client-out-port)
          (close-output-port server-out-port))))))

(test-begin "json-rpc tests")

(define invalid-request -32600)
(define method-not-found -32601)

(test-begin "method: hello. Return \"Hello World!\".")
(run-test `((id . 0)
            (method . "hello")
            (params . ((name . "World!"))))
          "Hello World!"
          #f)
(test-end)

(test-begin "method: grüß. Return \"Grüß Gott!\".")
(run-test `((id . 0)
            (method . "grüß")
            (params . ((name . "Gott!"))))
          "Grüß Gott!"
          #f)
(test-end)


(test-begin "method: hellow. Error: missing method.")
(run-test `((id . 0)
            (method . "hellow")
            (params . ((name . "World!"))))
          #f
          `((code . ,method-not-found)))
(test-end)

(test-begin "method: foobar. Error: missing method.")
(run-test `((id . 0)
            (method . "foobar")
            (params . "null"))
          #f
          `((code . ,method-not-found)))
(test-end)

(test-begin "method: subtract. Return 19.")
(run-test `((id . 0)
            (method . "subtract")
            (params . #(42 23)))
          19
          #f)
(test-end)

(test-begin "method: subtract. Return -19.")
(run-test `((id . 0)
            (method . "subtract")
            (params . #(23 42)))
          -19
          #f)
(test-end)

(test-begin "method: update. Notification, do nothing.")
(run-test `((method . "update")
            (params . #(1 2 3 4 5)))
          #f
          #f)
(test-end)

(test-begin "method: 1. Error: invalid request (method name must be string).")

(run-test `((id . 1)
            (method . 1)
            (params . "bar"))
          #f
          `((code . ,invalid-request)))
(test-end)


(test-begin "batch test")

(parameterize
    ((json-rpc-handler-table
      `(("hello" . ,(lambda (params)
                      (let ((name (cdr (assoc 'name params))))
                        (string-append "Hello " name)))))))
  (let ((res (json-rpc-compute-response
              #(((id . 1)
                 (method . "hello")
                 (params . ((name . "World!"))))
                ((id . 2)
                 (method . "hello")
                 (params . ((name . "Mundo!"))))))))
    (test-begin "batch: successful")
    (test-assert (vector? res))
    (let ((res0 (vector-ref res 0))
          (res1 (vector-ref res 1)))
      (cond ((= (alist-ref 'id res0) 1)
             (test-equal "Hello World!" (alist-ref 'result res0))
             (test-equal "Hello Mundo!" (alist-ref 'result res1)))
            (else
             (test-equal "Hello World!" (alist-ref 'result res1))
             (test-equal "Hello Mundo!" (alist-ref 'result res0)))))
    (test-end "batch: successful"))

  (test-begin "batch: empty array")
  (let ((err (assoc 'error (json-rpc-compute-response #()))))
    (test-equal invalid-request (cdr (assoc 'code (cdr err)))))
  (test-end "batch: empty array")
  )

(test-end "batch test")

(test-end "json-rpc tests")