Name process behaviour procedures.
This commit is contained in:
parent
0db231575c
commit
a86eb10494
3
ip.rkt
3
ip.rkt
|
@ -301,7 +301,8 @@
|
||||||
full-packet)
|
full-packet)
|
||||||
|
|
||||||
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
|
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
|
||||||
(on-claim (lambda (_g arp-results)
|
(on-claim #:name (string->symbol (format "lookup-arp:~a" (ip-address->hostname ipaddr)))
|
||||||
|
(lambda (_g arp-results)
|
||||||
(if (not arp-results)
|
(if (not arp-results)
|
||||||
(error 'ip "Someone has published a wildcard arp result")
|
(error 'ip "Someone has published a wildcard arp result")
|
||||||
(and (not (set-empty? arp-results))
|
(and (not (set-empty? arp-results))
|
||||||
|
|
|
@ -14,7 +14,8 @@
|
||||||
(struct port-allocator-state (used-ports local-ips) #:transparent)
|
(struct port-allocator-state (used-ports local-ips) #:transparent)
|
||||||
|
|
||||||
(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports)
|
(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports)
|
||||||
(spawn (lambda (e s)
|
(spawn #:name (string->symbol (format "port-allocator:~a" allocator-type))
|
||||||
|
(lambda (e s)
|
||||||
(match e
|
(match e
|
||||||
[(scn g)
|
[(scn g)
|
||||||
(define local-ips (or (gestalt->local-ip-addresses g) (set)))
|
(define local-ips (or (gestalt->local-ip-addresses g) (set)))
|
||||||
|
|
28
tcp.rkt
28
tcp.rkt
|
@ -51,16 +51,20 @@
|
||||||
;; User-accessible driver startup
|
;; User-accessible driver startup
|
||||||
|
|
||||||
(define (spawn-tcp-driver)
|
(define (spawn-tcp-driver)
|
||||||
(list (spawn-demand-matcher (advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?)))
|
(list (spawn-demand-matcher #:name 'tcp-inbound-driver
|
||||||
|
(advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?)))
|
||||||
(advertise (advertise (tcp-channel ? (?! (tcp-listener ?)) ?)))
|
(advertise (advertise (tcp-channel ? (?! (tcp-listener ?)) ?)))
|
||||||
(lambda (server-addr)
|
(lambda (server-addr)
|
||||||
(match-define (tcp-listener port) server-addr)
|
(match-define (tcp-listener port) server-addr)
|
||||||
;; TODO: have listener shut down once user-level listener does
|
;; TODO: have listener shut down once user-level listener does
|
||||||
(list
|
(list
|
||||||
(spawn (lambda (e s) #f)
|
(spawn #:name (string->symbol
|
||||||
|
(format "tcp-listener-port-reservation:~a" port))
|
||||||
|
(lambda (e s) #f)
|
||||||
(void)
|
(void)
|
||||||
(scn (assertion (tcp-port-allocation port server-addr))))
|
(scn (assertion (tcp-port-allocation port server-addr))))
|
||||||
(spawn-demand-matcher
|
(spawn-demand-matcher
|
||||||
|
#:name (string->symbol (format "tcp-listener:~a" port))
|
||||||
(advertise (tcp-channel (?! (tcp-address ? ?))
|
(advertise (tcp-channel (?! (tcp-address ? ?))
|
||||||
(?! (tcp-address ? port))
|
(?! (tcp-address ? port))
|
||||||
?))
|
?))
|
||||||
|
@ -68,7 +72,8 @@
|
||||||
(?! (tcp-address ? port))
|
(?! (tcp-address ? port))
|
||||||
?))
|
?))
|
||||||
(spawn-relay server-addr)))))
|
(spawn-relay server-addr)))))
|
||||||
(spawn-demand-matcher (advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
|
(spawn-demand-matcher #:name 'tcp-outbound-driver
|
||||||
|
(advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
|
||||||
(observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
|
(observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
|
||||||
allocate-port-and-spawn-socket)
|
allocate-port-and-spawn-socket)
|
||||||
(spawn-tcp-port-allocator)
|
(spawn-tcp-port-allocator)
|
||||||
|
@ -116,7 +121,11 @@
|
||||||
(define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
|
(define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
|
||||||
(list
|
(list
|
||||||
(message (set-timer timer-name relay-peer-wait-time-msec 'relative))
|
(message (set-timer timer-name relay-peer-wait-time-msec 'relative))
|
||||||
(spawn (lambda (e state)
|
(spawn #:name (string->symbol (format "tcp-relay:~v:~v:~v"
|
||||||
|
local-user-addr
|
||||||
|
remote-addr
|
||||||
|
local-tcp-addr))
|
||||||
|
(lambda (e state)
|
||||||
(match e
|
(match e
|
||||||
[(scn g)
|
[(scn g)
|
||||||
(define local-peer-absent?
|
(define local-peer-absent?
|
||||||
|
@ -287,7 +296,8 @@
|
||||||
(transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
(transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
||||||
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
||||||
|
|
||||||
(spawn (lambda (e s)
|
(spawn #:name 'kernel-tcp-driver
|
||||||
|
(lambda (e s)
|
||||||
(match e
|
(match e
|
||||||
[(scn g)
|
[(scn g)
|
||||||
(analyze-gestalt g s)]
|
(analyze-gestalt g s)]
|
||||||
|
@ -612,6 +622,12 @@
|
||||||
(current-inexact-milliseconds)
|
(current-inexact-milliseconds)
|
||||||
#f
|
#f
|
||||||
#f)))
|
#f)))
|
||||||
(spawn state-vector-behavior
|
(spawn #:name
|
||||||
|
(string->symbol (format "tcp-state-vector:~a:~a:~a:~a"
|
||||||
|
(ip-address->hostname src-ip)
|
||||||
|
src-port
|
||||||
|
(ip-address->hostname dst-ip)
|
||||||
|
dst-port))
|
||||||
|
state-vector-behavior
|
||||||
state0
|
state0
|
||||||
(scn (compute-gestalt state0))))))
|
(scn (compute-gestalt state0))))))
|
||||||
|
|
Loading…
Reference in New Issue