;;;; SPDX-FileCopyrightText: 2023 Vasilij Schneidermann <mail@vasilij.de>
;;;;
;;;; SPDX-License-Identifier: GPL-3.0-or-later

(module modo-rest-api-test ()

(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken format))
(import (chicken process-context))
(import http-client)
(import (rename intarweb (headers create-headers)))
(import medea)
(import (except test test))
(import uri-common)

(define-syntax test
  (syntax-rules ()
    ((test expect expr)
     (test #f expect expr))
    ((test name expect (expr ...))
     (test-info name expect (expr ...) ()))
    ((test name expect expr)
     (test-info name expect expr ()))
    ((test a ...)
     (test-syntax-error 'test "2 or 3 arguments required"
                        (test a ...)))
    ))

(define web-port (make-parameter #f))
(define web-sessionid (make-parameter #f))

(define (api-request method path json)
  (define (condition->status-response e type)
    (let* ((status (response-status (get-condition-property e type 'response)))
           (body (get-condition-property e type 'body))
           (body (and body (read-json body))))
      (values status body)))

  (let* ((uri (uri-reference (format "http://localhost:~a~a"
                                     (web-port) path)))
         (cookie-header `(cookie #(("SESSIONID" . ,(web-sessionid))
                                   ((path . ,(uri-reference "/"))))))
         (content-type-header '(content-type application/json))
         (headers (create-headers (list cookie-header)))
         (headers (if json
                      (create-headers (list content-type-header) headers)
                      headers))
         (req (make-request method: method uri: uri headers: headers))
         (data (and json (json->string json))))
    (condition-case
     (receive (body _url res)
         (call-with-input-request req data read-json)
       (values (response-status res) body))
     (e (exn http client-error)
        (condition->status-response e 'client-error))
     (e (exn http server-error)
        (condition->status-response e 'server-error))
     (e (exn http unexpected-server-response)
        (condition->status-response e 'unexpected-server-response)))))

(define (get-request path #!optional json) (api-request 'GET path json))
(define (post-request path #!optional json) (api-request 'POST path json))
(define (put-request path #!optional json) (api-request 'PUT path json))
(define (delete-request path #!optional json) (api-request 'DELETE path json))

(define (main port)
  (web-port (string->number port))
  (let ((sessionid (get-environment-variable "SESSIONID")))
    (when (not sessionid)
      (error "SESSIONID unset"))
    (web-sessionid sessionid))
  (let ((list1 #f)
        (list2 #f)
        (list3 #f)
        (listx #f)
        (todo1 #f)
        (todo2 #f)
        (todo3 #f)
        (todox #f))

    (test-group "empty database"
      (receive (status json)
          (get-request "/api/lists")
        (test 'ok status)
        (test #() json))

      (test-assert (eqv? (get-request "/api/list/1") 'not-found)))

    (test-group "insert list"
      (receive (status json) (post-request "/api/list" '((content . "List 1")))
        (test 'ok status)
        (set! list1 (alist-ref 'lid json)))
      (receive (status json) (post-request "/api/list" '((content . "Oops")))
        (test 'ok status)
        (set! listx (alist-ref 'lid json)))
      (receive (status json) (post-request "/api/list" '((content . "List x")))
        (test 'ok status)
        (set! list3 (alist-ref 'lid json)))
      (receive (status json) (post-request "/api/list" '((content . "List 2")))
        (test 'ok status)
        (set! list2 (alist-ref 'lid json))))

    (test-group "delete list"
      (test-assert (eqv? (get-request (format "/api/list/~a" listx)) 'ok))
      (test-assert (eqv? (delete-request (format "/api/list/~a" listx)) 'no-content))
      (test-assert (eqv? (get-request (format "/api/list/~a" listx)) 'not-found)))

    (test-group "update list"
      (receive (status json) (get-request (format "/api/list/~a" list3))
        (test 'ok status)
        (test "List x" (alist-ref 'content json)))
      (test-assert (eqv? (put-request (format "/api/list/~a" list3) '((content . "List 3"))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a" list3) '((content . "List 3"))) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a" list3))
        (test 'ok status)
        (test "List 3" (alist-ref 'content json))))

    (test-group "reorder list"
      (receive (status json) (get-request "/api/lists")
        (test '("List 1" "List 3" "List 2")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json))))
      (test-assert (eqv? (put-request (format "/api/list/~a/reorder" list3) '((to . 3))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/reorder" list3) '((to . 3))) 'no-content))
      (receive (status json) (get-request "/api/lists")
        (test '("List 1" "List 2" "List 3")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json)))))

    (test-group "reorder list (move to end)"
      (receive (status json) (get-request "/api/lists")
        (test '("List 1" "List 2" "List 3")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json))))
      (test-assert (eqv? (put-request (format "/api/list/~a/reorder" list1) '((to . -1))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/reorder" list1) '((to . -1))) 'no-content))
      (receive (status json) (get-request "/api/lists")
        (test '("List 2" "List 3" "List 1")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json)))))

    (test-group "reorder list (move to beginning)"
      (receive (status json) (get-request "/api/lists")
        (test '("List 2" "List 3" "List 1")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json))))
      (test-assert (eqv? (put-request (format "/api/list/~a/reorder" list1) '((to . 1))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/reorder" list1) '((to . 1))) 'no-content))
      (receive (status json) (get-request "/api/lists")
        (test '("List 1" "List 2" "List 3")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json)))))

    (test-group "insert todo"
      (receive (status json) (post-request (format "/api/list/~a/todo" list1) '((content . "TODO 1")))
        (test 'ok status)
        (set! todo1 (alist-ref 'tid json)))
      (receive (status json) (post-request (format "/api/list/~a/todo" list1) '((content . "Oops")))
        (test 'ok status)
        (set! todox (alist-ref 'tid json)))
      (receive (status json) (post-request (format "/api/list/~a/todo" list1) '((content . "TODO x")))
        (test 'ok status)
        (set! todo3 (alist-ref 'tid json)))
      (receive (status json) (post-request (format "/api/list/~a/todo" list1) '((content . "TODO 2")))
        (test 'ok status)
        (set! todo2 (alist-ref 'tid json))))

    (test-group "delete todo"
      (test-assert (eqv? (get-request (format "/api/list/~a/todo/~a" list1 todox)) 'ok))
      (test-assert (eqv? (delete-request (format "/api/list/~a/todo/~a" list1 todox)) 'no-content))
      (test-assert (eqv? (get-request (format "/api/list/~a/todo/~a" list1 todox)) 'not-found)))

    (test-group "update todo"
      (receive (status json) (get-request (format "/api/list/~a/todo/~a" list1 todo3))
        (test 'ok status)
        (test "TODO x" (alist-ref 'content json)))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a" list1 todo3) '((content . "TODO 3"))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a" list1 todo3) '((content . "TODO 3"))) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a/todo/~a" list1 todo3))
        (test 'ok status)
        (test "TODO 3" (alist-ref 'content json))))

    (test-group "reorder todo"
      (receive (status json) (get-request (format "/api/list/~a/todos" list1))
        (test '("TODO 1" "TODO 3" "TODO 2")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json))))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/reorder" list1 todo3) '((to . 3))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/reorder" list1 todo3) '((to . 3))) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a/todos" list1))
        (test '("TODO 1" "TODO 2" "TODO 3")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json)))))

    (test-group "reorder todo (move to end)"
      (receive (status json) (get-request (format "/api/list/~a/todos" list1))
        (test '("TODO 1" "TODO 2" "TODO 3")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json))))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/reorder" list1 todo1) '((to . -1))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/reorder" list1 todo1) '((to . -1))) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a/todos" list1))
        (test '("TODO 2" "TODO 3" "TODO 1")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json)))))

    (test-group "reorder todo (move to beginning)"
      (receive (status json) (get-request (format "/api/list/~a/todos" list1))
        (test '("TODO 2" "TODO 3" "TODO 1")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json))))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/reorder" list1 todo1) '((to . 1))) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/reorder" list1 todo1) '((to . 1))) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a/todos" list1))
        (test '("TODO 1" "TODO 2" "TODO 3")
               (map (lambda (item) (alist-ref 'content item)) (vector->list json)))))

    (test-group "finish todo"
      (receive (status json) (get-request (format "/api/list/~a/todo/~a" list1 todo1))
        (test 'ok status)
        (test #f (alist-ref 'done json)))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/finish" list1 todo1)) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/finish" list1 todo1)) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a/todo/~a" list1 todo1))
        (test 'ok status)
        (test #t (alist-ref 'done json))))

    (test-group "resurrect todo"
      (receive (status json) (get-request (format "/api/list/~a/todo/~a" list1 todo1))
        (test 'ok status)
        (test #t (alist-ref 'done json)))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/resurrect" list1 todo1)) 'no-content))
      (test-assert (eqv? (put-request (format "/api/list/~a/todo/~a/resurrect" list1 todo1)) 'no-content))
      (receive (status json) (get-request (format "/api/list/~a/todo/~a" list1 todo1))
        (test 'ok status)
        (test #f (alist-ref 'done json)))))

  (test-group "clean up"
    (receive (status json) (get-request "/api/lists")
      (test 'ok status)
      (for-each
       (lambda (item)
         (let ((lid (alist-ref 'lid item)))
           (receive (status json)
               (get-request (format "/api/list/~a/todos" lid))
             (test 'ok status)
             (for-each
              (lambda (item)
                (let ((tid (alist-ref 'tid item)))
                  (let ((path (format "/api/list/~a/todo/~a" lid tid)))
                    (test-assert (eqv? (delete-request path) 'no-content)))))
              (vector->list json)))
           (let ((path (format "/api/list/~a" lid)))
             (test-assert (eqv? (delete-request path) 'no-content)))))
       (vector->list json))))
  (test-exit))

(apply main (command-line-arguments))

)