diff --git a/examples/netstack/arp.rkt b/examples/netstack/arp.rkt index 97cf773..030cbc4 100644 --- a/examples/netstack/arp.rkt +++ b/examples/netstack/arp.rkt @@ -1,22 +1,20 @@ -#lang racket/base +#lang syndicate/actor ;; ARP protocol, http://tools.ietf.org/html/rfc826 ;; Only does ARP-over-ethernet. (provide (struct-out arp-query) (struct-out arp-assertion) (struct-out arp-interface) - spawn-arp-driver) + spawn-arp-driver) (require racket/set) (require racket/match) -(require syndicate/monolithic) -(require syndicate/drivers/timer) -(require syndicate/demand-matcher) +(require/activate syndicate/drivers/timer) (require bitsyntax) (require "dump-bytes.rkt") (require "configuration.rkt") -(require "ethernet.rkt") +(require/activate "ethernet.rkt") (struct arp-query (protocol protocol-address interface link-address) #:prefab) (struct arp-assertion (protocol protocol-address interface-name) #:prefab) @@ -31,51 +29,31 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (spawn-arp-driver) - (spawn-demand-matcher (arp-interface (?!)) - (arp-interface-up (?!)) - spawn-arp-interface)) + (actor #:name 'arp-driver + (react (during/actor (arp-interface $interface-name) + #:name (list 'arp-interface interface-name) + (assert (arp-interface-up interface-name)) + (on-start (define hwaddr (lookup-ethernet-hwaddr interface-name)) + (when (not hwaddr) + (error 'arp "Failed to look up ARP interface ~v" + interface-name)) + (react (run-arp-interface interface-name hwaddr))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (struct cache-key (protocol address) #:transparent) (struct cache-value (expiry interface address) #:transparent) -(struct state (cache queries assertions) #:transparent) +(define (expire-cache c) + (define now (current-inexact-milliseconds)) + (define (not-expired? v) (< now (cache-value-expiry v))) + (for/hash [((k v) (in-hash c)) #:when (not-expired? v)] + (values k v))) -(define (spawn-arp-interface interface-name) - (log-info "spawn-arp-interface ~v" interface-name) - (lookup-ethernet-hwaddr (assertion (arp-interface-up interface-name)) - interface-name - (lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr)))) - -(define (spawn-arp-interface* interface-name hwaddr) - (log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr) +(define (run-arp-interface interface-name hwaddr) + (log-info "ARP interface ~v ~v" interface-name hwaddr) (define interface (ethernet-interface interface-name hwaddr)) - (define (expire-cache cache) - (define now (current-inexact-milliseconds)) - (define (not-expired? v) (< now (cache-value-expiry v))) - (for/hash [((k v) (in-hash cache)) #:when (not-expired? v)] - (values k v))) - - (define timer-key (list 'arp interface-name)) - - (define (set-wakeup-alarm) - (message (set-timer timer-key wakeup-interval 'relative))) - - (define (compute-gestalt cache) - (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)) (define plen (bytes-length target-pa)) @@ -96,140 +74,123 @@ ARP-ethertype packet)) - (define (analyze-incoming-packet source destination body s) - (bit-string-case body - ([ (= 1 :: integer bytes 2) - (ptype :: integer bytes 2) - hlen - plen - (oper :: integer bytes 2) - (sender-hardware-address0 :: binary bytes hlen) - (sender-protocol-address0 :: binary bytes plen) - (target-hardware-address0 :: binary bytes hlen) - (target-protocol-address0 :: binary bytes plen) - (:: binary) ;; The extra zeros exist because ethernet packets - ;; have a minimum size. This is, in part, why - ;; IPv4 headers have a total-length field, so - ;; that the zero padding can be removed. - ] - (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)) - (define learned-key (cache-key ptype sender-protocol-address)) - (when (and (set-member? (state-queries s) learned-key) ;; it is relevant to our interests - (not (equal? sender-hardware-address - (cache-value-address (hash-ref (state-cache s) - learned-key - (lambda () - (cache-value #f #f #f))))))) - (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)) - learned-key - (cache-value (+ (current-inexact-milliseconds) - 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)) - (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 (some-asserted-pa ptype) + (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions))) + ['() #f] + [(list* k _) (cache-key-address k)])) - (define queries-projection (observe (arp-query (?!) (?!) ? ?))) - (define (gestalt->queries g) - (for/set [(e (in-set (trie-project/set #:take 2 g queries-projection)))] - (match-define (list ptype pa) e) - (cache-key ptype pa))) + (define (send-questions!) + (for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))] + (define pa (some-asserted-pa (cache-key-protocol q))) + (log-info "~a ARP Asking for ~a from ~a" + interface-name + (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)))))) - (define assertions-projection (arp-assertion (?!) (?!) ?)) - (define (gestalt->assertions g) - (for/set [(e (in-set (trie-project/set #:take 2 g assertions-projection)))] - (match-define (list ptype pa) e) - (cache-key ptype pa))) + (field [cache (hash)] + [queries (set)] + [assertions (set)]) - (define (analyze-gestalt g s) - (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])) - (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)))))))) + (on-start (define timer-key (list 'arp interface-name)) + (define (arm-timer!) (send! (set-timer timer-key wakeup-interval 'relative))) + (arm-timer!) + (react (on (message (timer-expired timer-key _)) + (cache (expire-cache (cache))) + (send-questions!) + (arm-timer!)))) - (define (send-questions s) - (define unanswered-queries - (set-subtract (state-queries s) (list->set (hash-keys (state-cache s))))) - (define (some-asserted-pa ptype) - (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) - (set->list (state-assertions s))) - ['() #f] - [(list* k _) (cache-key-address k)])) - (transition s - (for/list [(q (in-set unanswered-queries))] - (define pa (some-asserted-pa (cache-key-protocol q))) - (log-info "~a ARP Asking for ~a from ~a" - interface-name - (pretty-bytes (cache-key-address q)) - (and pa (pretty-bytes pa))) - (when pa - (message (build-packet broadcast-ethernet-address - (cache-key-protocol q) - 1 ;; request - hwaddr - pa - zero-ethernet-address - (cache-key-address q))))))) + (on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype))) + (match-define (ethernet-packet _ _ source destination _ body) p) + (bit-string-case body + ([ (= 1 :: integer bytes 2) + (ptype :: integer bytes 2) + hlen + plen + (oper :: integer bytes 2) + (sender-hardware-address0 :: binary bytes hlen) + (sender-protocol-address0 :: binary bytes plen) + (target-hardware-address0 :: binary bytes hlen) + (target-protocol-address0 :: binary bytes plen) + (:: binary) ;; The extra zeros exist because ethernet packets + ;; have a minimum size. This is, in part, why IPv4 + ;; headers have a total-length field, so that the + ;; zero padding can be removed. + ] + (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)) + (define learned-key (cache-key ptype sender-protocol-address)) - (list (set-wakeup-alarm) - (spawn (lambda (e s) - ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s) - (match e - [(scn g) - (sequence-transitions (analyze-gestalt g s) - send-questions)] - [(message (ethernet-packet _ _ source destination _ body)) - (analyze-incoming-packet source destination body s)] - [(message (timer-expired _ _)) - (define new-s (struct-copy state s - [cache (expire-cache (state-cache s))])) - (sequence-transitions (transition new-s - (list (set-wakeup-alarm) - (compute-gestalt (state-cache new-s)))) - send-questions)] - [_ #f])) - (state (hash) (set) (set)) - (compute-gestalt (hash))))) + (when (and (set-member? (queries) learned-key) ;; it is relevant to our interests + (not (equal? sender-hardware-address + (cache-value-address (hash-ref (cache) + learned-key + (lambda () + (cache-value #f #f #f))))))) + (log-info "~a ARP Adding ~a = ~a to cache" + interface-name + (pretty-bytes sender-protocol-address) + (pretty-bytes sender-hardware-address))) + + (cache (hash-set (expire-cache (cache)) + learned-key + (cache-value (+ (current-inexact-milliseconds) + cache-entry-lifetime-msec) + interface + sender-hardware-address))) + (case oper + [(1) ;; request + (when (set-member? (assertions) (cache-key ptype target-protocol-address)) + (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) (void)] ;; reply + [else (void)]))) + (else #f))) + + (during (arp-assertion $protocol $protocol-address interface-name) + (define a (cache-key protocol protocol-address)) + (on-start (assertions (set-add (assertions) a)) + (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)))) + (on-stop (assertions (set-remove (assertions) a)))) + + (during (observe (arp-query $protocol $protocol-address interface _)) + (define key (cache-key protocol protocol-address)) + (on-start (queries (set-add (queries) key)) + (send-questions!)) + (on-stop (queries (set-remove (queries) key))) + (assert #:when (hash-has-key? (cache) key) + (match (hash-ref (cache) key) + [(cache-value _ ifname addr) + (arp-query protocol protocol-address ifname addr)])))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(spawn-arp-driver) diff --git a/examples/netstack/ethernet.rkt b/examples/netstack/ethernet.rkt index c5ecef9..6391ea7 100644 --- a/examples/netstack/ethernet.rkt +++ b/examples/netstack/ethernet.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang syndicate/actor ;; Ethernet driver (provide (struct-out ethernet-packet) @@ -9,14 +9,11 @@ ethernet-packet-pattern lookup-ethernet-hwaddr) +(require/activate syndicate/drivers/timer) (require racket/set) (require racket/match) (require racket/async-channel) -(require syndicate/monolithic) -(require syndicate/demand-matcher) -(require "on-claim.rkt") - (require packet-socket) (require bitsyntax) @@ -32,52 +29,44 @@ (log-info "Device names: ~a" interface-names) (define (spawn-ethernet-driver) - (spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?)) - (ethernet-interface (?!) ?) - spawn-interface-tap)) + (actor #:name 'ethernet-driver + (react (during/actor + (observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _)) + #:name (list 'ethernet-interface interface-name) -(define (spawn-interface-tap interface-name) - (define h (raw-interface-open interface-name)) - (define interface (ethernet-interface interface-name (raw-interface-hwaddr h))) - (cond - [(not h) - (log-error "ethernet: Couldn't open interface ~v" interface-name) - '()] - [else - (log-info "Opened interface ~a, yielding handle ~v" interface-name h) - (define control-ch (make-async-channel)) - (thread (lambda () (interface-packet-read-loop interface h control-ch))) - (spawn (lambda (e h) - (match e - [(scn g) - (if (trie-empty? g) - (begin (async-channel-put control-ch 'quit) - (quit)) - (begin (async-channel-put control-ch 'unblock) - #f))] - [(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 (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)) - ;; (pretty-bytes (ethernet-packet-destination p)) - ;; (number->string (ethernet-packet-ethertype p) 16)) - ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) - (raw-interface-write h (encode-ethernet-packet p)) - #f] - [_ #f])) - h - (scn/union (assertion interface) - (subscription (ethernet-packet interface #f ? ? ? ?)) - (subscription (observe (ethernet-packet interface #t ? ? ? ?))) - (subscription (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))])) + (define h (raw-interface-open interface-name)) + (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name)) + (log-info "Opened interface ~a, yielding handle ~v" interface-name h) + + (define interface (ethernet-interface interface-name (raw-interface-hwaddr h))) + (assert interface) + + (define control-ch (make-async-channel)) + (thread (lambda () (interface-packet-read-loop interface h control-ch))) + + (on-start (flush!) ;; ensure all subscriptions are in place + (async-channel-put control-ch 'unblock) + (actor #:name (list 'ethernet-interface-quit-monitor interface-name) + (react (on (retracted interface) + (async-channel-put control-ch 'quit))))) + + (on (message ($ p (ethernet-packet interface #t _ _ _ _)) #:meta-level 1) + ;; (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))) + (send! p)) + + (on (message ($ p (ethernet-packet interface #f _ _ _ _))) + ;; (log-info "Interface ~a OUTBOUND 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))) + (raw-interface-write h (encode-ethernet-packet p))))))) (define (interface-packet-read-loop interface h control-ch) (define (blocked) @@ -121,14 +110,16 @@ (define (ethernet-packet-pattern interface-name from-wire? ethertype) (ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?)) -(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 (?!)))) +(define (lookup-ethernet-hwaddr interface-name) + (define timer-id (gensym 'lookup-ethernet-hwaddr)) + (react/suspend (k) + (on-start (send! (set-timer timer-id 5000 'relative))) + (stop-when (message (timer-expired timer-id _)) + (log-info "Lookup of ethernet interface ~v failed" interface-name) + (k #f)) + (stop-when (asserted (ethernet-interface interface-name $hwaddr)) + (k hwaddr)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(spawn-ethernet-driver) diff --git a/examples/netstack/main.rkt b/examples/netstack/main.rkt index 9d694ac..81c63d7 100644 --- a/examples/netstack/main.rkt +++ b/examples/netstack/main.rkt @@ -1,19 +1,17 @@ #lang syndicate/monolithic +(require/activate syndicate/drivers/timer) +(require/activate "ethernet.rkt") +(require/activate "arp.rkt") + (require syndicate/demand-matcher) -(require syndicate/drivers/timer) (require "demo-config.rkt") -(require "ethernet.rkt") -(require "arp.rkt") (require "ip.rkt") (require "tcp.rkt") (require "udp.rkt") ;;(log-events-and-actions? #t) -(spawn-timer-driver) -(spawn-ethernet-driver) -(spawn-arp-driver) (spawn-ip-driver) (spawn-tcp-driver) (spawn-udp-driver)