;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

#lang syndicate

(require/activate syndicate/drivers/web)
(require/activate syndicate/drivers/timer)

(define server (http-server "localhost" 8081 #f))

(define (button text link)
  `(form ((method "POST") (action ,link)) (button ((type "submit")) ,text)))

(define (redirect-response id url)
  (http-response #:code 303 #:message #"See other"
                 #:headers `((Location . ,url))
                 id (xexpr->bytes/utf-8 `(html (a ((href ,url)) "continue")))))

(spawn

 (during (http-request $id $method $resource _ _ _)
   (stop-when (asserted ($ details (http-request-peer-details id _ _ _ _)))
     (log-info "~a: ~a ~v ~v" id method resource details)))

 (during/spawn (http-request $id 'get (http-resource server '("" ())) _ _ _)
   (assert (http-accepted id))
   (assert (http-response id (xexpr->bytes/utf-8
                              `(html
                                (h1 "Hello")
                                ,(button "Make a new counter" "/newcounter"))))))

 (during/spawn (http-request $id 'post (http-resource server '("newcounter" ())) _ _ _)
   (assert (http-accepted id))
   (on-start (define counter-url (spawn-counter))
             (react (assert (redirect-response id counter-url)))))

 (during/spawn (http-request $id 'get (http-resource server '("chunked" ())) _ _ _)
   (assert (http-accepted id))
   (assert (http-response id 'chunked #:mime-type #"text/plain"))
   (on-start (sleep 1)
             (send! (http-response-chunk id #"One\n"))
             (sleep 1)
             (send! (http-response-chunk id #"Two\n"))
             (sleep 1)
             (send! (http-response-chunk id #"Three\n"))
             (stop-current-facet)))

 (during/spawn (http-request $id 'get (http-resource server '("ws-echo" ())) _ _ _)
   (assert (http-accepted id))
   (assert (http-response-websocket id))
   (on (message (websocket-in id $body))
       (log-info "~a sent: ~v" id body)
       (send! (websocket-out id (format "You said: ~a" body))))
   (on (message (websocket-in id "quit"))
       (stop-current-facet))
   (on-start (log-info "Starting websocket connection ~a" id))
   (on-stop (log-info "Stopping websocket connection ~a" id)))
 )

(define (spawn-counter)
  (define counter-id (symbol->string (gensym 'counter)))
  (define counter-url (string-append "/" counter-id))
  (begin0 counter-url
    (spawn
     #:name counter-id

     (field [counter 0])

     (during (http-request $id 'get (http-resource server `(,counter-id ())) _ _ _)
       (assert (http-accepted id))
       (assert
        (http-response id (xexpr->bytes/utf-8
                           `(html (h1 "Counter")
                                  (p "The counter is: " ,(number->string (counter)))
                                  ,(button "Increment" (string-append "/" counter-id "/inc"))
                                  ,(button "Decrement" (string-append "/" counter-id "/dec"))
                                  (p "(Return " (a ((href "/")) "home") ")"))))))

     (during (http-request $id 'post (http-resource server `(,counter-id ("inc" ()))) _ _ _)
       (assert (http-accepted id))
       (on-start (counter (+ (counter) 1))
                 (react (assert (redirect-response id counter-url)))))

     (during (http-request $id 'post (http-resource server `(,counter-id ("dec" ()))) _ _ _)
       (assert (http-accepted id))
       (on-start (counter (- (counter) 1))
                 (react (assert (redirect-response id counter-url))))))))