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

Generalize port-allocator

This commit is contained in:
Tony Garnock-Jones 2014-06-19 22:16:53 -04:00
parent d063b3b2fb
commit 90c8e8555b
2 changed files with 18 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
port-allocator.rkt
View File

@ -13,20 +13,12 @@
(struct port-allocator-state (used-ports local-ips) #:transparent)
(define (spawn-port-allocator allocator-type port-projections)
(define (spawn-port-allocator allocator-type projections compute-used-ports)
(spawn (lambda (e s)
(match e
[(routing-update g)
(define local-ips (or (gestalt->local-ip-addresses g) (set)))
(define extracted-ips+ports
(apply set-union
(set)
(map (lambda (p) (or (gestalt-project/keys g p) (set))) port-projections)))
(define new-used-ports (for/fold [(s (set))] [(e (in-set extracted-ips+ports))]
(match-define (list hostname port) e)
(if (set-member? local-ips (ip-string->ip-address hostname))
(set-add s port)
s)))
(define new-used-ports (compute-used-ports g local-ips))
(log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports)
(transition (port-allocator-state new-used-ports local-ips) '())]
[(message (port-allocation-request _ k) _ _)
@ -43,4 +35,4 @@
(apply gestalt-union
(sub (port-allocation-request allocator-type ?))
observe-local-ip-addresses-gestalt
(map projection->gestalt port-projections))))
(map projection->gestalt projections))))

19
tcp.rkt
View File

@ -54,19 +54,31 @@
#:supply-level 2
(lambda (server-addr)
(match-define (tcp-listener port) server-addr)
;; TODO: have listener shut down once user-level listener does
(spawn-demand-matcher
(tcp-channel (?! (tcp-address ? ?)) (?! (tcp-address ? port)) ?)
(spawn-relay server-addr))))
(spawn-demand-matcher (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)
allocate-port-and-spawn-socket)
(spawn-port-allocator 'tcp
(list (project-subs (tcp-channel (tcp-address (?!) (?!)) ? ?))
(project-subs (tcp-channel ? (tcp-address (?!) (?!)) ?))))
(spawn-tcp-port-allocator)
(spawn-kernel-tcp-driver)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Port allocation
(define (spawn-tcp-port-allocator)
(define project-active-connections (project-pubs (tcp-packet #f (?!) (?!) ? ? ? ? ? ? ? ?)))
(define project-listeners (project-subs #:level 1 (tcp-channel ? (tcp-listener (?!)) ?)))
(spawn-port-allocator 'tcp
(list project-active-connections project-listeners)
(lambda (g local-ips)
(define listener-ports (gestalt-project/single g project-listeners))
(define active-connection-ports
(for/set [(e (gestalt-project/keys g project-active-connections))
#:when (set-member? local-ips (car e))]
(cadr e)))
(set-union listener-ports active-connection-ports))))
(define (allocate-port-and-spawn-socket local-addr remote-addr)
(send (port-allocation-request
'tcp
@ -273,7 +285,6 @@
(gestalt-union (pub (ip-packet #f ? ? PROTOCOL-TCP ? ?))
(sub (ip-packet ? ? ? PROTOCOL-TCP ? ?))
(sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?))
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?))
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) #:level 1)
observe-local-ip-addresses-gestalt)))