diff --git a/arp.rkt b/arp.rkt index a6ab180..1b0cff6 100644 --- a/arp.rkt +++ b/arp.rkt @@ -78,7 +78,7 @@ (cache-value-interface v) (cache-value-address v))))))) - (define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa) + (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)) (define packet (bit-string->bytes @@ -118,12 +118,19 @@ (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 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)) - (cache-key ptype sender-protocol-address) + learned-key (cache-value (+ (current-inexact-milliseconds) cache-entry-lifetime-msec) interface @@ -135,8 +142,7 @@ [(1) ;; request (if (set-member? (state-assertions s) (cache-key ptype target-protocol-address)) - (send (build-packet s - sender-hardware-address + (send (build-packet sender-hardware-address ptype 2 ;; reply hwaddr @@ -162,51 +168,19 @@ (cache-key ptype pa))) (define (analyze-gestalt g s) - (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 [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)) - ['() #f] - [(list* k _) (cache-key-address k)])) - ;; (log-info "analyze-gestalt: g:\n~a" (gestalt->pretty-string g)) - ;; (log-info "analyze-gestalt: new-queries ~v" new-queries) - ;; (log-info "analyze-gestalt: new-assertions ~v" new-assertions) - ;; (log-info "analyze-gestalt: added-queries ~v" added-queries) - ;; (log-info "analyze-gestalt: added-assertions ~v" added-assertions) - ;; (log-info "analyze-gestalt: unanswered-queries ~v" unanswered-queries) - ;; (log-info "analyze-gestalt: new-s ~v" new-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 [(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))) - (if pa - (send (build-packet new-s - broadcast-ethernet-address - (cache-key-protocol q) - 1 ;; request - hwaddr - pa - zero-ethernet-address - (cache-key-address q))) - '())) (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 + (send (build-packet broadcast-ethernet-address (cache-key-protocol a) 2 ;; reply -- gratuitous announcement hwaddr @@ -214,20 +188,47 @@ hwaddr (cache-key-address a))))))) + (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 + (send (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) - (analyze-gestalt g s)] + (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))])) - (transition new-s - (list (set-wakeup-alarm) - (routing-update (compute-gestalt (state-cache new-s)))))] + (define new-g (compute-gestalt (state-cache new-s))) + (sequence-transitions (transition new-s + (list (set-wakeup-alarm) + (routing-update new-g))) + send-questions)] [_ #f])) (state (hash) (set) (set)) (compute-gestalt (hash)))))