Expanders for events and assertion-patterns.
Introduced expanders for events (define-event-expander) and for assertion-patterns (define-assertion-expander). Introduced convenience syntax and utilities in web.rkt for working with web requests. Support nested bindings in assertion-patterns for message events (only).
This commit is contained in:
parent
796acbeea2
commit
819ff13835
|
@ -14,6 +14,7 @@
|
||||||
"pict-lib"
|
"pict-lib"
|
||||||
"sgl"
|
"sgl"
|
||||||
"struct-defaults"
|
"struct-defaults"
|
||||||
|
"auxiliary-macro-context"
|
||||||
))
|
))
|
||||||
(define build-deps '("racket-doc"
|
(define build-deps '("racket-doc"
|
||||||
"scribble-lib"))
|
"scribble-lib"))
|
||||||
|
|
|
@ -565,6 +565,30 @@
|
||||||
(define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...)))
|
(define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...)))
|
||||||
(define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...)))
|
(define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...)))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(require auxiliary-macro-context)
|
||||||
|
|
||||||
|
(define-auxiliary-macro-context
|
||||||
|
#:context-name event-expander
|
||||||
|
#:prop-name prop:event-expander
|
||||||
|
#:prop-predicate-name event-expander?
|
||||||
|
#:prop-accessor-name event-expander-proc
|
||||||
|
#:macro-definer-name define-event-expander
|
||||||
|
#:introducer-parameter-name current-event-expander-introducer
|
||||||
|
#:local-introduce-name syntax-local-event-expander-introduce
|
||||||
|
#:expander-id-predicate-name event-expander-id?
|
||||||
|
#:expander-transform-name event-expander-transform)
|
||||||
|
|
||||||
|
(provide (for-syntax
|
||||||
|
prop:event-expander
|
||||||
|
event-expander?
|
||||||
|
event-expander-proc
|
||||||
|
syntax-local-event-expander-introduce
|
||||||
|
event-expander-id?
|
||||||
|
event-expander-transform)
|
||||||
|
define-event-expander)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Syntax-time support
|
;; Syntax-time support
|
||||||
|
|
||||||
|
@ -637,9 +661,23 @@
|
||||||
#`(for [(entry (in-set entry-set))]
|
#`(for [(entry (in-set entry-set))]
|
||||||
#,entry-handler-stx)))])))))
|
#,entry-handler-stx)))])))))
|
||||||
|
|
||||||
(define-for-syntax (analyze-event outer-expr-stx event-stx terminal? script-stx priority-stx)
|
(define-for-syntax orig-insp
|
||||||
|
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||||
|
|
||||||
|
(define-for-syntax (analyze-event outer-expr-stx armed-event-stx terminal? script-stx priority-stx)
|
||||||
|
(define event-stx (syntax-disarm armed-event-stx orig-insp))
|
||||||
(syntax-parse event-stx
|
(syntax-parse event-stx
|
||||||
#:literals [core:message asserted retracted rising-edge]
|
#:literals [core:message asserted retracted rising-edge]
|
||||||
|
[(expander args ...)
|
||||||
|
#:when (event-expander-id? #'expander)
|
||||||
|
(event-expander-transform
|
||||||
|
event-stx
|
||||||
|
(lambda (result)
|
||||||
|
(analyze-event outer-expr-stx
|
||||||
|
(syntax-rearm result event-stx)
|
||||||
|
terminal?
|
||||||
|
script-stx
|
||||||
|
priority-stx)))]
|
||||||
[(core:message P L:meta-level)
|
[(core:message P L:meta-level)
|
||||||
(define-values (proj pat bindings _instantiated)
|
(define-values (proj pat bindings _instantiated)
|
||||||
(analyze-pattern event-stx #'P))
|
(analyze-pattern event-stx #'P))
|
||||||
|
|
|
@ -18,6 +18,14 @@
|
||||||
(struct-out web-response-chunk)
|
(struct-out web-response-chunk)
|
||||||
(struct-out websocket-message)
|
(struct-out websocket-message)
|
||||||
|
|
||||||
|
web-request-incoming
|
||||||
|
web-request-get
|
||||||
|
websocket-connection-closed
|
||||||
|
websocket-message-recv
|
||||||
|
websocket-message-send!
|
||||||
|
web-respond/bytes!
|
||||||
|
web-respond/xexpr!
|
||||||
|
|
||||||
spawn-web-driver)
|
spawn-web-driver)
|
||||||
|
|
||||||
(require net/url)
|
(require net/url)
|
||||||
|
@ -41,6 +49,7 @@
|
||||||
(require (only-in web-server/private/util lowercase-symbol!))
|
(require (only-in web-server/private/util lowercase-symbol!))
|
||||||
(require web-server/dispatchers/dispatch)
|
(require web-server/dispatchers/dispatch)
|
||||||
(require struct-defaults)
|
(require struct-defaults)
|
||||||
|
(require xml)
|
||||||
|
|
||||||
(require/activate "timer.rkt")
|
(require/activate "timer.rkt")
|
||||||
|
|
||||||
|
@ -79,6 +88,45 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define-event-expander web-request-incoming
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ (id req) vh method path)
|
||||||
|
(message (web-request ($ id _)
|
||||||
|
'inbound
|
||||||
|
($ req (web-request-header method (web-resource vh `path) _ _))
|
||||||
|
_))]))
|
||||||
|
|
||||||
|
(define-event-expander web-request-get
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ (id req) vh path)
|
||||||
|
(web-request-incoming (id req) vh 'get path)]))
|
||||||
|
|
||||||
|
(define-event-expander websocket-connection-closed
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ id)
|
||||||
|
(retracted (observe (websocket-message id 'outbound _)))]))
|
||||||
|
|
||||||
|
(define-event-expander websocket-message-recv
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ id str)
|
||||||
|
(message (websocket-message id 'inbound str))]))
|
||||||
|
|
||||||
|
(define (websocket-message-send! id str)
|
||||||
|
(send! (websocket-message id 'outbound str)))
|
||||||
|
|
||||||
|
(define (web-respond/bytes! id #:header [header (make-web-response-header)] body-bytes)
|
||||||
|
(send! (web-response-complete id header body-bytes)))
|
||||||
|
|
||||||
|
(define (web-respond/xexpr! id
|
||||||
|
#:header [header (make-web-response-header)]
|
||||||
|
#:preamble [preamble #"<!DOCTYPE html>"]
|
||||||
|
body-xexpr)
|
||||||
|
(web-respond/bytes! id #:header header
|
||||||
|
(bytes-append preamble
|
||||||
|
(string->bytes/utf-8 (xexpr->string body-xexpr)))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define web-server-max-waiting (make-parameter 511)) ;; sockets
|
(define web-server-max-waiting (make-parameter 511)) ;; sockets
|
||||||
(define web-server-connection-manager (make-parameter #f))
|
(define web-server-connection-manager (make-parameter #f))
|
||||||
(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds
|
(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds
|
||||||
|
@ -141,11 +189,9 @@
|
||||||
(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
|
id
|
||||||
(web-response-header 404
|
(make-web-response-header
|
||||||
#"Not found"
|
#:code 404
|
||||||
(current-seconds)
|
#:message #"Not found")
|
||||||
#"text/plain"
|
|
||||||
'())
|
|
||||||
'()))
|
'()))
|
||||||
(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))
|
||||||
|
|
|
@ -0,0 +1,34 @@
|
||||||
|
#lang syndicate/actor
|
||||||
|
;; Simple demo of web driver. See web-demo.rkt for a more realistic example.
|
||||||
|
|
||||||
|
(require/activate syndicate/drivers/timer)
|
||||||
|
(require/activate syndicate/drivers/web)
|
||||||
|
(require net/url)
|
||||||
|
|
||||||
|
(actor #:name 'server
|
||||||
|
(react
|
||||||
|
(define vh (web-virtual-host "http" ? 9090))
|
||||||
|
|
||||||
|
(assert vh)
|
||||||
|
|
||||||
|
(on (web-request-incoming (id req) vh _ ("ws" ()))
|
||||||
|
(actor
|
||||||
|
(react
|
||||||
|
(assert (web-response-websocket id))
|
||||||
|
(stop-when (websocket-connection-closed id) (log-info "Connection dropped"))
|
||||||
|
(stop-when (websocket-message-recv id "quit") (log-info "Received quit command"))
|
||||||
|
(on (websocket-message-recv id $str)
|
||||||
|
(log-info "Got ~v" str)
|
||||||
|
(websocket-message-send! id str)))))
|
||||||
|
|
||||||
|
(field [counter 0])
|
||||||
|
(on (web-request-get (id req) vh ("foo" ,$path))
|
||||||
|
(define req-num (counter))
|
||||||
|
(counter (+ (counter) 1))
|
||||||
|
(web-respond/xexpr! id
|
||||||
|
`(html
|
||||||
|
(body
|
||||||
|
(h1 "Hi there.")
|
||||||
|
(p ,(format "Your path was ~v, and this is request ~a"
|
||||||
|
path
|
||||||
|
req-num))))))))
|
|
@ -16,6 +16,30 @@
|
||||||
(require "treap.rkt")
|
(require "treap.rkt")
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
|
|
||||||
|
(require auxiliary-macro-context)
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define-auxiliary-macro-context
|
||||||
|
#:context-name assertion-expander
|
||||||
|
#:prop-name prop:assertion-expander
|
||||||
|
#:prop-predicate-name assertion-expander?
|
||||||
|
#:prop-accessor-name assertion-expander-proc
|
||||||
|
#:macro-definer-name define-assertion-expander
|
||||||
|
#:introducer-parameter-name current-assertion-expander-introducer
|
||||||
|
#:local-introduce-name syntax-local-assertion-expander-introduce
|
||||||
|
#:expander-id-predicate-name assertion-expander-id?
|
||||||
|
#:expander-transform-name assertion-expander-transform)
|
||||||
|
|
||||||
|
(provide (for-syntax
|
||||||
|
prop:assertion-expander
|
||||||
|
assertion-expander?
|
||||||
|
assertion-expander-proc
|
||||||
|
syntax-local-assertion-expander-introduce
|
||||||
|
assertion-expander-id?
|
||||||
|
assertion-expander-transform)
|
||||||
|
define-assertion-expander)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(struct predicate-match (predicate sub-pattern) #:transparent)
|
(struct predicate-match (predicate sub-pattern) #:transparent)
|
||||||
|
@ -29,8 +53,7 @@
|
||||||
[(_ (capture sub))
|
[(_ (capture sub))
|
||||||
(match (walk v sub '())
|
(match (walk v sub '())
|
||||||
[#f #f]
|
[#f #f]
|
||||||
['() (cons v captures-rev)]
|
[nested-captures-rev (append nested-captures-rev (list v) captures-rev)])]
|
||||||
[_ (error 'match-value/captures "Bindings in capture sub-patterns not supported")])]
|
|
||||||
[(_ (predicate-match pred? sub)) #:when (pred? v)
|
[(_ (predicate-match pred? sub)) #:when (pred? v)
|
||||||
(walk v sub captures-rev)]
|
(walk v sub captures-rev)]
|
||||||
[((== ?) _)
|
[((== ?) _)
|
||||||
|
@ -60,6 +83,9 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define-for-syntax orig-insp
|
||||||
|
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define (dollar-id? stx)
|
(define (dollar-id? stx)
|
||||||
(and (identifier? stx)
|
(and (identifier? stx)
|
||||||
|
@ -69,9 +95,16 @@
|
||||||
(and (dollar-id? stx)
|
(and (dollar-id? stx)
|
||||||
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
||||||
|
|
||||||
|
(define (is-message-pattern? outer-expr-stx)
|
||||||
|
(syntax-parse outer-expr-stx
|
||||||
|
#:literals [message]
|
||||||
|
[(message _ ...) '#t]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
;; Syntax -> (Values Projection AssertionSetPattern (ListOf Identifier) Syntax)
|
;; Syntax -> (Values Projection AssertionSetPattern (ListOf Identifier) Syntax)
|
||||||
(define (analyze-pattern outer-expr-stx pat-stx0)
|
(define (analyze-pattern outer-expr-stx pat-stx0)
|
||||||
(let walk ((pat-stx pat-stx0))
|
(let walk ((armed-pat-stx pat-stx0))
|
||||||
|
(define pat-stx (syntax-disarm armed-pat-stx orig-insp))
|
||||||
(syntax-case pat-stx ($ ? quasiquote unquote quote)
|
(syntax-case pat-stx ($ ? quasiquote unquote quote)
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (walk #'p)]
|
[(quasiquote (unquote p)) (walk #'p)]
|
||||||
|
@ -90,29 +123,34 @@
|
||||||
[($ v p)
|
[($ v p)
|
||||||
(let ()
|
(let ()
|
||||||
(define-values (pr g bs _ins) (walk #'p))
|
(define-values (pr g bs _ins) (walk #'p))
|
||||||
(when (not (null? bs))
|
(when (and (not (null? bs)) (not (is-message-pattern? outer-expr-stx)))
|
||||||
(raise-syntax-error #f "nested bindings not supported" outer-expr-stx pat-stx))
|
(raise-syntax-error #f
|
||||||
|
"Nested bindings only supported in message events"
|
||||||
|
outer-expr-stx
|
||||||
|
pat-stx))
|
||||||
(values #`(?! #,pr)
|
(values #`(?! #,pr)
|
||||||
g
|
g
|
||||||
(list #'v)
|
(cons #'v bs)
|
||||||
#'v))]
|
#'v))]
|
||||||
|
|
||||||
[(? pred? p)
|
[(? pred? p)
|
||||||
;; TODO: support pred? in asserted/retracted as well as message events
|
;; TODO: support pred? in asserted/retracted as well as message events
|
||||||
(let ()
|
(let ()
|
||||||
(syntax-parse outer-expr-stx
|
(when (not (is-message-pattern? outer-expr-stx))
|
||||||
#:literals [message]
|
(raise-syntax-error #f
|
||||||
[(message _ ...) 'ok]
|
"Predicate '?' matching only supported in message events"
|
||||||
[_ (raise-syntax-error #f
|
outer-expr-stx
|
||||||
"Predicate '?' matching only supported in message events"
|
pat-stx))
|
||||||
outer-expr-stx
|
|
||||||
pat-stx)])
|
|
||||||
(define-values (pr g bs ins) (walk #'p))
|
(define-values (pr g bs ins) (walk #'p))
|
||||||
(values #`(predicate-match pred? #,pr)
|
(values #`(predicate-match pred? #,pr)
|
||||||
g
|
g
|
||||||
bs
|
bs
|
||||||
ins))]
|
ins))]
|
||||||
|
|
||||||
|
[(expander args ...)
|
||||||
|
(assertion-expander-id? #'expander)
|
||||||
|
(assertion-expander-transform pat-stx (lambda (r) (walk (syntax-rearm r pat-stx))))]
|
||||||
|
|
||||||
[(ctor p ...)
|
[(ctor p ...)
|
||||||
(let ()
|
(let ()
|
||||||
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
|
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
|
||||||
|
|
Loading…
Reference in New Issue