syndicate-rkt/syndicate-examples/web-core.rkt

88 lines
3.5 KiB
Racket

;;; 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))))))))