syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Improve example

This commit is contained in:
Tony Garnock-Jones 2018-08-15 10:11:07 +01:00
parent 061765041b
commit c125564f5f
2 changed files with 88 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
syndicate/drivers/web.rkt
View File

@ -4,13 +4,19 @@
(struct-out http-resource)
(struct-out http-request)
(struct-out http-accepted)
(struct-out http-response)
(struct-out http-response-websocket)
(except-out (struct-out http-response) http-response)
(rename-out [make-http-response http-response]
[http-response <http-response>])
(except-out (struct-out http-response-websocket) http-response-websocket)
(rename-out [make-http-response-websocket http-response-websocket]
[http-response-websocket <http-response-websocket>])
(struct-out http-request-peer-details)
(struct-out http-request-cookie)
(struct-out http-response-chunk)
(struct-out websocket-out)
(struct-out websocket-in))
(struct-out websocket-in)
xexpr->bytes/utf-8)
(require racket/async-channel)
(require racket/exn)
@ -23,6 +29,8 @@
(require net/rfc6455/dispatcher)
(require net/url)
(require struct-defaults)
(require web-server/http/bindings)
(require web-server/http/cookie)
(require web-server/http/cookie-parse)
@ -34,6 +42,8 @@
(require (only-in web-server/private/util lowercase-symbol!))
(require web-server/dispatchers/dispatch)
(require xml)
(module+ test (require rackunit))
(define-logger syndicate/drivers/web)
@ -146,10 +156,6 @@
(match-let ([(list Lip Lport Rip Rport) addresses])
(assert (http-request-peer-details id Lip Lport Rip Rport)))
(define (respond/error! code message-bytes)
(respond!
(http-response id code message-bytes (current-seconds) #"text/plain" '() message-bytes)))
(define (respond! resp)
(match-define (http-response _ c m lms mime-type headers body) resp)
(define hs (build-headers headers))
@ -193,13 +199,23 @@
(field [respondent-exists? #f])
(on-start (for [(i 3)] (flush!)) ;; TODO: UGHHHH
(when (not (respondent-exists?))
(stop-facet root-facet (respond/error! 404 #"Not found"))))
(stop-facet root-facet
(respond! (make-http-response #:code 404
#:message #"Not found"
id
(xexpr->bytes/utf-8
`(html (h1 "Not found"))))))))
(on (asserted (http-accepted id))
(respondent-exists? #t)
(react
(stop-when (retracted (http-accepted id))
(stop-facet root-facet (respond/error! 500 #"Server error")))
(stop-facet root-facet
(respond! (make-http-response #:code 500
#:message #"Server error"
id
(xexpr->bytes/utf-8
`(html (h1 "Server error")))))))
(stop-when (asserted ($ resp (http-response id _ _ _ _ _ $detail)))
(match detail
['chunked (respond/chunked! resp)]
@ -302,3 +318,18 @@
(define (exn:fail:port-is-closed? e)
(and (exn:fail? e)
(regexp-match #px"port is closed" (exn-message e))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(begin-for-declarations
(define-struct-defaults make-http-response http-response
(#:code [http-response-code 200]
#:message [http-response-message #"OK"]
#:last-modified-seconds [http-response-last-modified-seconds (current-seconds)]
#:mime-type [http-response-mime-type #"text/html"]
#:headers [http-response-headers '()]))
(define-struct-defaults make-http-response-websocket http-response-websocket
(#:headers [http-response-websocket-headers '()])))
(define (xexpr->bytes/utf-8 #:preamble [preamble #"<!DOCTYPE html>"] xexpr)
(bytes-append preamble (string->bytes/utf-8 (xexpr->string xexpr))))

57
syndicate/examples/web-core.rkt
View File

@ -5,6 +5,14 @@
(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 _ _ _)
@ -13,17 +21,19 @@
(during/spawn (http-request $id 'get (http-resource server '("" ())) _ _ _)
(assert (http-accepted id))
(assert (http-response id 200 #"OK" (current-seconds)
#"text/plain"
'()
#"Hi")))
(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 200 #"Chunked" (current-seconds)
#"text/plain"
'()
'chunked))
(assert (http-response id 'chunked #:mime-type #"text/plain"))
(on-start (sleep 1)
(send! (http-response-chunk id #"One\n"))
(sleep 1)
@ -34,7 +44,7 @@
(during/spawn (http-request $id 'get (http-resource server '("ws-echo" ())) _ _ _)
(assert (http-accepted id))
(assert (http-response-websocket 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))))
@ -43,3 +53,32 @@
(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))))))))