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

Minor fixes

This commit is contained in:
Tony Garnock-Jones 2016-10-24 22:01:10 -04:00
parent 171a51d68c
commit cd83b5f5d8
2 changed files with 59 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
racket/syndicate/drivers/web.rkt
View File

@ -4,6 +4,7 @@
(provide (struct-out web-virtual-host) (provide (struct-out web-virtual-host)
(struct-out web-resource) (struct-out web-resource)
url->resource url->resource
resource->url
(struct-out web-request) (struct-out web-request)
(struct-out web-request-header) (struct-out web-request-header)
@ -52,6 +53,7 @@
(require xml) (require xml)
(require/activate "timer.rkt") (require/activate "timer.rkt")
(require "../protocol/advertise.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -91,10 +93,12 @@
(define-event-expander web-request-incoming (define-event-expander web-request-incoming
(syntax-rules () (syntax-rules ()
[(_ (id req) vh method path) [(_ (id req) vh method path)
(web-request-incoming (id req) vh method path _)]
[(_ (id req) vh method path body)
(message (web-request ($ id _) (message (web-request ($ id _)
'inbound 'inbound
($ req (web-request-header method (web-resource vh `path) _ _)) ($ req (web-request-header method (web-resource vh `path) _ _))
_))])) body))]))
(define-event-expander web-request-get (define-event-expander web-request-get
(syntax-rules () (syntax-rules ()
@ -139,6 +143,21 @@
(url-port u)) (url-port u))
(format-url-path u))) (format-url-path u)))
(define (resource->url r #:query [query '()])
(match-define (web-resource (web-virtual-host scheme host port) path) r)
(url scheme
#f
host
port
#t
(let loop ((p path))
(match p
['() '()]
[(list d par ... rest)
(cons (path/param d par) (loop rest))]))
query
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-web-driver) (define (spawn-web-driver)
@ -184,13 +203,9 @@
(actor #:name (list 'web-req id) (actor #:name (list 'web-req id)
(on-start (send! (set-timer (list 'web-req id) 100 'relative)) (on-start (send! (set-timer (list 'web-req id) 100 'relative))
(send! web-req)) (send! web-req))
;; TODO: protocol for 500 Internal server error
(stop-when (message (timer-expired (list 'web-req id) _)) (stop-when (message (timer-expired (list 'web-req id) _))
(do-response-complete control-ch (do-response-complete control-ch id header-404 '()))
id
(make-web-response-header
#:code 404
#:message #"Not found")
'()))
(stop-when (message (web-response-complete id $rh $body)) (stop-when (message (web-response-complete id $rh $body))
(do-response-complete control-ch id rh body)) (do-response-complete control-ch id rh body))
(stop-when (asserted (web-response-chunked id $rh)) (stop-when (asserted (web-response-chunked id $rh))
@ -198,6 +213,8 @@
(stop-when (asserted (web-response-websocket id $headers)) (stop-when (asserted (web-response-websocket id $headers))
(do-response-websocket control-ch id headers))))) (do-response-websocket control-ch id headers)))))
(define header-404 (make-web-response-header #:code 404 #:message #"Not found"))
(define (do-response-complete control-ch id rh constree-of-bytes) (define (do-response-complete control-ch id rh constree-of-bytes)
(match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh) (match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh)
(channel-put control-ch (channel-put control-ch
@ -348,17 +365,17 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (do-client-request id req body) (define (do-client-request id req body)
(react (stop-when (asserted (observe (web-response-websocket id _)))
(stop-when (asserted (observe (web-response-websocket id _))) (do-request-websocket id req))
(do-request-websocket id req)) (stop-when (asserted (observe (web-response-complete id _ _)))
(stop-when (asserted (observe (web-response-complete id _ _))) (do-request-complete id req body))
(do-request-complete id req body)) (stop-when (asserted (observe (web-response-chunked id _)))
(stop-when (asserted (observe (web-response-chunked id _))) (do-request-chunked id req body)))
(do-request-chunked id req body))))
(define (analyze-outbound-request req) (define (analyze-outbound-request req)
(match-define (web-request-header method (match-define (web-request-header method
(web-resource (web-virtual-host scheme host port) path) (and resource
(web-resource (web-virtual-host scheme host port) _))
headers headers
query) query)
req) req)
@ -368,18 +385,7 @@
["https" 443] ["https" 443]
[_ #f])) [_ #f]))
method method
(url->string (url scheme (url->string (resource->url resource #:query query))
#f
host
port
#t
(let loop ((p path))
(match p
['() '()]
[(list d par ... rest)
(cons (path/param d par) (loop rest))]))
query
#f))
headers)) headers))
(define (do-request-websocket id req) (define (do-request-websocket id req)
@ -446,10 +452,10 @@
(send-ground-message (web-raw-client-conn id response)))) (send-ground-message (web-raw-client-conn id response))))
(react (react
(stop-when (message (inbound (web-raw-client-conn id $r))) (stop-when (message (inbound (web-raw-client-conn id $r)))
(react (stop-when (retracted (observe (web-response-complete id _ _)))) (react (stop-when (asserted (observe (web-response-complete id _ _)))
(if (exn? r) (if (exn? r)
(assert (web-response-websocket id #f #f)) (send! (web-response-complete id #f #f))
(begin (assert r))))))) (send! r)))))))
(define (do-request-chunked id req body) (define (do-request-chunked id req body)
(log-error "do-request-chunked: unimplemented") (log-error "do-request-chunked: unimplemented")

45
racket/syndicate/examples/actor/web-sanity-check.rkt
View File

@ -20,29 +20,28 @@
'inbound 'inbound
($ req (web-request-header _ (web-resource vh `("ws" ())) _ _)) ($ req (web-request-header _ (web-resource vh `("ws" ())) _ _))
_)) _))
(actor (react (actor (assert (web-response-websocket id))
(assert (web-response-websocket id)) (stop-when (retracted (observe (websocket-message id 'outbound _)))
(stop-when (retracted (observe (websocket-message id 'outbound _))) (log-info "Connection dropped"))
(log-info "Connection dropped")) (stop-when (message (websocket-message id 'inbound "quit"))
(stop-when (message (websocket-message id 'inbound "quit")) (log-info "Received quit command"))
(log-info "Received quit command")) (on (message (websocket-message id 'inbound $str))
(on (message (websocket-message id 'inbound $str)) (log-info "Got ~v" str)
(log-info "Got ~v" str) (define u (string->url str))
(define u (string->url str)) (when (url-scheme u)
(when (url-scheme u) (let ((r (gensym 'client)))
(let ((r (gensym 'client))) (react (on-start
(react (on-start (send! (web-request r
(send! (web-request r 'outbound
'outbound (web-request-header 'get
(web-request-header 'get (url->resource u)
(url->resource u) '()
'() '())
'()) #"")))
#""))) (stop-when (message (web-response-complete r $h $body))
(stop-when (asserted (web-response-complete r $h $body)) (log-info "Got headers back: ~v" h)
(log-info "Got headers back: ~v" h) (log-info "Got body back: ~v" body)))))
(log-info "Got body back: ~v" body))))) (send! (websocket-message id 'outbound str)))))
(send! (websocket-message id 'outbound str))))))
(on (message (web-request $id (on (message (web-request $id
'inbound 'inbound