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

Reinterpret canonical-local-host -> canonical-baseurl. 

In order to support HTTPS nginx proxying, we need to maintain a
"fictional" baseurl which is not directly connected to this server's
listen ports. This has caused a change to configuration: now, a
baseurl is specified along with one or more listen specifications.
This commit is contained in:
Tony Garnock-Jones 2016-11-22 11:35:39 +13:00
parent 1802a36ce3
commit f14e0acfcb
11 changed files with 143 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
README.md
View File

@ -20,7 +20,7 @@ See the specification of the W3C WebSub protocol at
1. Install Racket from <http://download.racket-lang.org/> 1. Install Racket from <http://download.racket-lang.org/>
2. Install RacketMQ by running `raco pkg install --auto racketmq` 2. Install RacketMQ by running `raco pkg install --auto racketmq`
3. `racketmq --canonical-host localhost 7827` 3. `racketmq --baseurl http://localhost:7827/ --listen localhost 7827`
To install from git, replace the `raco pkg install ...` step above To install from git, replace the `raco pkg install ...` step above
with an invocation of `make link` from the top directory of your git with an invocation of `make link` from the top directory of your git
@ -45,9 +45,8 @@ checkout.
## Configuration ## Configuration
RacketMQ has only one required configuration variable: you must tell The most important RacketMQ configuration variable is its canonical
the hub its primary ("canonical") *host name* and *port number*. These base URL: the URL prefix used to build URLs for clients to use.
are used to build URLs for clients of the Hub to use.
When the RacketMQ startup script is given a "`-f` *filename*" option, When the RacketMQ startup script is given a "`-f` *filename*" option,
it loads configuration data from the named file. The option can be it loads configuration data from the named file. The option can be
@ -59,7 +58,8 @@ For a fully-commented example configuration file, see
Within each file, each configuration entry should be a list (see Within each file, each configuration entry should be a list (see
[Racket syntax](https://docs.racket-lang.org/reference/reader.html)) [Racket syntax](https://docs.racket-lang.org/reference/reader.html))
with a symbol (the "key") as its first item followed by zero or more with a symbol (the "key") as its first item followed by zero or more
items. items. Line comments start with semicolon (`;`) as usual for
S-expression languages.
Each configuration file is automatically reread by the server when it Each configuration file is automatically reread by the server when it
is changed: if you need to make changes, consider doing so atomically is changed: if you need to make changes, consider doing so atomically
@ -68,29 +68,30 @@ by producing an updated configuration file and using
### Required configuration data ### Required configuration data
(canonical-host "localhost" 7827) (canonical-baseurl "http://localhost:7827/")
Exactly one "canonical-host" key, containing two values, a string Exactly one "canonical-baseurl" key, containing a URL string naming
hostname, and a number TCP port. This causes an HTTP server to be the base URL used for constructing URLs that are given out to third
spun up on the named port. parties, such as subscription endpoints for upstream hubs to use.
Since this is the only mandatory configuration item, RacketMQ can run This is *just* for URL construction, and does NOT create any HTTP
without any configuration file at all if the server is started with listeners. Those are configured with "http-listener" keys:
the `--canonical-host` command-line argument:
racketmq --canonical-host localhost 7827 (http-listener "localhost" 7827)
;; (http-listener "localhost" 80)
### Optional configuration data ;; (http-listener "www.example.com" 7827)
;;
(accepted-host "localhost" 7827)
(accepted-host "localhost" 80)
(accepted-host "www.example.com" 7827)
;; etc. ;; etc.
If you want your server to appear under several aliases, add them At least one "http-listener" key is required. These cause an HTTP
here. HTTP servers will be spun up for all mentioned port numbers, server to be spun up for each mentioned port number. Traffic will only
and within those servers, `Host` headers matching the given host be accepted for HTTP Host headers mentioned in these keys.
names will be accepted.
Since these are the only mandatory configuration item, RacketMQ can
run without any configuration file at all if the server is started
with the `--baseurl` and `--listen` command-line arguments:
racketmq --baseurl http://localhost:7827/ --listen localhost 7827
### Fine tuning ### Fine tuning

30
racketmq/defaults.rktd
View File

@ -15,24 +15,24 @@
;;=========================================================================== ;;===========================================================================
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;; Exactly one "canonical-host" key, containing two values, a string ;; Exactly one "canonical-baseurl" key, containing a URL string naming
;; hostname, and a number TCP port. This causes an HTTP server to be ;; the base URL used for constructing URLs that are given out to third
;; spun up on the named port. ;; parties, such as subscription endpoints for upstream hubs to use.
(canonical-host "localhost" 7827) ;;
;; This is *just* for URL construction, and does NOT create any HTTP
;;=========================================================================== ;; listeners. Those are configured with "http-listener" keys,
;; OPTIONAL: ;; documented below.
;;=========================================================================== ;;
(canonical-baseurl "http://localhost:7827/")
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;; If you want your server to appear under several aliases, add them ;; At least one "http-listener" key. These cause an HTTP server to be
;; here. HTTP servers will be spun up for all mentioned port numbers, ;; spun up for each mentioned port number. Traffic will only be
;; and within those servers, `Host` headers matching the given host ;; accepted for HTTP Host headers mentioned in these keys.
;; names will be accepted.
;; ;;
;; (accepted-host "localhost" 7827) (http-listener "localhost" 7827)
;; (accepted-host "localhost" 80) ;; (http-listener "localhost" 80)
;; (accepted-host "www.example.com" 7827) ;; (http-listener "www.example.com" 7827)
;; ;;
;; etc. ;; etc.

33
racketmq/hub.rkt
View File

@ -12,17 +12,21 @@
(require/activate "hub/static-content.rkt") (require/activate "hub/static-content.rkt")
(require/activate "hub/topic-demand.rkt") (require/activate "hub/topic-demand.rkt")
(require/activate "hub/local-topic.rkt") (require/activate "hub/local-topic.rkt")
(require/activate "hub/remote-topic.rkt")
(require/activate "hub/subscription.rkt") (require/activate "hub/subscription.rkt")
(require/activate "hub/websocket.rkt") (require/activate "hub/websocket.rkt")
(command-line #:program "racketmq" (command-line #:program "racketmq"
#:once-each #:once-each
["--canonical-host" host port "Specify the canonical host and port for this hub" ["--baseurl" baseurl "Specify the canonical base URL for this hub"
(actor #:name (list 'command-line-canonical-host host port) (actor #:name (list 'command-line-canonical-baseurl baseurl)
(assert (config (list 'canonical-host host (string->number port)))))] (assert (config (list 'canonical-baseurl baseurl))))]
#:multi #:multi
[("-l" "--listen") host port "Specify one HTTP listener"
(actor #:name (list 'command-line-http-listener host port)
(assert (config (list 'http-listener host (string->number port)))))]
[("-o" "--option") key vals "Specify a single configuration option" [("-o" "--option") key vals "Specify a single configuration option"
(actor #:name (list 'config-option key vals) (actor #:name (list 'config-option key vals)
(assert (config (cons (string->symbol key) (assert (config (cons (string->symbol key)
@ -32,21 +36,20 @@
(actor #:name 'main (actor #:name 'main
(during (config (list 'canonical-host $h $p)) (during (config (list 'canonical-baseurl $u))
(assert (canonical-local-host h p)) (assert (canonical-baseurl u)))
(assert (local-host h p)))
(define/query-set canonical-local-hosts ($ c (canonical-local-host _ _)) c) (define/query-set canonical-baseurls ($ c (canonical-baseurl _)) c)
(stop-when (rising-edge (> (set-count (canonical-local-hosts)) 1)) (stop-when (rising-edge (> (set-count (canonical-baseurls)) 1))
(log-error "Too many canonical-host records in configuration.")) (log-error "Too many canonical-baseurl records in configuration."))
(on-start (sleep 0.1) (on-start (sleep 0.1)
(when (set-empty? (canonical-local-hosts)) (when (set-empty? (canonical-baseurls))
(log-error "No canonical-host records specified; try the --canonical-host command line argument"))) (log-error "No canonical-baseurl records specified; try the --baseurl command line argument")))
;; TODO: Make the too-many-canonical-host-records situation recoverable. ;; TODO: Make the too-many-canonical-baseurl-records situation recoverable.
;; TODO: And/or, make the whole application quit when it gets into a bad state. ;; TODO: And/or, make the whole application quit when it gets into a bad state.
(during (config (list 'accepted-host $h $p)) (during (config (list 'http-listener $h $p))
(assert (local-host h p))) (assert (http-listener h p)))
(during (local-host $host-name $port) (during (http-listener $host-name $port)
(assert (vh host-name port)))) (assert (vh host-name port))))

10
racketmq/hub/local-topic.rkt
View File

@ -11,7 +11,7 @@
(field [topics (set)]) (field [topics (set)])
(during (local-host $host-name $port) (during (http-listener $host-name $port)
(on (web-request-incoming (id req) (vh host-name port) 'put ("topic" (,$topic ()))) (on (web-request-incoming (id req) (vh host-name port) 'put ("topic" (,$topic ())))
(when (not (set-member? (topics) topic)) (when (not (set-member? (topics) topic))
(topics (set-add (topics) topic)) (topics (set-add (topics) topic))
@ -51,10 +51,10 @@
(max-count))) (max-count)))
(on-stop (log-info "Terminating local topic ~v" topic)) (on-stop (log-info "Terminating local topic ~v" topic))
(during (local-host $host-name $port) (during (http-listener $host-name $port)
(during (canonical-local-host $canonical-host-name $cport) (during (canonical-baseurl $baseurl)
(define hub-url (canonical-url canonical-host-name cport `("hub" ()))) (define hub-url (canonical-url baseurl `("hub" ())))
(define self-url (canonical-url canonical-host-name cport `("topic" (,topic ())))) (define self-url (canonical-url baseurl `("topic" (,topic ()))))
(define discovery-headers (list (cons 'link (format "<~a>; rel=hub" hub-url)) (define discovery-headers (list (cons 'link (format "<~a>; rel=hub" hub-url))
(cons 'link (format "<~a>; rel=self" self-url)))) (cons 'link (format "<~a>; rel=self" self-url))))

18
racketmq/hub/remote-topic.rkt
View File

@ -1,7 +1,5 @@
#lang syndicate/actor #lang syndicate/actor
(provide remote-topic-main)
(require racket/dict) (require racket/dict)
(require racket/set) (require racket/set)
(require file/sha1) (require file/sha1)
@ -34,6 +32,11 @@
(check-equal? (shrink-lease 90) 81) (check-equal? (shrink-lease 90) 81)
(check-equal? (shrink-lease 50) 45)) (check-equal? (shrink-lease 50) 45))
(actor #:name 'remote-topic-manager
(during/actor (remote-topic-demand $full-topic)
#:name (list 'remote-topic full-topic)
(remote-topic-main full-topic)))
(define (remote-topic-main full-topic) (define (remote-topic-main full-topic)
(define sub-id (random-hex-string 16)) (define sub-id (random-hex-string 16))
(log-info "Remote sub endpoint ~a for topic ~s" sub-id full-topic) (log-info "Remote sub endpoint ~a for topic ~s" sub-id full-topic)
@ -62,8 +65,8 @@
[#f "disabled"] [#f "disabled"]
[n (format "~a seconds" n)]))) [n (format "~a seconds" n)])))
(during (canonical-local-host $canonical-host-name $cport) (during (canonical-baseurl $baseurl)
(define callback (canonical-url canonical-host-name cport `("sub" (,sub-id ())))) (define callback (canonical-url baseurl `("sub" (,sub-id ()))))
(define (refresh-subscription!) (define (refresh-subscription!)
;; TODO: shared secret ;; TODO: shared secret
@ -161,7 +164,8 @@
(* 1000 (or (poll-interval-seconds) 0))))) (* 1000 (or (poll-interval-seconds) 0)))))
(poll-upstream!)) (poll-upstream!))
(on (web-request-get (id req) (vh canonical-host-name cport) ("sub" (,sub-id ()))) (during (http-listener $host-name $port)
(on (web-request-get (id req) (vh host-name port) ("sub" (,sub-id ())))
(log-info "Received verification-of-intent: ~v" (web-request-header-query req)) (log-info "Received verification-of-intent: ~v" (web-request-header-query req))
(define challenge (dict-ref (web-request-header-query req) 'hub.challenge "")) (define challenge (dict-ref (web-request-header-query req) 'hub.challenge ""))
(define lease-seconds (dict-ref (web-request-header-query req) 'hub.lease_seconds #f)) (define lease-seconds (dict-ref (web-request-header-query req) 'hub.lease_seconds #f))
@ -171,7 +175,7 @@
(log-warning "Upstream hub for topic ~s did not supply hub.lease_seconds" full-topic)) (log-warning "Upstream hub for topic ~s did not supply hub.lease_seconds" full-topic))
(web-respond/bytes! id (string->bytes/utf-8 challenge))) (web-respond/bytes! id (string->bytes/utf-8 challenge)))
(on (web-request-incoming (id req) (vh canonical-host-name cport) 'post ("sub" (,sub-id ())) $body) (on (web-request-incoming (id req) (vh host-name port) 'post ("sub" (,sub-id ())) $body)
;; TODO: verify the use of the shared secret ;; TODO: verify the use of the shared secret
(actor* (actor*
(define parsed-link-headers (parse-link-headers (web-request-header-headers req))) (define parsed-link-headers (parse-link-headers (web-request-header-headers req)))
@ -192,4 +196,4 @@
upstream-topic upstream-topic
body body
content-type)) content-type))
(web-respond/status! id 201 #"Created"))))) (web-respond/status! id 201 #"Created"))))))

2
racketmq/hub/static-content.rkt
View File

@ -16,7 +16,7 @@
(actor #:name 'static-content-server (actor #:name 'static-content-server
(define url->path (make-url->path htdocs-path)) (define url->path (make-url->path htdocs-path))
(during (local-host $host-name $port) (during (http-listener $host-name $port)
(on (web-request-get (id req) (vh host-name port) ,_) (on (web-request-get (id req) (vh host-name port) ,_)
(define-values (path path-pieces) (define-values (path path-pieces)
(url->path (resource->url (web-request-header-resource req)))) (url->path (resource->url (web-request-header-resource req))))

12
racketmq/hub/subscription.rkt
View File

@ -13,10 +13,10 @@
(require "../protocol.rkt") (require "../protocol.rkt")
(actor #:name 'hub (actor #:name 'hub
(during (local-host $host-name $port) (during (http-listener $host-name $port)
(during (canonical-local-host $canonical-host-name $cport) (during (canonical-baseurl $baseurl)
(on (web-request-incoming (id req) (vh host-name port) 'post ("hub" ()) $body) (on (web-request-incoming (id req) (vh host-name port) 'post ("hub" ()) $body)
(asynchronous-verification-of-intent id req body canonical-host-name cport) (asynchronous-verification-of-intent id req body baseurl)
(web-respond/status! id 202 #"Accepted")))) (web-respond/status! id 202 #"Accepted"))))
(on (message (update-subscription $topic $callback $settings)) (on (message (update-subscription $topic $callback $settings))
@ -28,7 +28,7 @@
#:on-crash (retract! (subscription topic callback ?)) #:on-crash (retract! (subscription topic callback ?))
(subscription-main topic callback))) (subscription-main topic callback)))
(define (asynchronous-verification-of-intent id req body canonical-host-name cport) (define (asynchronous-verification-of-intent id req body baseurl)
(actor* #:name 'verification-of-intent (actor* #:name 'verification-of-intent
(define params (make-immutable-hash (form-urlencoded->alist (bytes->string/utf-8 body)))) (define params (make-immutable-hash (form-urlencoded->alist (bytes->string/utf-8 body))))
(define callback (hash-ref params 'hub.callback)) (define callback (hash-ref params 'hub.callback))
@ -38,9 +38,7 @@
(define requested-topic (hash-ref params 'hub.topic)) (define requested-topic (hash-ref params 'hub.topic))
(define topic (define topic
(url->string (url->string
(combine-url/relative (string->url (canonical-url canonical-host-name (combine-url/relative (string->url (canonical-url baseurl `("topic" ("" ()))))
cport
`("topic" ("" ()))))
requested-topic))) requested-topic)))
(define requested-lease-seconds (define requested-lease-seconds
(string->number (string->number

46
racketmq/hub/topic-demand.rkt
View File

@ -2,44 +2,32 @@
(require racket/exn) (require racket/exn)
(require racket/set) (require racket/set)
(require racket/string)
(require net/url) (require net/url)
(require/activate syndicate/drivers/web) (require/activate syndicate/drivers/web)
(require/activate "remote-topic.rkt")
(require "../private/util.rkt") (require "../private/util.rkt")
(require "../protocol.rkt") (require "../protocol.rkt")
(actor #:name 'topic-demand-analyzer (actor #:name 'topic-demand-analyzer
(define/query-set local-hosts ($ h (local-host _ _)) h)
(during/actor (topic-demand $full-topic _) (during/actor (topic-demand $full-topic _)
#:name (list 'general-topic full-topic) #:name (list 'topic-demand full-topic)
#:let [(local-hosts-snapshot (local-hosts))]
(with-handlers [(exn? (lambda (e)
(log-error "Topic demand error: ~a" (exn->string e))))]
(match-define (web-resource (web-virtual-host _ topic-host topic-port) topic-path)
(url->resource (string->url full-topic)))
(define maybe-local-topic
(match topic-path [`("topic" (,topic ())) topic] [_ #f]))
(general-topic-main full-topic
topic-host
topic-port
maybe-local-topic
(set-member? local-hosts-snapshot
(local-host topic-host topic-port))))))
(define (general-topic-main full-topic topic-host topic-port maybe-local-topic start-as-local?) (define/query-value topic-baseurl #f (canonical-baseurl $b)
(define (local-state) (canonical-url b `("topic" ("" ()))))
(react (stop-when (retracted (local-host topic-host topic-port))
(remote-state))
(assert (local-topic-demand maybe-local-topic))))
(define (remote-state) (define/dataflow state
(react (stop-when #:when maybe-local-topic (asserted (local-host topic-host topic-port)) (cond
(local-state)) [(not (topic-baseurl)) 'unknown]
(remote-topic-main full-topic))) [(string-prefix? full-topic (topic-baseurl)) 'local]
[else 'remote]))
(on-start (begin/dataflow
(if (and maybe-local-topic start-as-local?) (log-info "Topic-demand for ~s is in state ~s." full-topic (state)))
(local-state)
(remote-state)))) (assert #:when (eq? (state) 'local)
(local-topic-demand (substring full-topic (string-length (topic-baseurl)))))
(assert #:when (eq? (state) 'remote)
(remote-topic-demand full-topic))))

12
racketmq/hub/websocket.rkt
View File

@ -13,21 +13,19 @@
(require "../protocol.rkt") (require "../protocol.rkt")
(actor #:name 'websocket-hub (actor #:name 'websocket-hub
(during (local-host $host-name $port) (during (http-listener $host-name $port)
(during (canonical-local-host $canonical-host-name $cport) (during (canonical-baseurl $baseurl)
(on (web-request-get (id req) (vh host-name port) ("hub" ())) (on (web-request-get (id req) (vh host-name port) ("hub" ()))
(when (equal? (dict-ref (web-request-header-headers req) 'upgrade #f) "websocket") (when (equal? (dict-ref (web-request-header-headers req) 'upgrade #f) "websocket")
(websocket-subscription id req canonical-host-name cport)))))) (websocket-subscription id req baseurl))))))
(define (websocket-subscription id req canonical-host-name cport) (define (websocket-subscription id req baseurl)
(actor* #:name (list 'websocket-subscription id) (actor* #:name (list 'websocket-subscription id)
(define params (web-request-header-query req)) (define params (web-request-header-query req))
(define requested-topic (dict-ref params 'hub.topic)) (define requested-topic (dict-ref params 'hub.topic))
(define topic ;; TODO: abstract this expression out (see also subscription.rkt) (define topic ;; TODO: abstract this expression out (see also subscription.rkt)
(url->string (url->string
(combine-url/relative (string->url (canonical-url canonical-host-name (combine-url/relative (string->url (canonical-url baseurl `("topic" ("" ()))))
cport
`("topic" ("" ()))))
requested-topic))) requested-topic)))
(define poll-interval-seconds (define poll-interval-seconds
(match (dict-ref params (match (dict-ref params

6
racketmq/private/util.rkt
View File

@ -144,5 +144,7 @@
(define (vh host-name port) (web-virtual-host "http" host-name port)) (define (vh host-name port) (web-virtual-host "http" host-name port))
(define (canonical-url canonical-host-name cport path) (define (canonical-url baseurl path)
(url->string (resource->url (web-resource (vh canonical-host-name cport) path)))) (define b (url->resource (string->url baseurl)))
(url->string (resource->url (struct-copy web-resource b
[path (append-url-path (web-resource-path b) path)]))))

16
racketmq/protocol.rkt
View File

@ -8,8 +8,9 @@
(struct-out local-topic-config) (struct-out local-topic-config)
(struct-out topic-demand) (struct-out topic-demand)
(struct-out local-topic-demand) (struct-out local-topic-demand)
(struct-out local-host) (struct-out remote-topic-demand)
(struct-out canonical-local-host)) (struct-out http-listener)
(struct-out canonical-baseurl))
;; A Topic is a URIString. ;; A Topic is a URIString.
@ -53,8 +54,11 @@
;; (local-topic-demand String) ;; (local-topic-demand String)
(struct local-topic-demand (name) #:prefab) ;; ASSERTION (struct local-topic-demand (name) #:prefab) ;; ASSERTION
;; (local-host String Number) ;; (remote-topic-demand Topic)
(struct local-host (name port) #:prefab) ;; ASSERTION (struct remote-topic-demand (topic-name) #:prefab) ;; ASSERTION
;; (canonical-local-host String Number) ;; (http-listener String Number)
(struct canonical-local-host (name port) #:prefab) ;; ASSERTION (struct http-listener (name port) #:prefab) ;; ASSERTION
;; (canonical-baseurl URLString)
(struct canonical-baseurl (string) #:prefab) ;; ASSERTION