diff --git a/arp.rkt b/arp.rkt index 657b8b9..fb647b5 100644 --- a/arp.rkt +++ b/arp.rkt @@ -9,9 +9,9 @@ (require racket/set) (require racket/match) -(require minimart) -(require minimart/drivers/timer) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/drivers/timer) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") @@ -22,6 +22,8 @@ (struct arp-assertion (protocol protocol-address interface-name) #:prefab) (struct arp-interface (interface-name) #:prefab) +(struct arp-interface-up (interface-name) #:prefab) + (define ARP-ethertype #x0806) (define cache-entry-lifetime-msec (* 14400 1000)) (define wakeup-interval 5000) @@ -30,7 +32,7 @@ (define (spawn-arp-driver) (spawn-demand-matcher (arp-interface (?!)) - #:supply-level 1 + (arp-interface-up (?!)) spawn-arp-interface)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -42,13 +44,10 @@ (define (spawn-arp-interface interface-name) (log-info "spawn-arp-interface ~v" interface-name) - (lookup-ethernet-hwaddr (gestalt-for-supply interface-name) + (lookup-ethernet-hwaddr (assertion (arp-interface-up 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)) @@ -62,21 +61,20 @@ (define timer-key (list 'arp interface-name)) (define (set-wakeup-alarm) - (send (set-timer timer-key wakeup-interval 'relative))) + (message (set-timer timer-key wakeup-interval 'relative))) (define (compute-gestalt cache) - (gestalt-union (sub (timer-expired timer-key ?)) - (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)) - (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))))))) + (scn/union (subscription (timer-expired timer-key ?)) + (subscription interface) + (subscription (ethernet-packet-pattern interface-name #t ARP-ethertype)) + (assertion (arp-interface-up interface-name)) + (subscription (arp-assertion ? ? interface-name)) + (subscription (observe (arp-query ? ? interface ?))) + (for/fold [(g (trie-empty))] [((k v) (in-hash cache))] + (assertion-set-union g (assertion (arp-query (cache-key-protocol k) + (cache-key-address k) + (cache-value-interface v) + (cache-value-address v))))))) (define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa) (define hlen (bytes-length target-ha)) @@ -135,40 +133,39 @@ cache-entry-lifetime-msec) interface sender-hardware-address))) - (transition (struct-copy state s - [cache cache]) - (list - (case oper - [(1) ;; request - (if (set-member? (state-assertions s) - (cache-key ptype target-protocol-address)) - (begin - (log-info "~a ARP answering request for ~a/~a" - interface-name - ptype - (pretty-bytes target-protocol-address)) - (send (build-packet sender-hardware-address - ptype - 2 ;; reply - hwaddr - target-protocol-address - sender-hardware-address - sender-protocol-address))) - '())] - [(2) '()] ;; reply - [else '()]) - (routing-update (compute-gestalt cache)))))) + (transition (struct-copy state s [cache cache]) + (list + (case oper + [(1) ;; request + (if (set-member? (state-assertions s) + (cache-key ptype target-protocol-address)) + (begin + (log-info "~a ARP answering request for ~a/~a" + interface-name + ptype + (pretty-bytes target-protocol-address)) + (message (build-packet sender-hardware-address + ptype + 2 ;; reply + hwaddr + target-protocol-address + sender-hardware-address + sender-protocol-address))) + '())] + [(2) '()] ;; reply + [else '()]) + (compute-gestalt cache))))) (else #f))) - (define queries-projection (project-subs #:level 1 (arp-query (?!) (?!) ? ?))) + (define queries-projection (compile-projection (observe (arp-query (?!) (?!) ? ?)))) (define (gestalt->queries g) - (for/set [(e (in-set (gestalt-project/keys g queries-projection)))] + (for/set [(e (in-set (trie-project/set g queries-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) - (define assertions-projection (project-pubs (arp-assertion (?!) (?!) ?))) + (define assertions-projection (compile-projection (arp-assertion (?!) (?!) ?))) (define (gestalt->assertions g) - (for/set [(e (in-set (gestalt-project/keys g assertions-projection)))] + (for/set [(e (in-set (trie-project/set g assertions-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) @@ -176,22 +173,22 @@ (define new-assertions (gestalt->assertions g)) (define added-assertions (set-subtract new-assertions (state-assertions s))) (define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions])) - (transition new-s - (list - (when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name))) - (quit)) - (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 broadcast-ethernet-address - (cache-key-protocol a) - 2 ;; reply -- gratuitous announcement - hwaddr - (cache-key-address a) - hwaddr - (cache-key-address a))))))) + (if (trie-empty? (project-assertions g (arp-interface interface-name))) + (quit) + (transition new-s + (list + (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)) + (message (build-packet broadcast-ethernet-address + (cache-key-protocol a) + 2 ;; reply -- gratuitous announcement + hwaddr + (cache-key-address a) + hwaddr + (cache-key-address a)))))))) (define (send-questions s) (define unanswered-queries @@ -209,30 +206,29 @@ (pretty-bytes (cache-key-address q)) (and pa (pretty-bytes pa))) (when pa - (send (build-packet broadcast-ethernet-address - (cache-key-protocol q) - 1 ;; request - hwaddr - pa - zero-ethernet-address - (cache-key-address q))))))) + (message (build-packet broadcast-ethernet-address + (cache-key-protocol q) + 1 ;; request + hwaddr + pa + zero-ethernet-address + (cache-key-address q))))))) (list (set-wakeup-alarm) (spawn (lambda (e s) ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s) (match e - [(routing-update g) + [(scn g) (sequence-transitions (analyze-gestalt g s) send-questions)] - [(message (ethernet-packet _ _ source destination _ body) _ _) + [(message (ethernet-packet _ _ source destination _ body)) (analyze-incoming-packet source destination body s)] - [(message (timer-expired _ _) _ _) + [(message (timer-expired _ _)) (define new-s (struct-copy state s [cache (expire-cache (state-cache s))])) - (define new-g (compute-gestalt (state-cache new-s))) (sequence-transitions (transition new-s (list (set-wakeup-alarm) - (routing-update new-g))) + (compute-gestalt (state-cache new-s)))) send-questions)] [_ #f])) (state (hash) (set) (set)) diff --git a/configuration.rkt b/configuration.rkt index 665320c..01c8a86 100644 --- a/configuration.rkt +++ b/configuration.rkt @@ -3,7 +3,9 @@ (provide (struct-out ethernet-interface) (struct-out host-route) (struct-out gateway-route) - (struct-out net-route)) + (struct-out net-route) + + (struct-out route-up)) (struct ethernet-interface (name hwaddr) #:prefab) @@ -15,3 +17,5 @@ (struct host-route (ip-addr netmask interface-name) #:prefab) (struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab) (struct net-route (network-addr netmask link) #:prefab) + +(struct route-up (route) #:prefab) ;; assertion: the given Route is running diff --git a/demo-config.rkt b/demo-config.rkt index 4b065d2..1740e58 100644 --- a/demo-config.rkt +++ b/demo-config.rkt @@ -2,7 +2,7 @@ ;; Demonstration stack configuration for various hosts. (require racket/match) -(require minimart) +(require prospect-monolithic) (require (only-in mzlib/os gethostname)) (require "configuration.rkt") @@ -13,14 +13,14 @@ (void) (match (gethostname) ["skip" - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) - (pub (host-route (bytes 192 168 1 222) 24 "en0")))] + (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) + (assertion (host-route (bytes 192 168 1 222) 24 "en0")))] [(or "hop" "walk") - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) - (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] + (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) + (assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))] ["stockholm.ccs.neu.edu" - (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) - (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) - (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] + (scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0")) + (assertion (host-route (bytes 192 168 56 222) 24 "vboxnet0")) + (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] [else (error 'spawn-demo-config "No setup for hostname ~a" (gethostname))]))) diff --git a/ethernet.rkt b/ethernet.rkt index 8ae6da1..d985eb4 100644 --- a/ethernet.rkt +++ b/ethernet.rkt @@ -6,8 +6,6 @@ broadcast-ethernet-address interface-names spawn-ethernet-driver - ethernet-hwaddr-projection - gestalt->hwaddr ethernet-packet-pattern lookup-ethernet-hwaddr) @@ -15,8 +13,8 @@ (require racket/match) (require racket/async-channel) -(require minimart) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/demand-matcher) (require packet-socket) (require bitsyntax) @@ -33,8 +31,8 @@ (log-info "Device names: ~a" interface-names) (define (spawn-ethernet-driver) - (spawn-demand-matcher (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?) - #:demand-is-subscription? #t + (spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?)) + (ethernet-interface (?!) ?) spawn-interface-tap)) (define (spawn-interface-tap interface-name) @@ -50,22 +48,21 @@ (thread (lambda () (interface-packet-read-loop interface h control-ch))) (spawn (lambda (e h) (match e - [(routing-update g) - - (if (gestalt-empty? g) + [(scn g) + (if (trie-empty? g) (begin (async-channel-put control-ch 'quit) - (transition #f (quit))) + (quit)) (begin (async-channel-put control-ch 'unblock) #f))] - [(message (? ethernet-packet? p) 1 #f) ;; from metalevel 1 + [(message (at-meta (? ethernet-packet? p))) ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)" ;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (pretty-bytes (ethernet-packet-source p)) ;; (pretty-bytes (ethernet-packet-destination p)) ;; (number->string (ethernet-packet-ethertype p) 16)) ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) - (transition h (send p))] - [(message (? ethernet-packet? p) 0 #f) ;; from metalevel 0 + (transition h (message p))] + [(message (? ethernet-packet? p)) ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)" ;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (pretty-bytes (ethernet-packet-source p)) @@ -76,10 +73,10 @@ #f] [_ #f])) h - (gestalt-union (pub (ethernet-packet interface #t ? ? ? ?)) - (pub (ethernet-packet interface #t ? ? ? ?) #:level 1) - (sub (ethernet-packet interface #f ? ? ? ?)) - (sub (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))])) + (scn/union (assertion interface) + (subscription (ethernet-packet interface #f ? ? ? ?)) + (subscription (observe (ethernet-packet interface #t ? ? ? ?))) + (subscription (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))])) (define (interface-packet-read-loop interface h control-ch) (define (blocked) @@ -120,29 +117,17 @@ (ethertype :: integer bytes 2) (body :: binary)))) -(define (ethernet-hwaddr-projection interface-name) - (project-pubs (ethernet-packet (ethernet-interface interface-name (?!)) #t ? ? ? ?))) - -(define (gestalt->hwaddr g interface-name) - (define hwaddrs (gestalt-project/single g (ethernet-hwaddr-projection interface-name))) - (case (set-count hwaddrs) - [(0) #f] - [(1) (set-first hwaddrs)] - [else - (log-warning "gestalt->hwaddr: multiple addresses for interface ~a: ~v" interface-name hwaddrs) - (set-first hwaddrs)])) - (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))) +(define (lookup-ethernet-hwaddr base-interests interface-name k) + (on-claim #: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-interests + (ethernet-interface interface-name (?!)))) diff --git a/fetchurl.rkt b/fetchurl.rkt index 105bfa0..24469b6 100644 --- a/fetchurl.rkt +++ b/fetchurl.rkt @@ -1,7 +1,7 @@ -#lang minimart +#lang prospect-monolithic -(require minimart/demand-matcher) -(require minimart/drivers/timer) +(require prospect-monolithic/demand-matcher) +(require prospect-monolithic/drivers/timer) (require "demo-config.rkt") (require "ethernet.rkt") (require "arp.rkt") diff --git a/ip.rkt b/ip.rkt index 8106801..3e98837 100644 --- a/ip.rkt +++ b/ip.rkt @@ -13,9 +13,9 @@ (require racket/set) (require racket/match) (require (only-in racket/string string-split)) -(require minimart) -(require minimart/drivers/timer) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/drivers/timer) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") @@ -53,48 +53,38 @@ (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 local-ip-address-projector (compile-projection (host-route (?!) ? ?))) +(define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector)) +(define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (spawn-ip-driver) (list (spawn-demand-matcher (host-route (?!) (?!) (?!)) - #:supply-level 1 + (route-up (host-route (?!) (?!) (?!))) spawn-host-route) (spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!)) - #:supply-level 1 + (route-up (gateway-route (?!) (?!) (?!) (?!))) spawn-gateway-route) (spawn-demand-matcher (net-route (?!) (?!) (?!)) - #:supply-level 1 + (route-up (net-route (?!) (?!) (?!))) spawn-net-route))) -(define (host-route-supply ip-addr netmask interface-name) - (sub (host-route ip-addr netmask interface-name) #:level 1)) - -(define (gateway-route-supply network-addr netmask gateway-addr interface-name) - (sub (gateway-route network-addr netmask gateway-addr 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) + (spawn-normal-ip-route (host-route 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) _ _) + [(scn (? trie-empty?)) (quit)] + [(message (ip-packet _ peer-address _ _ _ body)) (bit-string-case body ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum (case type @@ -106,12 +96,12 @@ 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))))] + (transition s (message (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 @@ -124,10 +114,10 @@ (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))))) + (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 @@ -135,15 +125,16 @@ (struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent) (define (spawn-gateway-route network netmask gateway-addr interface-name) - (define gestalt-for-supply (gateway-route-supply network netmask gateway-addr interface-name)) + (define the-route (gateway-route network netmask gateway-addr interface-name)) - (define host-route-projector (project-subs (host-route (?!) ? ?))) - (define gateway-route-projector (project-subs (gateway-route (?!) (?!) ? ?))) - (define net-route-projector (project-subs (net-route (?!) (?!) ?))) - (define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype - gateway-addr - (?! (ethernet-interface interface-name ?)) - (?!)))) + (define host-route-projector (compile-projection (host-route (?!) ? ?))) + (define gateway-route-projector (compile-projection (gateway-route (?!) (?!) ? ?))) + (define net-route-projector (compile-projection (net-route (?!) (?!) ?))) + (define gateway-arp-projector (compile-projection + (arp-query IPv4-ethertype + gateway-addr + (?! (ethernet-interface interface-name ?)) + (?!)))) (define (covered-by-some-other-route? addr routes) (for/or ([r (in-set routes)]) @@ -153,25 +144,27 @@ (spawn (lambda (e s) (match e - [(routing-update g) - (define host-ips (gestalt-project/single g host-route-projector)) - (define gw-nets+netmasks (gestalt-project/keys g gateway-route-projector)) - (define net-nets+netmasks (gestalt-project/keys g net-route-projector)) - (define gw-ip+hwaddr (let ((vs (gestalt-project/keys g gateway-arp-projector))) + [(scn g) + (define host-ips (trie-project/set/single g host-route-projector)) + (define gw-nets+netmasks (trie-project/set g gateway-route-projector)) + (define net-nets+netmasks (trie-project/set g net-route-projector)) + (define gw-ip+hwaddr (let ((vs (trie-project/set g gateway-arp-projector))) (and vs (not (set-empty? vs)) (set-first vs)))) (when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s))) (log-info "Discovered gateway ~a at ~a on interface ~a." (ip-address->hostname gateway-addr) (ethernet-interface-name (car gw-ip+hwaddr)) (pretty-bytes (cadr gw-ip+hwaddr)))) - (transition (gateway-route-state - (set-union (for/set ([ip host-ips]) (list ip 32)) - gw-nets+netmasks - net-nets+netmasks) - (and gw-ip+hwaddr (car gw-ip+hwaddr)) - (and gw-ip+hwaddr (cadr gw-ip+hwaddr))) - (when (gestalt-empty? (gestalt-filter g gestalt-for-supply)) (quit)))] - [(message (? ip-packet? p) _ _) + (if (trie-empty? (project-assertions g (?! the-route))) + (quit) + (transition (gateway-route-state + (set-union (for/set ([ip host-ips]) (list ip 32)) + 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." @@ -181,42 +174,39 @@ (not (covered-by-some-other-route? (ip-packet-destination p) (gateway-route-state-routes s))) (transition s - (send (ethernet-packet gw-if - #f - (ethernet-interface-hwaddr gw-if) - (gateway-route-state-gateway-hwaddr s) - IPv4-ethertype - (format-ip-packet p)))))] + (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) - (gestalt-union gestalt-for-supply - - (sub (ip-packet ? ? ? ? ? ?)) - (pub (ip-packet ? ? ? ? ? ?)) - - observe-local-ip-addresses-gestalt - (sub (net-route ? ? ?) #:level 2) - (sub (gateway-route ? ? ? ?) #:level 2) - (projection->gestalt gateway-arp-projector)))) + (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 (define (spawn-net-route network-addr netmask link) - (spawn-normal-ip-route (net-route-supply network-addr netmask link) network-addr netmask link)) + (spawn-normal-ip-route (net-route network-addr netmask link) network-addr netmask link)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Normal IP route -(define (spawn-normal-ip-route gestalt-for-supply network netmask interface-name) +(define (spawn-normal-ip-route the-route network netmask interface-name) (spawn (lambda (e s) (match e - [(routing-update g) - (transition s (when (gestalt-empty? g) (quit)))] - [(message (ethernet-packet _ _ _ _ _ body) _ _) + [(scn (? trie-empty?)) (quit)] + [(message (ethernet-packet _ _ _ _ _ body)) (define p (parse-ip-packet interface-name body)) - (and p (transition s (send p)))] - [(message (? ip-packet? p) _ _) + (and p (transition s (message 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) @@ -224,23 +214,21 @@ s (lookup-arp destination (ethernet-interface interface-name ?) - (gestalt-empty) + (trie-empty) (lambda (interface destination-hwaddr) - (send (ethernet-packet interface - #f - (ethernet-interface-hwaddr interface) - destination-hwaddr - IPv4-ethertype - (format-ip-packet p)))))))] + (message (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 ? ? ? ? ? ?))))) + (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 ? ? ? ? ? ?))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -313,25 +301,25 @@ full-packet) (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)) - '()))) + (on-claim (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 + (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)) + '()))) diff --git a/main.rkt b/main.rkt index af9d6af..8feeb27 100644 --- a/main.rkt +++ b/main.rkt @@ -1,13 +1,13 @@ -#lang minimart +#lang prospect-monolithic -(require minimart/demand-matcher) -(require minimart/drivers/timer) +(require prospect-monolithic/demand-matcher) +(require prospect-monolithic/drivers/timer) (require "demo-config.rkt") (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") -(require "tcp.rkt") -(require "udp.rkt") +;; (require "tcp.rkt") +;; (require "udp.rkt") ;;(log-events-and-actions? #t) @@ -15,94 +15,95 @@ (spawn-ethernet-driver) (spawn-arp-driver) (spawn-ip-driver) -(spawn-tcp-driver) -(spawn-udp-driver) +;; (spawn-tcp-driver) +;; (spawn-udp-driver) (spawn-demo-config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(let () +#;(let () (local-require racket/set racket/string) (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (project-pubs #:meta-level 1 (?!))) - (define peer-detector (project-pubs `(,(?!) says ,?))) + (define remote-detector (compile-projection (at-meta (?!)))) + (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) (define (send-to-remote fmt . vs) - (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) + (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (define (say who fmt . vs) (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs)))) (list (send-to-remote "Welcome, ~a.\n" user) - (spawn (lambda (e old-peers) - (log-info "~a: ~v --> ~v" user e old-peers) - (match e - [(message (tcp-channel _ _ bs) 1 #f) - (transition old-peers - (send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))] - [(message `(,who says ,what) 0 #f) - (transition old-peers (say who "says: ~a" what))] - [(routing-update g) - (define new-peers (gestalt-project/single g peer-detector)) - (transition - new-peers - (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))] - (say who "departed."))))] - [#f #f])) - (set) - (gestalt-union (sub `(,? says ,?)) - (sub `(,? says ,?) #:level 1) - (pub `(,user says ,?)) - (sub (tcp-channel them us ?) #:meta-level 1) - (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) - (pub (tcp-channel us them ?) #:meta-level 1))))) - - (spawn-world - (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 6667)) ?) - #:meta-level 1 - spawn-session)) + (spawn + (lambda (e peers) + (match e + [(message (at-meta (tcp-channel _ _ bs))) + (transition peers (message `(,user says ,(string-trim (bytes->string/utf-8 bs)))))] + [(message `(,who says ,what)) + (transition peers (say who "says: ~a" what))] + [(scn assertions) + (if (trie-empty? (trie-project assertions remote-detector)) + (quit (send-to-remote "Goodbye!\n")) + (let ((new-peers (trie-project/set/single assertions peer-detector))) + (define arrived (set-subtract new-peers peers)) + (define departed (set-subtract peers new-peers)) + (transition new-peers + (list (for/list [(who arrived)] (say who "arrived.")) + (for/list [(who departed)] (say who "departed."))))))] + [#f #f])) + (set) + (scn/union + (subscription `(,? says ,?)) ;; read actual chat messages + (subscription (advertise `(,? says ,?))) ;; observe peer presence + (advertisement `(,user says ,?)) ;; advertise our presence + (subscription (tcp-channel them us ?) #:meta-level 1) ;; read from remote client + (subscription (advertise (tcp-channel them us ?)) #:meta-level 1) ;; monitor remote client + (advertisement (tcp-channel us them ?) #:meta-level 1) ;; we will write to remote client + )))) + (spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) + (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) + #:meta-level 1 + spawn-session) ) -(let () +#;(let () (spawn (lambda (e s) (match e - [(message (udp-packet src dst body) _ _) + [(message (udp-packet src dst body)) (log-info "Got packet from ~v: ~v" src body) - (transition s (send (udp-packet dst - src - (string->bytes/utf-8 (format "You said: ~a" body)))))] + (transition s (message + (udp-packet dst + src + (string->bytes/utf-8 (format "You said: ~a" body)))))] [_ #f])) (void) - (gestalt-union (sub (udp-packet ? (udp-listener 6667) ?))))) + (scn (subscription (udp-packet ? (udp-listener 6667) ?))))) -(let () +#;(let () (define (spawn-session them us) (list (send 'bump) (spawn (lambda (e s) (match e - [(message `(counter ,counter) _ _) + [(message `(counter ,counter)) (define response (string->bytes/utf-8 (format (string-append "HTTP/1.0 200 OK\r\n\r\n" - "

Hello world from minimart-netstack!

\n" - "

This is running on minimart's own\n" - "\n" + "

Hello world from prospect-monolithic-netstack!

\n" + "

This is running on prospect-monolithic's own\n" + "\n" "TCP/IP stack.

\n" "

There have been ~a requests prior to this one.

") counter))) - (transition s (list (send #:meta-level 1 (tcp-channel us them response)) + (transition s (list (message #:meta-level 1 (tcp-channel us them response)) (quit)))] [_ #f])) (void) - (gestalt-union (sub `(counter ,?)) - (sub (tcp-channel them us ?) #:meta-level 1) - (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) - (pub (tcp-channel us them ?) #:meta-level 1))))) + (scn/union (subscription `(counter ,?)) + (subscription (tcp-channel them us ?) #:meta-level 1) + (subscription (advertise (tcp-channel them us ?)) #:meta-level 1) + (advertisement (tcp-channel us them ?) #:meta-level 1))))) (spawn-world (spawn (lambda (e counter) @@ -111,30 +112,10 @@ (transition (+ counter 1) (send `(counter ,counter)))] [_ #f])) 0 - (gestalt-union (sub 'bump) - (pub `(counter ,?)))) - (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?) + (scn (subscription 'bump))) + (spawn-demand-matcher (advertise (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)) + (observe (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)) #:meta-level 1 spawn-session)) ) - -(spawn (lambda (e s) - (local-require racket/pretty) - (match e - [(message m _ _) - ;; (pretty-write `(MAIN ,m)) - (void)] - [(routing-update g) - ;; (printf "MAIN gestalt:\n") - ;; (pretty-print-gestalt g) - (void)] - [_ (void)]) - (flush-output) - #f) - (void) - (gestalt-union - (sub ? #:level 5) - (pub ? #:level 5) - ;;(sub (tcp-channel ? ? ?) #:level 5) - )) diff --git a/port-allocator.rkt b/port-allocator.rkt index 6466db3..1599cd5 100644 --- a/port-allocator.rkt +++ b/port-allocator.rkt @@ -6,7 +6,7 @@ (require racket/set) (require racket/match) -(require minimart) +(require prospect-monolithic) (require "ip.rkt") (struct port-allocation-request (type k) #:prefab) diff --git a/tcp.rkt b/tcp.rkt index 2f5df59..e6525be 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -8,9 +8,9 @@ (require racket/set) (require racket/match) -(require minimart) -(require minimart/drivers/timer) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/drivers/timer) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") diff --git a/udp.rkt b/udp.rkt index a2444c5..d275571 100644 --- a/udp.rkt +++ b/udp.rkt @@ -10,8 +10,8 @@ (require racket/set) (require racket/match) -(require minimart) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt")