(Less im)Proper routing.
This commit is contained in:
Tony Garnock-Jones
parent
25c970902d
commit
e76fa1527c
104
arp.rkt
104
arp.rkt
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
(provide (struct-out arp-query)
|
||||
(struct-out arp-assertion)
|
||||
(struct-out arp-interface)
|
||||
spawn-arp-driver)
|
||||
|
||||
(require racket/set)
|
||||
|
|
@ -14,10 +15,12 @@
|
|||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require "ethernet.rkt")
|
||||
|
||||
(struct arp-query (protocol protocol-address hardware-address) #:prefab)
|
||||
(struct arp-assertion (protocol protocol-address) #:prefab)
|
||||
(struct arp-query (protocol protocol-address interface link-address) #:prefab)
|
||||
(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
|
||||
(struct arp-interface (interface-name) #:prefab)
|
||||
|
||||
(define ARP-ethertype #x0806)
|
||||
(define cache-entry-lifetime-msec (* 14400 1000))
|
||||
|
|
@ -25,12 +28,31 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-arp-driver)
|
||||
(spawn-demand-matcher (arp-interface (?!))
|
||||
#:supply-level 1
|
||||
spawn-arp-interface))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct cache-key (protocol address) #:transparent)
|
||||
(struct cache-value (expiry address) #:transparent)
|
||||
(struct cache-value (expiry interface address) #:transparent)
|
||||
|
||||
(struct state (hwaddr cache queries assertions) #:transparent)
|
||||
(struct state (cache queries assertions) #:transparent)
|
||||
|
||||
(define (spawn-arp-interface interface-name)
|
||||
(log-info "spawn-arp-interface ~v" interface-name)
|
||||
(lookup-ethernet-hwaddr (gestalt-for-supply interface-name)
|
||||
interface-name
|
||||
(lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr))))
|
||||
|
||||
(define (gestalt-for-supply interface-name)
|
||||
(sub (arp-interface interface-name) #:level 1))
|
||||
|
||||
(define (spawn-arp-interface* interface-name hwaddr)
|
||||
(log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr)
|
||||
(define interface (ethernet-interface interface-name hwaddr))
|
||||
|
||||
(define (spawn-arp-driver interface-name)
|
||||
(define (expire-cache cache)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(define (not-expired? v) (< now (cache-value-expiry v)))
|
||||
|
|
@ -47,11 +69,13 @@
|
|||
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype))
|
||||
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype) #:level 1)
|
||||
(pub (ethernet-packet-pattern interface-name #f ARP-ethertype))
|
||||
(sub (arp-assertion ? ?) #:level 1)
|
||||
(pub (arp-query ? ? ?) #:level 2)
|
||||
(gestalt-for-supply interface-name)
|
||||
(sub (arp-assertion ? ? interface-name) #:level 1)
|
||||
(pub (arp-query ? ? interface ?) #:level 2)
|
||||
(for/fold [(g (gestalt-empty))] [((k v) (in-hash cache))]
|
||||
(gestalt-union g (pub (arp-query (cache-key-protocol k)
|
||||
(cache-key-address k)
|
||||
(cache-value-interface v)
|
||||
(cache-value-address v)))))))
|
||||
|
||||
(define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
|
||||
|
|
@ -67,9 +91,9 @@
|
|||
(sender-pa :: binary bytes plen)
|
||||
(target-ha :: binary bytes hlen)
|
||||
(target-pa :: binary bytes plen))))
|
||||
(ethernet-packet (ethernet-interface interface-name (state-hwaddr s))
|
||||
(ethernet-packet interface
|
||||
#f
|
||||
(state-hwaddr s)
|
||||
hwaddr
|
||||
dest-mac
|
||||
ARP-ethertype
|
||||
packet))
|
||||
|
|
@ -84,15 +108,24 @@
|
|||
(sender-hardware-address0 :: binary bytes hlen)
|
||||
(sender-protocol-address0 :: binary bytes plen)
|
||||
(target-hardware-address0 :: binary bytes hlen)
|
||||
(target-protocol-address0 :: binary bytes plen) ]
|
||||
(target-protocol-address0 :: binary bytes plen)
|
||||
(:: binary) ;; TODO: are the extra zeros coming from the
|
||||
;; router real, or an artifact of my
|
||||
;; packet-capture implementation?
|
||||
]
|
||||
(let ()
|
||||
(define sender-protocol-address (bit-string->bytes sender-protocol-address0))
|
||||
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
|
||||
(define target-protocol-address (bit-string->bytes target-protocol-address0))
|
||||
;; (log-info "~a ARP Adding ~a = ~a to cache"
|
||||
;; interface-name
|
||||
;; (pretty-bytes sender-protocol-address)
|
||||
;; (pretty-bytes sender-hardware-address))
|
||||
(define cache (hash-set (expire-cache (state-cache s))
|
||||
(cache-key ptype sender-protocol-address)
|
||||
(cache-value (+ (current-inexact-milliseconds)
|
||||
cache-entry-lifetime-msec)
|
||||
interface
|
||||
sender-hardware-address)))
|
||||
(transition (struct-copy state s
|
||||
[cache cache])
|
||||
|
|
@ -105,7 +138,7 @@
|
|||
sender-hardware-address
|
||||
ptype
|
||||
2 ;; reply
|
||||
(state-hwaddr s)
|
||||
hwaddr
|
||||
target-protocol-address
|
||||
sender-hardware-address
|
||||
sender-protocol-address))
|
||||
|
|
@ -115,29 +148,25 @@
|
|||
(routing-update (compute-gestalt cache))))))
|
||||
(else #f)))
|
||||
|
||||
(define queries-projection (compile-gestalt-projection (arp-query (?!) (?!) ?)))
|
||||
(define queries-projection (project-subs #:level 1 (arp-query (?!) (?!) ? ?)))
|
||||
(define (gestalt->queries g)
|
||||
(for/set [(e (in-set (matcher-key-set (gestalt-project g 0 1 #f queries-projection))))]
|
||||
(for/set [(e (in-set (gestalt-project/keys g queries-projection)))]
|
||||
(match-define (list ptype pa) e)
|
||||
(cache-key ptype pa)))
|
||||
|
||||
(define assertions-projection (compile-gestalt-projection (arp-assertion (?!) (?!))))
|
||||
(define assertions-projection (project-pubs (arp-assertion (?!) (?!) ?)))
|
||||
(define (gestalt->assertions g)
|
||||
(for/set [(e (matcher-key-set (gestalt-project g 0 0 #t assertions-projection)))]
|
||||
(for/set [(e (in-set (gestalt-project/keys g assertions-projection)))]
|
||||
(match-define (list ptype pa) e)
|
||||
(cache-key ptype pa)))
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
||||
(define new-queries (gestalt->queries g))
|
||||
(define new-assertions (gestalt->assertions g))
|
||||
(define added-queries (set-subtract new-queries (state-queries s)))
|
||||
(define added-assertions (set-subtract new-assertions (state-assertions s)))
|
||||
(define unanswered-queries (set-subtract added-queries (list->set (hash-keys (state-cache s)))))
|
||||
(define new-s (struct-copy state s
|
||||
[hwaddr hwaddr]
|
||||
[queries new-queries]
|
||||
[assertions (if hwaddr new-assertions (state-assertions s))]))
|
||||
(define new-s (struct-copy state s [queries new-queries] [assertions new-assertions]))
|
||||
(define (some-asserted-pa ptype)
|
||||
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype))
|
||||
(set->list new-assertions))
|
||||
|
|
@ -152,9 +181,12 @@
|
|||
;; (log-info "analyze-gestalt: new-s ~v" new-s)
|
||||
(transition new-s
|
||||
(list
|
||||
(when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name)))
|
||||
(quit))
|
||||
(for/list [(q (in-set unanswered-queries))]
|
||||
(define pa (some-asserted-pa (cache-key-protocol q)))
|
||||
(log-info "Asking for ~a from ~a"
|
||||
(log-info "~a ARP Asking for ~a from ~a"
|
||||
interface-name
|
||||
(pretty-bytes (cache-key-address q))
|
||||
(and pa (pretty-bytes pa)))
|
||||
(if pa
|
||||
|
|
@ -167,23 +199,23 @@
|
|||
zero-ethernet-address
|
||||
(cache-key-address q)))
|
||||
'()))
|
||||
(when hwaddr ;; don't announce until we know our own hwaddr
|
||||
(for/list [(a (in-set added-assertions))]
|
||||
(log-info "Announcing ~a as ~a"
|
||||
(pretty-bytes (cache-key-address a))
|
||||
(pretty-bytes hwaddr))
|
||||
(send (build-packet new-s
|
||||
broadcast-ethernet-address
|
||||
(cache-key-protocol a)
|
||||
2 ;; reply -- gratuitous announcement
|
||||
hwaddr
|
||||
(cache-key-address a)
|
||||
hwaddr
|
||||
(cache-key-address a))))))))
|
||||
(for/list [(a (in-set added-assertions))]
|
||||
(log-info "~a ARP Announcing ~a as ~a"
|
||||
interface-name
|
||||
(pretty-bytes (cache-key-address a))
|
||||
(pretty-bytes hwaddr))
|
||||
(send (build-packet new-s
|
||||
broadcast-ethernet-address
|
||||
(cache-key-protocol a)
|
||||
2 ;; reply -- gratuitous announcement
|
||||
hwaddr
|
||||
(cache-key-address a)
|
||||
hwaddr
|
||||
(cache-key-address a)))))))
|
||||
|
||||
(list (set-wakeup-alarm)
|
||||
(spawn (lambda (e s)
|
||||
;; (log-info "ARP: ~v // ~v" e s)
|
||||
;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(analyze-gestalt g s)]
|
||||
|
|
@ -196,5 +228,5 @@
|
|||
(list (set-wakeup-alarm)
|
||||
(routing-update (compute-gestalt (state-cache new-s)))))]
|
||||
[_ #f]))
|
||||
(state #f (hash) (set) (set))
|
||||
(state (hash) (set) (set))
|
||||
(compute-gestalt (hash)))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out ethernet-interface)
|
||||
(struct-out host-route)
|
||||
(struct-out net-route))
|
||||
|
||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||
|
||||
;; A Route is one of
|
||||
;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
|
||||
;; - (net-route NetAddrBytes NetmaskNat IpAddrBytes), a gateway route for a subnet
|
||||
;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
|
||||
;; NetmaskNat in a net-route is a default route.
|
||||
(struct host-route (ip-addr netmask interface-name) #:prefab)
|
||||
(struct net-route (network-addr netmask link) #:prefab)
|
||||
29
ethernet.rkt
29
ethernet.rkt
|
|
@ -1,14 +1,15 @@
|
|||
#lang racket/base
|
||||
;; Ethernet driver
|
||||
|
||||
(provide (struct-out ethernet-interface)
|
||||
(struct-out ethernet-packet)
|
||||
(provide (struct-out ethernet-packet)
|
||||
zero-ethernet-address
|
||||
broadcast-ethernet-address
|
||||
interface-names
|
||||
spawn-ethernet-driver
|
||||
ethernet-hwaddr-projection
|
||||
gestalt->hwaddr
|
||||
ethernet-packet-pattern)
|
||||
ethernet-packet-pattern
|
||||
lookup-ethernet-hwaddr)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
|
@ -20,9 +21,9 @@
|
|||
(require packet-socket)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "configuration.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
|
||||
|
||||
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
||||
|
|
@ -50,6 +51,7 @@
|
|||
(spawn (lambda (e h)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
|
||||
(if (gestalt-empty? g)
|
||||
(begin (async-channel-put control-ch 'quit)
|
||||
(transition #f (quit)))
|
||||
|
|
@ -118,12 +120,11 @@
|
|||
(ethertype :: integer bytes 2)
|
||||
(body :: binary))))
|
||||
|
||||
(define (hwaddr-projection interface-name)
|
||||
(compile-gestalt-projection (ethernet-packet (ethernet-interface interface-name (?!)) ? ? ? ? ?)))
|
||||
(define (ethernet-hwaddr-projection interface-name)
|
||||
(project-pubs (ethernet-packet (ethernet-interface interface-name (?!)) #t ? ? ? ?)))
|
||||
|
||||
(define (gestalt->hwaddr g interface-name)
|
||||
(define hwaddrs
|
||||
(matcher-key-set/single (gestalt-project g 0 0 #t (hwaddr-projection interface-name))))
|
||||
(define hwaddrs (gestalt-project/single g (ethernet-hwaddr-projection interface-name)))
|
||||
(case (set-count hwaddrs)
|
||||
[(0) #f]
|
||||
[(1) (set-first hwaddrs)]
|
||||
|
|
@ -133,3 +134,15 @@
|
|||
|
||||
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
|
||||
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
|
||||
|
||||
(define (lookup-ethernet-hwaddr base-gestalt interface-name k)
|
||||
(on-gestalt #:timeout-msec 5000
|
||||
#:on-timeout (lambda ()
|
||||
(log-info "Lookup of ethernet interface ~v failed" interface-name)
|
||||
'())
|
||||
(lambda (_g hwaddrss)
|
||||
(and (not (set-empty? hwaddrss))
|
||||
(let ((hwaddr (car (set-first hwaddrss))))
|
||||
(k hwaddr))))
|
||||
base-gestalt
|
||||
(ethernet-hwaddr-projection interface-name)))
|
||||
|
|
|
|||
446
ip.rkt
446
ip.rkt
|
|
@ -1,8 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out ip-packet)
|
||||
(struct-out ip-interface)
|
||||
ip-address->hostname
|
||||
apply-netmask
|
||||
ip-address-in-subnet?
|
||||
gestalt->local-ip-addresses
|
||||
observe-local-ip-addresses-gestalt
|
||||
broadcast-ip-address
|
||||
spawn-ip-driver)
|
||||
|
||||
|
|
@ -14,12 +17,208 @@
|
|||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require "checksum.rkt")
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
|
||||
(struct ip-packet (source destination protocol options body) #:prefab) ;; TODO: more fields
|
||||
(struct ip-interface (address ethernet) #:prefab)
|
||||
(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
|
||||
source
|
||||
destination
|
||||
protocol
|
||||
options
|
||||
body)
|
||||
#:prefab) ;; TODO: more fields
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ip-address->hostname bs)
|
||||
(bit-string-case bs
|
||||
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||
|
||||
(define (apply-netmask addr netmask)
|
||||
(bit-string-case addr
|
||||
([ (n :: integer bytes 4) ]
|
||||
(bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask)))
|
||||
:: integer bytes 4)))))
|
||||
|
||||
(define (ip-address-in-subnet? addr network netmask)
|
||||
(equal? (apply-netmask network netmask)
|
||||
(apply-netmask addr netmask)))
|
||||
|
||||
(define broadcast-ip-address (bytes 255 255 255 255))
|
||||
|
||||
(define local-ip-address-projector (project-pubs (host-route (?!) ? ?)))
|
||||
(define (gestalt->local-ip-addresses g) (gestalt-project/single g local-ip-address-projector))
|
||||
(define observe-local-ip-addresses-gestalt (sub (host-route ? ? ?) #:level 2))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-ip-driver)
|
||||
(list
|
||||
(spawn-demand-matcher (host-route (?!) (?!) (?!))
|
||||
#:supply-level 1
|
||||
spawn-host-route)
|
||||
(spawn-demand-matcher (net-route (?!) (?!) (?!))
|
||||
#:supply-level 1
|
||||
spawn-net-route)))
|
||||
|
||||
(define (host-route-supply ip-addr netmask interface-name)
|
||||
(sub (host-route ip-addr netmask interface-name) #:level 1))
|
||||
|
||||
(define (net-route-supply network-addr netmask link)
|
||||
(sub (net-route network-addr netmask link) #:level 1))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Local IP route
|
||||
|
||||
(define (spawn-host-route my-address netmask interface-name)
|
||||
(list
|
||||
(let ((network-addr (apply-netmask my-address netmask)))
|
||||
(spawn-normal-ip-route (host-route-supply my-address netmask interface-name)
|
||||
network-addr
|
||||
netmask
|
||||
interface-name))
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(transition s (when (gestalt-empty? g) (quit)))]
|
||||
[(message (ip-packet _ peer-address _ _ _ body) _ _)
|
||||
(bit-string-case body
|
||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
||||
(case type
|
||||
[(8) ;; ECHO (0 is ECHO-REPLY)
|
||||
(log-info "Ping of ~a from ~a"
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address))
|
||||
(define reply-data0 (bit-string 0
|
||||
code
|
||||
(0 :: integer bytes 2) ;; TODO
|
||||
(rest :: binary)))
|
||||
(transition s (send (ip-packet #f
|
||||
my-address
|
||||
peer-address
|
||||
PROTOCOL-ICMP
|
||||
#""
|
||||
(ip-checksum 2 reply-data0))))]
|
||||
[else
|
||||
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
||||
type
|
||||
code
|
||||
checksum
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address)
|
||||
(dump-bytes->string rest))
|
||||
#f]))
|
||||
(else #f))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union (pub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))
|
||||
(sub (ip-packet ? ? my-address PROTOCOL-ICMP ? ?))
|
||||
(pub (arp-assertion IPv4-ethertype my-address interface-name))
|
||||
(host-route-supply my-address netmask interface-name)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Gateway IP route
|
||||
|
||||
(define (spawn-net-route network-addr netmask link)
|
||||
(cond
|
||||
[(bytes? link) (spawn-gateway-ip-route network-addr netmask link)]
|
||||
[(string? link) (spawn-normal-ip-route (net-route-supply network-addr netmask link)
|
||||
network-addr
|
||||
netmask
|
||||
link)]
|
||||
[else (error 'ip "Invalid net-route: ~v ~v ~v" network-addr netmask link)]))
|
||||
|
||||
(define (spawn-gateway-ip-route network netmask gateway-addr)
|
||||
(lookup-arp gateway-addr
|
||||
?
|
||||
(net-route-supply network netmask gateway-addr)
|
||||
(lambda (interface gateway-hwaddr)
|
||||
(spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr))))
|
||||
|
||||
(define (spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr)
|
||||
(define host-route-projector (project-subs (host-route (?!) ? ?)))
|
||||
(define net-route-projector (project-subs (net-route (?!) (?!) ?)))
|
||||
|
||||
(define (covered-by-some-other-route? addr routes)
|
||||
(for/or ([r (in-set routes)])
|
||||
(match-define (list net msk) r)
|
||||
(and (positive? msk)
|
||||
(ip-address-in-subnet? addr net msk))))
|
||||
|
||||
(spawn (lambda (e routes)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(define host-ips (gestalt-project/single g host-route-projector))
|
||||
(define net-ips+netmasks (gestalt-project/keys g net-route-projector))
|
||||
(transition (set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks)
|
||||
(when (gestalt-empty? (gestalt-filter g (net-route-supply network
|
||||
netmask
|
||||
gateway-addr)))
|
||||
(quit)))]
|
||||
[(message (? ip-packet? p) _ _)
|
||||
(and (not (equal? (ip-packet-source-interface p) (ethernet-interface-name interface)))
|
||||
(not (covered-by-some-other-route? (ip-packet-destination p) routes))
|
||||
(transition routes
|
||||
(send (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
gateway-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p)))))]
|
||||
[_ #f]))
|
||||
(set)
|
||||
(gestalt-union (if (zero? netmask)
|
||||
(net-route-supply network netmask gateway-addr)
|
||||
(gestalt-empty))
|
||||
observe-local-ip-addresses-gestalt
|
||||
(sub (ip-packet ? ? ? ? ? ?))
|
||||
(pub (ip-packet ? ? ? ? ? ?)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Normal IP route
|
||||
|
||||
(define (spawn-normal-ip-route gestalt-for-supply network netmask interface-name)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(log-info "normal-ip route ~v/~v/~v quitting:\n~a"
|
||||
network
|
||||
netmask
|
||||
interface-name
|
||||
(gestalt->pretty-string g))
|
||||
(transition s (when (gestalt-empty? g) (quit)))]
|
||||
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
||||
(define p (parse-ip-packet interface-name body))
|
||||
(and p (transition s (send p)))]
|
||||
[(message (? ip-packet? p) _ _)
|
||||
(define destination (ip-packet-destination p))
|
||||
(and (not (equal? (ip-packet-source-interface p) interface-name))
|
||||
(ip-address-in-subnet? destination network netmask)
|
||||
(transition
|
||||
s
|
||||
(lookup-arp destination
|
||||
(ethernet-interface interface-name ?)
|
||||
(gestalt-empty)
|
||||
(lambda (interface destination-hwaddr)
|
||||
(send (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p)))))))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union gestalt-for-supply
|
||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
||||
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
||||
(pub (arp-interface interface-name))
|
||||
(sub (ip-packet ? ? ? ? ? ?))
|
||||
(pub (ip-packet ? ? ? ? ? ?)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define IPv4-ethertype #x0800)
|
||||
|
||||
|
|
@ -32,174 +231,83 @@
|
|||
|
||||
(define default-ttl 64)
|
||||
|
||||
(define (ip-address->hostname bs)
|
||||
(bit-string-case bs
|
||||
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||
(define (parse-ip-packet interface-name body)
|
||||
;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
|
||||
(bit-string-case body
|
||||
([ (= IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
service-type
|
||||
(total-length :: bits 16)
|
||||
(id :: bits 16)
|
||||
(flags :: bits 3)
|
||||
(fragment-offset :: bits 13)
|
||||
ttl
|
||||
protocol
|
||||
(header-checksum :: bits 16) ;; TODO: check checksum
|
||||
(source-ip0 :: binary bits 32)
|
||||
(destination-ip0 :: binary bits 32)
|
||||
(rest :: binary) ]
|
||||
(let ((source-ip (bit-string->bytes source-ip0))
|
||||
(destination-ip (bit-string->bytes destination-ip0))
|
||||
(options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))))
|
||||
(if (and (>= header-length 5)
|
||||
(>= (bit-string-byte-count body) (* header-length 4)))
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes options-length)
|
||||
(data :: binary) ]
|
||||
(ip-packet interface-name
|
||||
(bit-string->bytes source-ip)
|
||||
(bit-string->bytes destination-ip)
|
||||
protocol
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))
|
||||
#f)))
|
||||
(else #f)))
|
||||
|
||||
(define broadcast-ip-address (bytes 255 255 255 255))
|
||||
(define (format-ip-packet p)
|
||||
(match-define (ip-packet _ src dst protocol options body) p)
|
||||
|
||||
(struct state (hwaddr) #:transparent)
|
||||
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
||||
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
|
||||
|
||||
(define (spawn-ip-driver interface-name my-address)
|
||||
(define header0 (bit-string (IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
0 ;; TODO: service type
|
||||
((+ (* header-length 4) (bit-string-byte-count body))
|
||||
:: bits 16)
|
||||
(0 :: bits 16) ;; TODO: identifier
|
||||
(0 :: bits 3) ;; TODO: flags
|
||||
(0 :: bits 13) ;; TODO: fragments
|
||||
default-ttl
|
||||
protocol
|
||||
(0 :: bits 16)
|
||||
(src :: binary bits 32)
|
||||
(dst :: binary bits 32)
|
||||
(options :: binary)))
|
||||
(define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
|
||||
|
||||
(define (analyze-incoming-packet body s)
|
||||
;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
|
||||
(bit-string-case body
|
||||
([ (= IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
service-type
|
||||
(total-length :: bits 16)
|
||||
(id :: bits 16)
|
||||
(flags :: bits 3)
|
||||
(fragment-offset :: bits 13)
|
||||
ttl
|
||||
protocol
|
||||
(header-checksum :: bits 16) ;; TODO: check checksum
|
||||
(source-ip0 :: binary bits 32)
|
||||
(destination-ip0 :: binary bits 32)
|
||||
(rest :: binary) ]
|
||||
(let ((source-ip (bit-string->bytes source-ip0))
|
||||
(destination-ip (bit-string->bytes destination-ip0))
|
||||
(options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))))
|
||||
(if (and (not (equal? source-ip my-address))
|
||||
(or (equal? destination-ip my-address)
|
||||
(equal? destination-ip broadcast-ip-address))
|
||||
(>= header-length 5)
|
||||
(>= (bit-string-byte-count body) (* header-length 4)))
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes options-length)
|
||||
(data :: binary) ]
|
||||
(transition s (send (ip-packet (bit-string->bytes source-ip)
|
||||
(bit-string->bytes destination-ip)
|
||||
protocol
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))))
|
||||
#f)))
|
||||
(else #f)))
|
||||
full-packet)
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
||||
(define new-s (struct-copy state s [hwaddr hwaddr]))
|
||||
(transition new-s (routing-update (compute-gestalt new-s))))
|
||||
|
||||
(define (compute-gestalt s)
|
||||
(gestalt-union
|
||||
(pub (arp-assertion IPv4-ethertype my-address))
|
||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
||||
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
||||
(sub (ip-packet my-address ? ? ? ?))
|
||||
(pub (ip-packet ? my-address ? ? ?))
|
||||
(if (state-hwaddr s)
|
||||
(pub (ip-interface my-address (ethernet-interface interface-name (state-hwaddr s))))
|
||||
(gestalt-empty))))
|
||||
|
||||
(list
|
||||
(spawn-icmp-driver my-address)
|
||||
(let ((state0 (state #f)))
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(analyze-gestalt g s)]
|
||||
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
||||
(analyze-incoming-packet body s)]
|
||||
[(message (ip-packet _ peer-address protocol options body) _ _)
|
||||
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
||||
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
|
||||
(define header0
|
||||
(bit-string (IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
0 ;; TODO: service type
|
||||
((+ (* header-length 4) (bit-string-byte-count body))
|
||||
:: bits 16)
|
||||
(0 :: bits 16) ;; TODO: identifier
|
||||
(0 :: bits 3) ;; TODO: flags
|
||||
(0 :: bits 13) ;; TODO: fragments
|
||||
default-ttl
|
||||
protocol
|
||||
(0 :: bits 16)
|
||||
(my-address :: binary bits 32)
|
||||
(peer-address :: binary bits 32)
|
||||
(options :: binary)))
|
||||
(define full-packet (bit-string ((ip-checksum 10 header0) :: binary)
|
||||
(body :: binary)))
|
||||
(transition s (spawn-packet-sender interface-name
|
||||
(state-hwaddr s)
|
||||
peer-address
|
||||
full-packet))]
|
||||
[_ #f]))
|
||||
state0
|
||||
(compute-gestalt state0)))))
|
||||
|
||||
(define arp-result-projection (compile-gestalt-projection (arp-query ? ? (?!))))
|
||||
|
||||
(define (spawn-packet-sender interface-name local-hwaddr remote-ip full-packet)
|
||||
(define timer-id (list (gensym 'packet) remote-ip))
|
||||
(list
|
||||
(send (set-timer timer-id 5000 'relative))
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(define all-results
|
||||
(matcher-key-set/single (gestalt-project g 0 0 #t arp-result-projection)))
|
||||
(match all-results
|
||||
[#f (error 'ip "Someone has published a wildcard arp result")]
|
||||
[(? set-empty?) #f] ;; no results yet, keep waiting
|
||||
[_
|
||||
(define remote-hwaddr (set-first all-results))
|
||||
(unless (= 1 (set-count all-results))
|
||||
(log-warning "Ambiguous arp result for ~a: ~v"
|
||||
(ip-address->hostname remote-ip)
|
||||
all-results))
|
||||
(transition s
|
||||
(list
|
||||
(send (ethernet-packet (ethernet-interface interface-name
|
||||
local-hwaddr)
|
||||
#f
|
||||
local-hwaddr
|
||||
remote-hwaddr
|
||||
IPv4-ethertype
|
||||
full-packet))
|
||||
(quit)))])]
|
||||
[(message (timer-expired _ _) _ _)
|
||||
(log-warning "ARP lookup failed, packet dropped")
|
||||
(transition s (quit))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union (sub (timer-expired timer-id ?))
|
||||
(sub (arp-query IPv4-ethertype remote-ip ?) #:level 1)))))
|
||||
|
||||
(define (spawn-icmp-driver my-address)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message (ip-packet peer-address _ _ _ body) _ _)
|
||||
(bit-string-case body
|
||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
||||
(case type
|
||||
[(8) ;; ECHO (0 is ECHO-REPLY)
|
||||
(log-info "Ping of ~a from ~a"
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address))
|
||||
(define reply-data0 (bit-string 0
|
||||
code
|
||||
(0 :: integer bytes 2) ;; TODO
|
||||
(rest :: binary)))
|
||||
(transition s (send (ip-packet my-address
|
||||
peer-address
|
||||
PROTOCOL-ICMP
|
||||
#""
|
||||
(ip-checksum 2 reply-data0))))]
|
||||
[else
|
||||
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
||||
type
|
||||
code
|
||||
checksum
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address)
|
||||
(dump-bytes->string rest))
|
||||
#f]))
|
||||
(else #f))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union (pub (ip-packet my-address ? PROTOCOL-ICMP ? ?))
|
||||
(sub (ip-packet ? my-address PROTOCOL-ICMP ? ?)))))
|
||||
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
|
||||
(on-gestalt (lambda (_g arp-results)
|
||||
(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
|
||||
(project-pubs (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))
|
||||
'())))
|
||||
|
|
|
|||
38
main.rkt
38
main.rkt
|
|
@ -2,28 +2,35 @@
|
|||
|
||||
(require minimart/demand-matcher)
|
||||
(require minimart/drivers/timer)
|
||||
(require "configuration.rkt")
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
(require "ip.rkt")
|
||||
(require "tcp.rkt")
|
||||
|
||||
(define interface "vboxnet0")
|
||||
|
||||
;;(log-events-and-actions? #t)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-ethernet-driver)
|
||||
(spawn-arp-driver interface)
|
||||
(spawn-ip-driver interface (bytes 192 168 56 222))
|
||||
(spawn-arp-driver)
|
||||
(spawn-ip-driver)
|
||||
(spawn-tcp-driver)
|
||||
|
||||
(spawn (lambda (e s) #f)
|
||||
(void)
|
||||
(gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||
(pub (host-route (bytes 192 168 56 222) 24 "vboxnet0"))
|
||||
(pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(let ()
|
||||
(local-require racket/set racket/string)
|
||||
|
||||
(define (spawn-session them us)
|
||||
(define user (gensym 'user))
|
||||
(define remote-detector (compile-gestalt-projection (?!)))
|
||||
(define peer-detector (compile-gestalt-projection `(,(?!) says ,?)))
|
||||
(define remote-detector (project-pubs #:meta-level 1 (?!)))
|
||||
(define peer-detector (project-pubs `(,(?!) says ,?)))
|
||||
(define (send-to-remote fmt . vs)
|
||||
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
|
||||
(define (say who fmt . vs)
|
||||
|
|
@ -38,12 +45,10 @@
|
|||
[(message `(,who says ,what) 0 #f)
|
||||
(transition old-peers (say who "says: ~a" what))]
|
||||
[(routing-update g)
|
||||
(define new-peers
|
||||
(matcher-key-set/single (gestalt-project g 0 0 #t peer-detector)))
|
||||
(define new-peers (gestalt-project/single g peer-detector))
|
||||
(transition
|
||||
new-peers
|
||||
(list (when (matcher-empty? (gestalt-project g 1 0 #t remote-detector))
|
||||
(quit))
|
||||
(list (when (matcher-empty? (gestalt-project g remote-detector)) (quit))
|
||||
(for/list [(who (set-subtract new-peers old-peers))]
|
||||
(say who "arrived."))
|
||||
(for/list [(who (set-subtract old-peers new-peers))]
|
||||
|
|
@ -68,15 +73,18 @@
|
|||
(local-require racket/pretty)
|
||||
(match e
|
||||
[(message m _ _)
|
||||
(pretty-write `(MAIN ,m))]
|
||||
;; (pretty-write `(MAIN ,m))
|
||||
(void)]
|
||||
[(routing-update g)
|
||||
(printf "MAIN gestalt:\n")
|
||||
(pretty-print-gestalt g)]
|
||||
;; (printf "MAIN gestalt:\n")
|
||||
;; (pretty-print-gestalt g)
|
||||
(void)]
|
||||
[_ (void)])
|
||||
(flush-output)
|
||||
#f)
|
||||
(void)
|
||||
(gestalt-union
|
||||
;;(sub ? #:level 5)
|
||||
(sub (tcp-channel ? ? ?) #:level 5)
|
||||
(sub ? #:level 5)
|
||||
(pub ? #:level 5)
|
||||
;;(sub (tcp-channel ? ? ?) #:level 5)
|
||||
))
|
||||
|
|
|
|||
70
tcp.rkt
70
tcp.rkt
|
|
@ -70,10 +70,8 @@
|
|||
(struct port-allocator-state (used-ports local-ips) #:transparent)
|
||||
|
||||
(define (spawn-port-allocator)
|
||||
(define port-projection (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?))
|
||||
(define port-compproj (compile-gestalt-projection port-projection))
|
||||
(define ip-projection (ip-interface (?!) ?))
|
||||
(define ip-compproj (compile-gestalt-projection ip-projection))
|
||||
(define port-projection
|
||||
(project-subs (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?)))
|
||||
|
||||
;; TODO: Choose a sensible IP address for the outbound connection.
|
||||
;; We don't have enough information to do this well at the moment,
|
||||
|
|
@ -90,18 +88,17 @@
|
|||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(define extracted-ips (matcher-key-set (gestalt-project g 0 0 #t ip-compproj)))
|
||||
(define extracted-ports (matcher-key-set (gestalt-project g 0 0 #f port-compproj)))
|
||||
(if (or (not extracted-ports) (not extracted-ips))
|
||||
(define local-ips (gestalt->local-ip-addresses g))
|
||||
(define extracted-ports (gestalt-project/keys g port-projection))
|
||||
(if (or (not extracted-ports) (not local-ips))
|
||||
(error 'tcp "Someone has published a wildcard TCP address or IP interface")
|
||||
(transition (let ((local-ips (for/set [(e (in-set extracted-ips))] (car e))))
|
||||
(port-allocator-state
|
||||
(for/fold [(s (set))] [(e (in-set extracted-ports))]
|
||||
(match-define (list si sp di dp) e)
|
||||
(let* ((s (if (set-member? local-ips si) (set-add s sp) s))
|
||||
(s (if (set-member? local-ips di) (set-add s dp) s)))
|
||||
s))
|
||||
local-ips))
|
||||
(transition (port-allocator-state
|
||||
(for/fold [(s (set))] [(e (in-set extracted-ports))]
|
||||
(match-define (list si sp di dp) e)
|
||||
(let* ((s (if (set-member? local-ips si) (set-add s sp) s))
|
||||
(s (if (set-member? local-ips di) (set-add s dp) s)))
|
||||
s))
|
||||
local-ips)
|
||||
'()))]
|
||||
[(message (tcp-port-allocation-request local-addr remote-addr) _ _)
|
||||
(define currently-used-ports (port-allocator-state-used-ports s))
|
||||
|
|
@ -117,8 +114,8 @@
|
|||
[_ #f]))
|
||||
(port-allocator-state (set) (set))
|
||||
(gestalt-union (sub (tcp-port-allocation-request ? ?))
|
||||
(sub (projection->pattern ip-projection) #:level 1)
|
||||
(pub (projection->pattern port-projection) #:level 1))))
|
||||
observe-local-ip-addresses-gestalt
|
||||
(pub (tcp-channel (tcp-address ? ?) (tcp-address ? ?) ?) #:level 1))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Relay between kernel-level and user-level
|
||||
|
|
@ -159,17 +156,12 @@
|
|||
|
||||
(define PROTOCOL-TCP 6)
|
||||
|
||||
(struct codec-state (active-state-vectors) #:transparent)
|
||||
(struct codec-state (local-ips active-state-vectors) #:transparent)
|
||||
|
||||
(define (spawn-kernel-tcp-driver)
|
||||
|
||||
(define (flip-statevec statevec)
|
||||
(match-define (list si sp di dp) statevec)
|
||||
(list di dp si sp))
|
||||
|
||||
(define (state-vector-active? statevec s)
|
||||
(or (set-member? (codec-state-active-state-vectors s) statevec)
|
||||
(set-member? (codec-state-active-state-vectors s) (flip-statevec statevec))))
|
||||
(set-member? (codec-state-active-state-vectors s) statevec))
|
||||
|
||||
(define (analyze-incoming-packet src-ip dst-ip body s)
|
||||
(bit-string-case body
|
||||
|
|
@ -237,14 +229,15 @@
|
|||
(else #f))))
|
||||
(else #f)))
|
||||
|
||||
(define statevec-projection
|
||||
(compile-gestalt-projection
|
||||
(tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))
|
||||
(define statevec-projection (project-subs (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define statevecs (matcher-key-set (gestalt-project g 0 0 #f statevec-projection)))
|
||||
(log-info "gestalt yielded statevecs ~v" statevecs)
|
||||
(transition (struct-copy codec-state s [active-state-vectors statevecs]) '()))
|
||||
(define local-ips (gestalt->local-ip-addresses g))
|
||||
(define statevecs (gestalt-project/keys g statevec-projection))
|
||||
(log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips)
|
||||
(transition (struct-copy codec-state s
|
||||
[local-ips local-ips]
|
||||
[active-state-vectors statevecs]) '()))
|
||||
|
||||
(define (deliver-outbound-packet p s)
|
||||
(match-define (tcp-packet #f
|
||||
|
|
@ -294,26 +287,29 @@
|
|||
0
|
||||
PROTOCOL-TCP
|
||||
((bit-string-byte-count payload) :: integer bytes 2)))
|
||||
(transition s (send (ip-packet src-ip dst-ip PROTOCOL-TCP #""
|
||||
(transition s (send (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
||||
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
||||
|
||||
(spawn (lambda (e s)
|
||||
(log-info "xxxxx TCP ~v" e)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(analyze-gestalt g s)]
|
||||
[(message (ip-packet src dst _ _ body) _ _)
|
||||
[(message (ip-packet source-if src dst _ _ body) _ _)
|
||||
#:when (and source-if ;; source-if == #f iff packet originates locally
|
||||
(set-member? (codec-state-local-ips s) dst))
|
||||
(analyze-incoming-packet src dst body s)]
|
||||
[(message (? tcp-packet? p) _ _)
|
||||
#:when (not (tcp-packet-from-wire? p))
|
||||
(deliver-outbound-packet p s)]
|
||||
[_ #f]))
|
||||
(codec-state (set))
|
||||
(gestalt-union (pub (ip-packet ? ? PROTOCOL-TCP ? ?))
|
||||
(sub (ip-packet ? ? PROTOCOL-TCP ? ?))
|
||||
(codec-state (set) (set))
|
||||
(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))))
|
||||
(pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) #:level 1)
|
||||
observe-local-ip-addresses-gestalt)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Per-connection state vector process
|
||||
|
|
|
|||
Loading…
Reference in New Issue