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

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

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