Flesh out server significantly; stub test utility
This commit is contained in:
parent
23a923ad77
commit
d9866843f2
|
@ -0,0 +1,93 @@
|
||||||
|
#lang syndicate/actor
|
||||||
|
|
||||||
|
(require racket/dict)
|
||||||
|
(require racket/format)
|
||||||
|
(require racket/set)
|
||||||
|
(require racket/string)
|
||||||
|
(require racket/port)
|
||||||
|
(require net/url)
|
||||||
|
(require net/uri-codec)
|
||||||
|
|
||||||
|
(require/activate syndicate/drivers/timer)
|
||||||
|
(require/activate syndicate/drivers/web)
|
||||||
|
|
||||||
|
(require "private/util.rkt")
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define vh (web-virtual-host "http" ? 7000)) ;; client
|
||||||
|
|
||||||
|
(define server-res (url->resource (string->url "http://localhost:7827/")))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (request! verb path #:body [body #""])
|
||||||
|
(web-request! verb
|
||||||
|
(url->string (resource->url (struct-copy web-resource server-res [path path])))
|
||||||
|
#:body body))
|
||||||
|
|
||||||
|
(let ((e (read-bytes-line-evt (current-input-port) 'any)))
|
||||||
|
(define (print-prompt)
|
||||||
|
(printf "> ")
|
||||||
|
(flush-output))
|
||||||
|
(actor (on-start (print-prompt))
|
||||||
|
(stop-when (message (inbound (external-event e (list (? eof-object? _))))))
|
||||||
|
(assert 'shell-running)
|
||||||
|
(on (message (inbound (external-event e (list (? bytes? $bs)))))
|
||||||
|
(match (string-split (string-trim (bytes->string/utf-8 bs)))
|
||||||
|
[(list "topic" topic)
|
||||||
|
(request! 'put `("topic" (,topic ())))]
|
||||||
|
[(list* "pub" topic strs)
|
||||||
|
(request! 'post `("topic" (,topic ()))
|
||||||
|
#:body (string->bytes/utf-8 (string-join strs)))]
|
||||||
|
[(list "sub" topic)
|
||||||
|
(spawn-subscriber topic)]
|
||||||
|
[(list)
|
||||||
|
(void)]
|
||||||
|
[_
|
||||||
|
(printf "Unexpected input\n")])
|
||||||
|
(sleep 0.1)
|
||||||
|
(print-prompt))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(actor #:name 'main
|
||||||
|
(stop-when (retracted 'shell-running))
|
||||||
|
|
||||||
|
(assert vh)
|
||||||
|
|
||||||
|
(on (web-request-get (id req) vh ("" ()))
|
||||||
|
(actor*
|
||||||
|
(web-respond/xexpr! id
|
||||||
|
`(html
|
||||||
|
(body
|
||||||
|
(h1 "Poke running")))))))
|
||||||
|
|
||||||
|
(actor #:name 'sink
|
||||||
|
(on (web-request-incoming (id req) vh 'post ("sink" ()) $body)
|
||||||
|
(printf "SINK POST: ~v >>> ~v\n" req body)
|
||||||
|
(if (equal? body #"fail")
|
||||||
|
(web-respond/status! id 500 #"Deliberate failure")
|
||||||
|
(web-respond/bytes! id #"")))
|
||||||
|
(on (web-request-get (id req) vh ("sink" ()))
|
||||||
|
(printf "SINK GET: ~v\n" req)
|
||||||
|
(define challenge (dict-ref (web-request-header-query req) 'hub.challenge ""))
|
||||||
|
(web-respond/bytes! id (string->bytes/utf-8 challenge))))
|
||||||
|
|
||||||
|
(actor #:name 'incoming-tracer
|
||||||
|
(assert (observe (web-response-complete _ _ _))) ;; :-( See journal for 30 Oct 2016
|
||||||
|
(on (web-request-incoming (id req) vh $verb ,$path $body)
|
||||||
|
(printf "~a ==> ~a ~v ~v\n" id verb path body)
|
||||||
|
(react (stop-when (message (web-response-complete id $resp $body))
|
||||||
|
(printf "~a <== ~v ~v\n" id resp body))
|
||||||
|
(on-start (send! (set-timer (list 'incoming-tracer id) 1000 'relative)))
|
||||||
|
(stop-when (message (timer-expired (list 'incoming-tracer id) _))
|
||||||
|
(printf "~a <== timeout\n" id)))))
|
||||||
|
|
||||||
|
(define (spawn-subscriber topic)
|
||||||
|
(request! 'post `("hub" ())
|
||||||
|
#:body (string->bytes/utf-8
|
||||||
|
(alist->form-urlencoded
|
||||||
|
`((hub.callback . "http://localhost:7000/sink")
|
||||||
|
(hub.mode . "subscribe")
|
||||||
|
(hub.topic . ,topic))))))
|
|
@ -1,14 +1,25 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide random-hex-string
|
(provide sleep
|
||||||
extend-url-string-query)
|
random-hex-string
|
||||||
|
extend-url-string-query
|
||||||
|
web-respond/status!
|
||||||
|
web-request!)
|
||||||
|
|
||||||
(require (only-in file/sha1 bytes->hex-string))
|
(require (only-in file/sha1 bytes->hex-string))
|
||||||
(require (only-in racket/random crypto-random-bytes))
|
(require (only-in racket/random crypto-random-bytes))
|
||||||
(require net/url)
|
(require net/url)
|
||||||
|
(require syndicate/actor)
|
||||||
|
(require syndicate/drivers/timer)
|
||||||
|
(require syndicate/drivers/web)
|
||||||
|
|
||||||
(module+ test (require rackunit))
|
(module+ test (require rackunit))
|
||||||
|
|
||||||
|
(define (sleep sec)
|
||||||
|
(define timer-id (gensym 'sleep))
|
||||||
|
(until (message (timer-expired timer-id _))
|
||||||
|
(on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
|
||||||
|
|
||||||
(define (random-hex-string half-length)
|
(define (random-hex-string half-length)
|
||||||
(bytes->hex-string (crypto-random-bytes half-length)))
|
(bytes->hex-string (crypto-random-bytes half-length)))
|
||||||
|
|
||||||
|
@ -16,6 +27,29 @@
|
||||||
(define u (string->url urlstr))
|
(define u (string->url urlstr))
|
||||||
(url->string (struct-copy url u [query (append (url-query u) extension)])))
|
(url->string (struct-copy url u [query (append (url-query u) extension)])))
|
||||||
|
|
||||||
|
(define (web-respond/status! id code message [body #""])
|
||||||
|
(web-respond/bytes! id
|
||||||
|
#:header (web-response-header
|
||||||
|
#:code code
|
||||||
|
#:message message
|
||||||
|
#:headers '())
|
||||||
|
body))
|
||||||
|
|
||||||
|
(define (web-request! verb urlstr #:body [body #""] #:headers [headers '()])
|
||||||
|
(define req-id (gensym 'req))
|
||||||
|
(define u (string->url urlstr))
|
||||||
|
(define res (url->resource u))
|
||||||
|
(react/suspend (k)
|
||||||
|
(on-start
|
||||||
|
(printf "~a --> ~a ~a ~v\n" req-id verb urlstr body)
|
||||||
|
(send! (web-request req-id
|
||||||
|
'outbound
|
||||||
|
(web-request-header verb res headers (url-query u))
|
||||||
|
body)))
|
||||||
|
(stop-when (message (web-response-complete req-id $resp $body))
|
||||||
|
(printf "~a <-- ~v ~v\n" req-id resp body)
|
||||||
|
(k resp body))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (extend-url-string-query "http://localhost/" '((a . "hi")))
|
(check-equal? (extend-url-string-query "http://localhost/" '((a . "hi")))
|
||||||
"http://localhost/?a=hi")
|
"http://localhost/?a=hi")
|
||||||
|
|
107
rmq/server.rkt
107
rmq/server.rkt
|
@ -2,6 +2,7 @@
|
||||||
|
|
||||||
(provide )
|
(provide )
|
||||||
|
|
||||||
|
(require racket/dict)
|
||||||
(require racket/format)
|
(require racket/format)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require net/url)
|
(require net/url)
|
||||||
|
@ -10,6 +11,7 @@
|
||||||
(require/activate syndicate/drivers/timer)
|
(require/activate syndicate/drivers/timer)
|
||||||
(require/activate syndicate/drivers/web)
|
(require/activate syndicate/drivers/web)
|
||||||
(require syndicate/protocol/advertise)
|
(require syndicate/protocol/advertise)
|
||||||
|
(require syndicate/functional-queue)
|
||||||
|
|
||||||
(require "private/util.rkt")
|
(require "private/util.rkt")
|
||||||
|
|
||||||
|
@ -89,14 +91,6 @@
|
||||||
#:name (list 'topic topic)
|
#:name (list 'topic topic)
|
||||||
(local-topic-main topic)))
|
(local-topic-main topic)))
|
||||||
|
|
||||||
(define (web-respond/status! id code message [body #""])
|
|
||||||
(web-respond/bytes! id
|
|
||||||
#:header (web-response-header
|
|
||||||
#:code code
|
|
||||||
#:message message
|
|
||||||
#:headers '())
|
|
||||||
body))
|
|
||||||
|
|
||||||
(define (local-topic-main topic)
|
(define (local-topic-main topic)
|
||||||
(field [max-age #f]
|
(field [max-age #f]
|
||||||
[max-count #f])
|
[max-count #f])
|
||||||
|
@ -116,9 +110,8 @@
|
||||||
(on (web-request-incoming (id req) vh 'post ("topic" (,topic ())) $body)
|
(on (web-request-incoming (id req) vh 'post ("topic" (,topic ())) $body)
|
||||||
(actor*
|
(actor*
|
||||||
(define content-type
|
(define content-type
|
||||||
(cdr (or (assq 'content-type (web-request-header-headers req))
|
(dict-ref (web-request-header-headers req) 'content-type "application/octet-stream"))
|
||||||
'(content-type . "application/octet-stream"))))
|
(log-info "Topic ~a got ~v message! ~v" topic content-type body)
|
||||||
(log-info "Got ~v message! ~v" content-type body)
|
|
||||||
(send! (notification (url->string (resource->url (web-request-header-resource req)))
|
(send! (notification (url->string (resource->url (web-request-header-resource req)))
|
||||||
body
|
body
|
||||||
content-type))
|
content-type))
|
||||||
|
@ -178,11 +171,10 @@
|
||||||
|
|
||||||
(during/actor (subscription $topic _ _ $callback _)
|
(during/actor (subscription $topic _ _ $callback _)
|
||||||
#:name (list 'subscription topic callback)
|
#:name (list 'subscription topic callback)
|
||||||
|
#:on-crash (retract! (subscription topic ? ? callback ?))
|
||||||
(subscription-main topic callback)))
|
(subscription-main topic callback)))
|
||||||
|
|
||||||
(define (subscription-change-validate mode lease topic callback)
|
(define (subscription-change-validate mode lease topic callback)
|
||||||
(define u (string->url callback))
|
|
||||||
(define res (url->resource u))
|
|
||||||
(define challenge (random-hex-string 16))
|
(define challenge (random-hex-string 16))
|
||||||
(define id (gensym 'validation))
|
(define id (gensym 'validation))
|
||||||
(define extra-query (list* (cons 'hub.mode mode)
|
(define extra-query (list* (cons 'hub.mode mode)
|
||||||
|
@ -191,23 +183,66 @@
|
||||||
(if lease
|
(if lease
|
||||||
(list (cons 'hub.lease_seconds (~a lease)))
|
(list (cons 'hub.lease_seconds (~a lease)))
|
||||||
(list))))
|
(list))))
|
||||||
(react/suspend
|
(define-values (resp body)
|
||||||
(k)
|
(web-request! 'get
|
||||||
(on-start (send! (web-request id
|
(let* ((u (string->url callback)))
|
||||||
'outbound
|
(url->string
|
||||||
(web-request-header 'get
|
(struct-copy url u [query (append (url-query u) extra-query)])))))
|
||||||
res
|
(and (eq? (web-response-header-code-type resp) 'successful)
|
||||||
'()
|
(equal? body (string->bytes/utf-8 challenge))))
|
||||||
(append (url-query u) extra-query))
|
|
||||||
'())))
|
|
||||||
(on (message (web-response-complete id $resp $body))
|
|
||||||
(k (and (<= 200 (web-response-header-code resp) 299)
|
|
||||||
(equal? body (string->bytes/utf-8 challenge)))))))
|
|
||||||
|
|
||||||
(define (subscription-main topic callback)
|
(define (canonical-topic-base-url canonical-hub-str)
|
||||||
(field [expiry-timer-id #f])
|
(combine-url/relative (string->url canonical-hub-str) "/topic/"))
|
||||||
(during (subscription topic $expiry-deadline $canonical-hub callback $secret-bytes)
|
|
||||||
(on-start (log-info "Subscription configured: ~v ~v ~v"
|
(define (subscription-main partial-topic callback)
|
||||||
|
(field [expiry-timer-id #f]
|
||||||
|
[delivery-active? #f]
|
||||||
|
[message-queue (make-queue)]
|
||||||
|
[dead-letters (make-queue)])
|
||||||
|
|
||||||
|
(stop-when (rising-edge (> (queue-length (dead-letters)) 1))
|
||||||
|
(log-info "Too many dead letters for ~a" callback))
|
||||||
|
|
||||||
|
(define (deliver-queued-notifications canonical-hub)
|
||||||
|
(delivery-active? #t)
|
||||||
|
(let deliver-rest ()
|
||||||
|
(when (not (queue-empty? (message-queue)))
|
||||||
|
(define-values (n newq) (dequeue (message-queue)))
|
||||||
|
(message-queue newq)
|
||||||
|
(match-define (notification topic body content-type) n)
|
||||||
|
(let deliver-one ((retries-remaining 1)
|
||||||
|
(retry-delay 5.0))
|
||||||
|
(define-values (resp _body)
|
||||||
|
(web-request! 'post
|
||||||
|
callback
|
||||||
|
#:headers (list (cons 'content-type content-type)
|
||||||
|
(cons 'link (format "<~a>; rel=hub" canonical-hub))
|
||||||
|
(cons 'link (format "<~a>; rel=self" topic)))
|
||||||
|
#:body body))
|
||||||
|
(cond
|
||||||
|
[(eq? (web-response-header-code-type resp) 'successful)
|
||||||
|
(deliver-rest)]
|
||||||
|
[(zero? retries-remaining)
|
||||||
|
(log-info "Dead letter for ~v" callback)
|
||||||
|
(dead-letters (enqueue (dead-letters) n))
|
||||||
|
(deliver-rest)]
|
||||||
|
[else
|
||||||
|
(log-info
|
||||||
|
"Delivery to ~v failed; pausing for ~a seconds; ~a retries remaining. Response: ~v"
|
||||||
|
callback
|
||||||
|
retry-delay
|
||||||
|
retries-remaining
|
||||||
|
resp)
|
||||||
|
(sleep retry-delay)
|
||||||
|
(deliver-one (- retries-remaining 1)
|
||||||
|
(min (* retry-delay 1.618) 30))]))))
|
||||||
|
(delivery-active? #f))
|
||||||
|
|
||||||
|
(during (subscription partial-topic $expiry-deadline $canonical-hub callback $secret-bytes)
|
||||||
|
(define topic (url->string (combine-url/relative (canonical-topic-base-url canonical-hub)
|
||||||
|
partial-topic)))
|
||||||
|
(on-start (log-info "Subscription configured: ~v ~v ~v ~v"
|
||||||
|
topic
|
||||||
expiry-deadline
|
expiry-deadline
|
||||||
canonical-hub
|
canonical-hub
|
||||||
secret-bytes)
|
secret-bytes)
|
||||||
|
@ -219,11 +254,11 @@
|
||||||
[else
|
[else
|
||||||
(log-info "Subscription will not expire")
|
(log-info "Subscription will not expire")
|
||||||
(expiry-timer-id #f)]))
|
(expiry-timer-id #f)]))
|
||||||
(stop-when #:when (expiry-timer-id) (message (timer-expired (expiry-timer-id) _))
|
|
||||||
(log-info "Subscription expired"))))
|
|
||||||
|
|
||||||
(actor #:name 'sink
|
(stop-when #:when (expiry-timer-id) (message (timer-expired (expiry-timer-id) _))
|
||||||
(on (web-request-get (id req) vh ("sink" ()))
|
(log-info "Subscription expired"))
|
||||||
(define challenge (cdr (or (assq 'hub.challenge (web-request-header-query req))
|
|
||||||
(cons 'hub.challenge ""))))
|
(on (message ($ n (notification topic _ _)))
|
||||||
(web-respond/bytes! id (string->bytes/utf-8 challenge))))
|
(message-queue (enqueue (message-queue) n))
|
||||||
|
(when (not (delivery-active?))
|
||||||
|
(deliver-queued-notifications canonical-hub)))))
|
||||||
|
|
Loading…
Reference in New Issue