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

actorise the relay

This commit is contained in:
Tony Garnock-Jones 2014-06-27 16:26:46 -04:00
parent edfb1a9250
commit 9af8adee79
1 changed files with 37 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
minimart/relay.rkt
View File

@ -42,63 +42,48 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Connections ;; Connections
(struct connection-state (client-id tunnelled-gestalt) #:transparent)
(define (ping-interval) (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8)))) (define (ping-interval) (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8))))
(define (spawn-connection-handler c server-id) (define (spawn-connection-handler c server-id)
(define (send-event e s) (actor #:name relay
(send (websocket-message server-id #:state [tunnelled-gestalt (gestalt-empty)]
(connection-state-client-id s)
(jsexpr->string (lift-json-event e))) (send #:meta-level 1 (set-timer c (ping-interval) 'relative))
#:meta-level 1)) (subscribe (timer-expired c ?)
(define ((handle-connection-routing-change g) s) #:meta-level 1
(if (gestalt-empty? g) (send #:meta-level 1 (set-timer c (ping-interval) 'relative))
(transition s (quit)) ;; websocket connection closed (send-event 'ping))
#f))
(define ((handle-tunnelled-routing-change g) s) (observe-advertisers (websocket-message c server-id ?)
(transition s (send-event (routing-update g) s))) #:meta-level 1
(define ((handle-tunnellable-message m) s) #:presence peer-connected?
(if (gestalt-accepts? (connection-state-tunnelled-gestalt s) m) (when (not peer-connected?) (quit)))
(transition s (send-event m s))
(transition s '()))) (advertise (websocket-message server-id c ?) #:meta-level 1)
(define relay-connections (subscribe (websocket-message c server-id ($ data))
(gestalt-union (sub (timer-expired c ?) #:meta-level 1) #:meta-level 1
(sub (websocket-message c server-id ?) #:meta-level 1) #:run-transition (handle-incoming (drop-json-action (string->jsexpr data))))
(sub (websocket-message c server-id ?) #:meta-level 1 #:level 1)
(pub (websocket-message server-id c ?) #:meta-level 1))) (define (handle-incoming data)
(define (connection-handler e s) (match data
(match e
[(routing-update g)
(sequence-transitions
(transition s '())
(handle-connection-routing-change (gestalt-filter g relay-connections))
(handle-tunnelled-routing-change
(gestalt-filter g (connection-state-tunnelled-gestalt s))))]
[(? message? m)
(sequence-transitions
(match m
[(message (websocket-message from to data) 1 #f)
(match (drop-json-action (string->jsexpr data))
[(routing-update g-unfiltered) [(routing-update g-unfiltered)
(define g (gestalt-transform g-unfiltered (define g (gestalt-transform g-unfiltered
(lambda (ml l p) (if (zero? ml) p '(#f . #f))))) (lambda (ml l p) (if (zero? ml) p '(#f . #f)))))
(transition (struct-copy connection-state s [tunnelled-gestalt g]) (begin-transition
(routing-update (gestalt-union g relay-connections)))] #:update [tunnelled-gestalt g]
#:update-routes)]
[(? message? m) [(? message? m)
(transition s (if (zero? (message-meta-level m)) m '()))] (begin-transition
(when (zero? (message-meta-level m)) m))]
['ping ['ping
(transition s (send-event 'pong s))] (begin-transition (send-event 'pong))]
['pong ['pong
(transition s '())])] (begin-transition)]))
[(message (timer-expired _ _) 1 #f)
(transition s (list (send (set-timer c (ping-interval) 'relative) #:meta-level 1) (observe-gestalt tunnelled-gestalt
(send-event 'ping s)))] [event ;; routing-update or message, prefiltered by tunnelled-gestalt
[_ (send-event event)])
(transition s '())])
(handle-tunnellable-message m))] (define (send-event e)
[#f #f])) (send #:meta-level 1
(list (send (set-timer c (ping-interval) 'relative) #:meta-level 1) (websocket-message server-id c (jsexpr->string (lift-json-event e)))))))
(spawn connection-handler
(connection-state c (gestalt-empty))
relay-connections)))