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

Migrate ip, port-allocator, udp and tcp to syndicate/actor

This commit is contained in:
Tony Garnock-Jones 2016-07-12 21:02:06 -04:00
parent 04f1c56a5a
commit 09dfaf7d0e
5 changed files with 655 additions and 871 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

301
examples/netstack/ip.rkt
View File

@ -1,29 +1,25 @@
#lang racket/base #lang syndicate/actor
(provide (struct-out ip-packet) (provide (struct-out ip-packet)
ip-address->hostname ip-address->hostname
ip-string->ip-address ip-string->ip-address
apply-netmask apply-netmask
ip-address-in-subnet? ip-address-in-subnet?
gestalt->local-ip-addresses query-local-ip-addresses
observe-local-ip-addresses-gestalt
broadcast-ip-address broadcast-ip-address
spawn-ip-driver) spawn-ip-driver)
(require racket/set) (require racket/set)
(require racket/match)
(require (only-in racket/string string-split)) (require (only-in racket/string string-split))
(require syndicate/monolithic)
(require syndicate/drivers/timer)
(require syndicate/demand-matcher)
(require bitsyntax) (require bitsyntax)
(require "dump-bytes.rkt") (require "dump-bytes.rkt")
(require "configuration.rkt") (require "configuration.rkt")
(require "checksum.rkt") (require "checksum.rkt")
(require "ethernet.rkt")
(require "arp.rkt") (require/activate syndicate/drivers/timer)
(require "on-claim.rkt") (require/activate "ethernet.rkt")
(require/activate "arp.rkt")
(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces (struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
source source
@ -54,182 +50,146 @@
(define broadcast-ip-address (bytes 255 255 255 255)) (define broadcast-ip-address (bytes 255 255 255 255))
(define local-ip-address-projector (host-route (?!) ? ?)) (define (query-local-ip-addresses)
(define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector)) (query-set local-ips (host-route $addr _ _) addr))
(define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-ip-driver) (define (spawn-ip-driver)
(list (actor #:name 'ip-driver
(spawn-demand-matcher (host-route (?!) (?!) (?!)) (react
(route-up (host-route (?!) (?!) (?!))) (during/actor (host-route $my-address $netmask $interface-name)
spawn-host-route) (assert (route-up (host-route my-address netmask interface-name)))
(spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!)) (do-host-route my-address netmask interface-name))
(route-up (gateway-route (?!) (?!) (?!) (?!))) (during/actor (gateway-route $network $netmask $gateway-addr $interface-name)
spawn-gateway-route) (assert (route-up
(spawn-demand-matcher (net-route (?!) (?!) (?!)) (gateway-route $network $netmask $gateway-addr $interface-name)))
(route-up (net-route (?!) (?!) (?!))) (do-gateway-route network netmask gateway-addr interface-name))
spawn-net-route))) (during/actor (net-route $network-addr $netmask $link)
(assert (route-up (net-route network-addr netmask link)))
(do-net-route network-addr netmask link)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Local IP route ;; Local IP route
(define (spawn-host-route my-address netmask interface-name) (define (do-host-route my-address netmask interface-name)
(list (let ((network-addr (apply-netmask my-address netmask)))
(let ((network-addr (apply-netmask my-address netmask))) (do-normal-ip-route (host-route my-address netmask interface-name)
(spawn-normal-ip-route (host-route my-address netmask interface-name) network-addr
network-addr netmask
netmask interface-name))
interface-name))
(spawn (lambda (e s) (assert (advertise (ip-packet _ my-address _ PROTOCOL-ICMP _ _)))
(match e (assert (arp-assertion IPv4-ethertype my-address interface-name))
[(scn (? trie-empty?)) (quit)] (on (message (ip-packet _ $peer-address my-address PROTOCOL-ICMP _ $body))
[(message (ip-packet _ peer-address _ _ _ body)) (bit-string-case body
(bit-string-case body ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum (case type
(case type [(8) ;; ECHO (0 is ECHO-REPLY)
[(8) ;; ECHO (0 is ECHO-REPLY) (log-info "Ping of ~a from ~a"
(log-info "Ping of ~a from ~a" (pretty-bytes my-address)
(pretty-bytes my-address) (pretty-bytes peer-address))
(pretty-bytes peer-address)) (define reply-data0 (bit-string 0
(define reply-data0 (bit-string 0 code
code (0 :: integer bytes 2) ;; TODO
(0 :: integer bytes 2) ;; TODO (rest :: binary)))
(rest :: binary))) (send! (ip-packet #f
(transition s (message (ip-packet #f my-address
my-address peer-address
peer-address PROTOCOL-ICMP
PROTOCOL-ICMP #""
#"" (ip-checksum 2 reply-data0)))]
(ip-checksum 2 reply-data0))))] [else
[else (log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a" type
type code
code checksum
checksum (pretty-bytes my-address)
(pretty-bytes my-address) (pretty-bytes peer-address)
(pretty-bytes peer-address) (dump-bytes->string rest))]))
(dump-bytes->string rest)) (else #f))))
#f]))
(else #f))]
[_ #f]))
(void)
(scn/union (advertisement (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))
(subscription (ip-packet ? ? my-address PROTOCOL-ICMP ? ?))
(assertion (arp-assertion IPv4-ethertype my-address interface-name))
(subscription (host-route my-address netmask interface-name))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gateway IP route ;; Gateway IP route
(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent) (struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
(define (spawn-gateway-route network netmask gateway-addr interface-name) (define (do-gateway-route network netmask gateway-addr interface-name)
(define the-route (gateway-route network netmask gateway-addr interface-name)) (define the-route (gateway-route network netmask gateway-addr interface-name))
(define host-route-projector (host-route (?!) (?!) ?)) (field [routes (set)])
(define gateway-route-projector (gateway-route (?!) (?!) ? ?)) (query-set* routes (host-route $addr $netmask _) (list addr netmask))
(define net-route-projector (net-route (?!) (?!) ?)) (query-set* routes (gateway-route $addr $netmask _ _) (list addr netmask))
(define gateway-arp-projector (arp-query IPv4-ethertype (query-set* routes (net-route $addr $netmask _) (list addr netmask))
gateway-addr
(?! (ethernet-interface interface-name ?))
(?!)))
(define (covered-by-some-other-route? addr routes) (field [gateway-interface #f]
(for/or ([r (in-set routes)]) [gateway-hwaddr #f])
(on (asserted (arp-query IPv4-ethertype
gateway-addr
($ iface (ethernet-interface interface-name _))
$hwaddr))
(when (not (gateway-hwaddr))
(log-info "Discovered gateway ~a at ~a on interface ~a."
(ip-address->hostname gateway-addr)
(ethernet-interface-name iface)
(pretty-bytes hwaddr)))
(gateway-interface iface)
(gateway-hwaddr hwaddr))
(define (covered-by-some-other-route? addr)
(for/or ([r (in-set (routes))])
(match-define (list net msk) r) (match-define (list net msk) r)
(and (positive? msk) (and (positive? msk)
(ip-address-in-subnet? addr net msk)))) (ip-address-in-subnet? addr net msk))))
(spawn (lambda (e s) (on (message ($ p (ip-packet _ _ _ _ _ _)))
(match e (when (not (gateway-interface))
[(scn g) (log-warning "Gateway hwaddr for ~a not known, packet dropped."
(define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector)) (ip-address->hostname gateway-addr)))
(define gw-nets+netmasks (trie-project/set #:take 2 g gateway-route-projector)) (when (and (gateway-interface)
(define net-nets+netmasks (trie-project/set #:take 2 g net-route-projector)) (not (equal? (ip-packet-source-interface p)
(define gw-ip+hwaddr (ethernet-interface-name (gateway-interface))))
(let ((vs (trie-project/set #:take 2 g gateway-arp-projector))) (not (covered-by-some-other-route? (ip-packet-destination p))))
(and vs (not (set-empty? vs)) (set-first vs)))) (send! (ethernet-packet (gateway-interface)
(when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s))) #f
(log-info "Discovered gateway ~a at ~a on interface ~a." (ethernet-interface-hwaddr (gateway-interface))
(ip-address->hostname gateway-addr) (gateway-hwaddr)
(ethernet-interface-name (car gw-ip+hwaddr)) IPv4-ethertype
(pretty-bytes (cadr gw-ip+hwaddr)))) (format-ip-packet p))))))
(if (trie-empty? (project-assertions g (?! the-route)))
(quit)
(transition (gateway-route-state
(set-union host-ips+netmasks
gw-nets+netmasks
net-nets+netmasks)
(and gw-ip+hwaddr (car gw-ip+hwaddr))
(and gw-ip+hwaddr (cadr gw-ip+hwaddr)))
'()))]
[(message (? ip-packet? p))
(define gw-if (gateway-route-state-gateway-interface s))
(when (not gw-if)
(log-warning "Gateway hwaddr for ~a not known, packet dropped."
(ip-address->hostname gateway-addr)))
(and gw-if
(not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if)))
(not (covered-by-some-other-route? (ip-packet-destination p)
(gateway-route-state-routes s)))
(transition s
(message (ethernet-packet gw-if
#f
(ethernet-interface-hwaddr gw-if)
(gateway-route-state-gateway-hwaddr s)
IPv4-ethertype
(format-ip-packet p)))))]
[_ #f]))
(gateway-route-state (set) #f #f)
(scn/union (subscription the-route)
(assertion (route-up the-route))
(subscription (ip-packet ? ? ? ? ? ?))
observe-local-ip-addresses-gestalt
(subscription (net-route ? ? ?))
(subscription (gateway-route ? ? ? ?))
(subscription (projection->pattern gateway-arp-projector)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General net route ;; General net route
(define (spawn-net-route network-addr netmask link) (define (do-net-route network-addr netmask link)
(spawn-normal-ip-route (net-route network-addr netmask link) network-addr netmask link)) (do-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Normal IP route ;; Normal IP route
(define (spawn-normal-ip-route the-route network netmask interface-name) (define (do-normal-ip-route the-route network netmask interface-name)
(spawn (lambda (e s) (assert (arp-interface interface-name))
(match e (on (message (ethernet-packet (ethernet-interface interface-name _) #t _ _ IPv4-ethertype $body))
[(scn (? trie-empty?)) (quit)] (define p (parse-ip-packet interface-name body))
[(message (ethernet-packet _ _ _ _ _ body)) (when p (send! p)))
(define p (parse-ip-packet interface-name body)) (on (message ($ p (ip-packet _ _ _ _ _ _)))
(and p (transition s (message p)))] (define destination (ip-packet-destination p))
[(message (? ip-packet? p)) (when (and (not (equal? (ip-packet-source-interface p) interface-name))
(define destination (ip-packet-destination p)) (ip-address-in-subnet? destination network netmask))
(and (not (equal? (ip-packet-source-interface p) interface-name)) (define timer-id (gensym 'ippkt))
(ip-address-in-subnet? destination network netmask) (react (on-start (send! (set-timer timer-id 5000 'relative)))
(transition (stop-when (message (timer-expired timer-id _))
s (log-warning "ARP lookup of ~a failed, packet dropped"
(lookup-arp destination (ip-address->hostname destination)))
(ethernet-interface interface-name ?) (stop-when (asserted (arp-query IPv4-ethertype
trie-empty destination
(lambda (interface destination-hwaddr) ($ interface (ethernet-interface interface-name _))
(message (ethernet-packet interface $destination-hwaddr))
#f (send! (ethernet-packet interface
(ethernet-interface-hwaddr interface) #f
destination-hwaddr (ethernet-interface-hwaddr interface)
IPv4-ethertype destination-hwaddr
(format-ip-packet p)))))))] IPv4-ethertype
[_ #f])) (format-ip-packet p))))))))
(void)
(scn/union (subscription the-route)
(assertion (route-up the-route))
(subscription (ethernet-packet-pattern interface-name #t IPv4-ethertype))
(assertion (arp-interface interface-name))
(subscription (ip-packet ? ? ? ? ? ?)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -301,27 +261,6 @@
full-packet) full-packet)
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(on-claim #:name (string->symbol (format "lookup-arp:~a" (ip-address->hostname ipaddr)))
(lambda (_g arp-results) (spawn-ip-driver)
(if (not arp-results)
(error 'ip "Someone has published a wildcard arp result")
(and (not (set-empty? arp-results))
(match (set-first arp-results)
[(list interface hwaddr)
(log-info "ARP lookup yielded ~a on ~a for ~a"
(pretty-bytes hwaddr)
(ethernet-interface-name interface)
(ip-address->hostname ipaddr))
(when (> (set-count arp-results) 1)
(log-warning "Ambiguous ARP result for ~a: ~v"
(ip-address->hostname ipaddr)
arp-results))
(k interface hwaddr)]))))
base-gestalt
(arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!))
#:timeout-msec 5000
#:on-timeout (lambda ()
(log-warning "ARP lookup of ~a failed, packet dropped"
(ip-address->hostname ipaddr))
'())))

9
examples/netstack/main.rkt
View File

@ -1,17 +1,14 @@
#lang syndicate/actor #lang syndicate/actor
(require "ip.rkt")
(require "tcp.rkt")
(require "udp.rkt")
;;(log-events-and-actions? #t) ;;(log-events-and-actions? #t)
(require/activate syndicate/drivers/timer) (require/activate syndicate/drivers/timer)
(require/activate "ethernet.rkt") (require/activate "ethernet.rkt")
(require/activate "arp.rkt") (require/activate "arp.rkt")
(spawn-ip-driver) (require/activate "ip.rkt")
(spawn-tcp-driver) (require/activate "tcp.rkt")
(spawn-udp-driver) (require/activate "udp.rkt")
(require/activate "demo-config.rkt") (require/activate "demo-config.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

57
examples/netstack/port-allocator.rkt
View File

@ -1,38 +1,37 @@
#lang racket/base #lang syndicate/actor
;; UDP/TCP port allocator ;; UDP/TCP port allocator
(provide spawn-port-allocator (provide spawn-port-allocator
(struct-out port-allocation-request)) allocate-port!
(struct-out port-allocation-request)
(struct-out port-allocation-reply))
(require racket/set) (require racket/set)
(require racket/match)
(require syndicate/monolithic)
(require "ip.rkt") (require "ip.rkt")
(struct port-allocation-request (type k) #:prefab) (struct port-allocation-request (reqid type) #:prefab)
(struct port-allocation-reply (reqid port) #:prefab)
(struct port-allocator-state (used-ports local-ips) #:transparent) (define (spawn-port-allocator allocator-type query-used-ports)
(actor #:name (list 'port-allocator allocator-type)
(react
(define local-ips (query-local-ip-addresses))
(define used-ports (query-used-ports))
(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports) ;; TODO: How can I get this to run whenever used-ports changes?
(spawn #:name (string->symbol (format "port-allocator:~a" allocator-type)) ;; (log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports)
(lambda (e s)
(match e (on (message (port-allocation-request $reqid allocator-type))
[(scn g) (define currently-used-ports (used-ports))
(define local-ips (or (gestalt->local-ip-addresses g) (set))) (let randomly-allocate-until-unused ()
(define new-used-ports (compute-used-ports g local-ips)) (define p (+ 1024 (random 64512)))
(log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports) (if (set-member? currently-used-ports p)
(transition (port-allocator-state new-used-ports local-ips) '())] (randomly-allocate-until-unused)
[(message (port-allocation-request _ k)) (begin (used-ports (set-add currently-used-ports p))
(define currently-used-ports (port-allocator-state-used-ports s)) (send! (port-allocation-reply reqid p)))))))))
(let randomly-allocate-until-unused ()
(define p (+ 1024 (random 64512))) (define (allocate-port! type)
(if (set-member? currently-used-ports p) (define reqid (gensym 'allocate-port!))
(randomly-allocate-until-unused) (react/suspend (done)
(transition (struct-copy port-allocator-state s (stop-when (message (port-allocation-reply reqid $port)) (done port))
[used-ports (set-add currently-used-ports p)]) (on-start (send! (port-allocation-request reqid type)))))
(k p (port-allocator-state-local-ips s)))))]
[_ #f]))
(port-allocator-state (set) (set))
(scn/union (subscription (port-allocation-request allocator-type ?))
observe-local-ip-addresses-gestalt
observer-gestalt)))

966
examples/netstack/tcp.rkt
View File

File diff suppressed because it is too large Load Diff

193
examples/netstack/udp.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang syndicate/actor
(provide (struct-out udp-remote-address) (provide (struct-out udp-remote-address)
(struct-out udp-handle) (struct-out udp-handle)
@ -9,13 +9,11 @@
spawn-udp-driver) spawn-udp-driver)
(require racket/set) (require racket/set)
(require racket/match)
(require syndicate/monolithic)
(require syndicate/demand-matcher)
(require bitsyntax) (require bitsyntax)
(require "dump-bytes.rkt") (require "dump-bytes.rkt")
(require "checksum.rkt") (require "checksum.rkt")
(require "configuration.rkt")
(require "ip.rkt") (require "ip.rkt")
(require "port-allocator.rkt") (require "port-allocator.rkt")
@ -45,77 +43,52 @@
(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab) (struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab)
(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress) (struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress)
(define any-remote (udp-remote-address ? ?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User-accessible driver startup ;; User-accessible driver startup
(define (spawn-udp-driver) (define (spawn-udp-driver)
(list (spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
(spawn-demand-matcher (observe (udp-packet ? (?! (udp-listener ?)) ?)) (spawn-kernel-udp-driver)
(advertise (udp-packet ? (?! (udp-listener ?)) ?)) (actor #:name 'udp-driver
(lambda (handle) (spawn-udp-relay (udp-listener-port handle) handle))) (react (on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
(spawn-demand-matcher (observe (udp-packet ? (?! (udp-handle ?)) ?)) (spawn-udp-relay (udp-listener-port h) h))
(advertise (udp-packet ? (?! (udp-handle ?)) ?)) (on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
(lambda (handle) (actor #:name (list 'udp-transient h)
(message (port-allocation-request (spawn-udp-relay (allocate-port! 'udp) h))))))
'udp
(lambda (port local-ips) (spawn-udp-relay port handle))))))
(spawn-udp-port-allocator)
(spawn-kernel-udp-driver)))
(define (spawn-udp-port-allocator)
(define udp-projector (udp-port-allocation (?!) ?))
(spawn-port-allocator 'udp
(subscription (projection->pattern udp-projector))
(lambda (g local-ips)
(project-assertions g udp-projector))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relaying ;; Relaying
(define (spawn-udp-relay local-port local-user-addr) (define (spawn-udp-relay local-port local-user-addr)
(log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr) (actor #:name (list 'udp-relay local-port local-user-addr)
(log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr)
(define local-peer-detector (?! (observe (udp-packet any-remote local-user-addr ?)))) (define any-remote (udp-remote-address ? ?))
(define (compute-gestalt local-ips) (react (stop-when (retracted (observe (udp-packet any-remote local-user-addr _))))
(for/fold [(g (assertion-set-union (assert (advertise (udp-packet any-remote local-user-addr _)))
(subscription (projection->pattern local-peer-detector)) (assert (udp-port-allocation local-port local-user-addr))
(advertisement (udp-packet any-remote local-user-addr ?))
observe-local-ip-addresses-gestalt
(subscription (udp-packet local-user-addr any-remote ?))
(assertion (udp-port-allocation local-port local-user-addr))))]
[(ip (in-set local-ips))]
(assertion-set-union g
(subscription (udp-datagram ? ? ip local-port ?))
(advertisement (udp-datagram ip local-port ? ? ?)))))
(spawn (lambda (e local-ips) (during (host-route $ip _ _)
(match e (assert (advertise (udp-datagram ip local-port _ _ _)))
[(scn g) (on (message (udp-datagram $source-ip $source-port ip local-port $bs))
(define new-local-ips (gestalt->local-ip-addresses g)) (send!
(if (trie-empty? (trie-project g local-peer-detector)) (udp-packet (udp-remote-address (ip-address->hostname source-ip)
(quit) source-port)
(transition new-local-ips (scn (compute-gestalt new-local-ips))))] local-user-addr
[(message (udp-packet (== local-user-addr) remote-addr bs)) bs))))
;; Choose arbitrary local IP address for outbound packet!
;; TODO: what can be done? Must I examine the routing table? (define local-ips (query-local-ip-addresses))
(match-define (udp-remote-address remote-host remote-port) remote-addr) (on (message (udp-packet local-user-addr ($ remote-addr any-remote) $bs))
(define remote-ip (ip-string->ip-address remote-host)) ;; Choose arbitrary local IP address for outbound packet!
(transition local-ips (message (udp-datagram (set-first local-ips) ;; TODO: what can be done? Must I examine the routing table?
local-port (match-define (udp-remote-address remote-host remote-port) remote-addr)
remote-ip (define remote-ip (ip-string->ip-address remote-host))
remote-port (send! (udp-datagram (set-first (local-ips))
bs)))] local-port
[(message (udp-datagram si sp _ _ bs)) remote-ip
(transition local-ips remote-port
(message (udp-packet (udp-remote-address (ip-address->hostname si) sp) bs))))))
local-user-addr
bs)))]
[_ #f]))
(set)
(scn (compute-gestalt (set)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Codec & kernel-level driver ;; Codec & kernel-level driver
@ -123,53 +96,47 @@
(define PROTOCOL-UDP 17) (define PROTOCOL-UDP 17)
(define (spawn-kernel-udp-driver) (define (spawn-kernel-udp-driver)
(spawn (lambda (e local-ips) (actor #:name 'kernel-udp-driver
(match e (forever
[(scn g) (assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
(transition (gestalt->local-ip-addresses g) '())]
[(message (ip-packet source-if src-ip dst-ip _ _ body)) (define local-ips (query-local-ip-addresses))
#:when (and source-if (set-member? local-ips dst-ip))
(bit-string-case body (on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
([ (src-port :: integer bytes 2) (when (and source-if (set-member? (local-ips) dst-ip))
(dst-port :: integer bytes 2) (bit-string-case body
(length :: integer bytes 2) ([ (src-port :: integer bytes 2)
(checksum :: integer bytes 2) ;; TODO: check checksum (dst-port :: integer bytes 2)
(data :: binary) ] (length :: integer bytes 2)
(bit-string-case data (checksum :: integer bytes 2) ;; TODO: check checksum
([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes (data :: binary) ]
(:: binary) ] (bit-string-case data
(transition local-ips (message (udp-datagram src-ip ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
src-port (:: binary) ]
dst-ip (send! (udp-datagram src-ip src-port dst-ip dst-port
dst-port (bit-string->bytes payload))))
(bit-string->bytes payload))))) (else #f)))
(else #f))) (else #f))))
(else #f))]
[(message (udp-datagram src-ip src-port dst-ip dst-port bs)) (on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
#:when (set-member? local-ips src-ip) (when (set-member? (local-ips) src-ip)
(let* ((payload (bit-string (src-port :: integer bytes 2) (let* ((payload (bit-string (src-port :: integer bytes 2)
(dst-port :: integer bytes 2) (dst-port :: integer bytes 2)
((+ 8 (bit-string-byte-count bs)) ((+ 8 (bit-string-byte-count bs))
:: integer bytes 2) :: integer bytes 2)
(0 :: integer bytes 2) ;; checksum location (0 :: integer bytes 2) ;; checksum location
(bs :: binary))) (bs :: binary)))
(pseudo-header (bit-string (src-ip :: binary bytes 4) (pseudo-header (bit-string (src-ip :: binary bytes 4)
(dst-ip :: binary bytes 4) (dst-ip :: binary bytes 4)
0 0
PROTOCOL-UDP PROTOCOL-UDP
((bit-string-byte-count payload) ((bit-string-byte-count payload)
:: integer bytes 2))) :: integer bytes 2)))
(checksummed-payload (ip-checksum #:pseudo-header pseudo-header (checksummed-payload (ip-checksum #:pseudo-header pseudo-header
6 payload))) 6 payload)))
(transition local-ips (message (ip-packet #f (send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
src-ip checksummed-payload))))))))
dst-ip
PROTOCOL-UDP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#""
checksummed-payload))))] (spawn-udp-driver)
[_ #f]))
(set)
(scn/union (advertisement (ip-packet #f ? ? PROTOCOL-UDP ? ?))
(subscription (ip-packet ? ? ? PROTOCOL-UDP ? ?))
(subscription (udp-datagram ? ? ? ? ?))
observe-local-ip-addresses-gestalt)))