From c125564f5fd27a2894a39099abf66645112def87 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 15 Aug 2018 10:11:07 +0100 Subject: [PATCH] Improve example --- syndicate/drivers/web.rkt | 49 ++++++++++++++++++++++------ syndicate/examples/web-core.rkt | 57 +++++++++++++++++++++++++++------ 2 files changed, 88 insertions(+), 18 deletions(-) diff --git a/syndicate/drivers/web.rkt b/syndicate/drivers/web.rkt index 1f83659..7f9e2cc 100644 --- a/syndicate/drivers/web.rkt +++ b/syndicate/drivers/web.rkt @@ -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 ]) + (except-out (struct-out http-response-websocket) http-response-websocket) + (rename-out [make-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 #""] xexpr) + (bytes-append preamble (string->bytes/utf-8 (xexpr->string xexpr)))) diff --git a/syndicate/examples/web-core.rkt b/syndicate/examples/web-core.rkt index f02fd17..98a9129 100644 --- a/syndicate/examples/web-core.rkt +++ b/syndicate/examples/web-core.rkt @@ -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))))))))