diff --git a/private/radix-tree.rkt b/private/radix-tree.rkt index 31daf9f..c0b1fad 100644 --- a/private/radix-tree.rkt +++ b/private/radix-tree.rkt @@ -2,14 +2,13 @@ (require "iputil.rkt") -(provide make-rt rt-update! rt-lookup rt-dump rt-flatten) +(provide make-rt rt-add! rt-del! rt-lookup rt-dump rt-flatten) ;; Radix tree implementation for efficient routing lookups ;; This module provides a radix tree type indexed by bit-lists (lists of booleans representing IP -;; address bits), which supports arbitary node data at any tree depth. Lookup always find the most -;; specific match. +;; address bits), which supports arbitary node data at any tree depth. Lookup finds all the matches. -;; An RT is a (rt-node RTedge RTedge Any) +;; An RT is a (rt-node RTedge RTedge [Listof Any]) ;; An RTkey is a [Listof Bool] ;; An RTedge is a (rt-edge RTkey RT) (struct rt-node [edge0 edge1 data] #:transparent #:mutable) @@ -17,13 +16,10 @@ ;; (represented by whether this was an edge0 or edge1 in the parent node) (struct rt-edge [label target] #:transparent) -;; A unique symbol representing no data associated with a certain node -(define empty-node-data '()) ;(gensym 'MEOW) - ;; -> RT ;; Creates a new empty RT (define (make-rt) - (rt-node #f #f empty-node-data)) + (rt-node #f #f '())) ;; Helper functions for rt-node struct access based on whether the edge is 1 or 0 (define (rt-getter bit) (if bit rt-node-edge1 rt-node-edge0)) @@ -64,14 +60,13 @@ [next-edge (list 'partial node next-edge next-common-len key (cons node visited))] [else (list 'no-match node key (cons node visited))]))])) -;; RT RTkey (Any -> Any) (-> Any) -;; Updates the radix tree for the given key, using updater and failure-result like the standard -;; racket -update! abstraction -(define (rt-update! node key updater failure-result) +;; RT RTkey Any -> Void +;; Updates the radix tree for the given key, adding the elem to the data at that key. +(define (rt-add! node key elem) (define (insert-node! node key) (let* ([bit (first key)] [setter! (rt-setter bit)]) - (setter! node (rt-edge key (rt-node #f #f (updater (failure-result))))))) + (setter! node (rt-edge key (rt-node #f #f (list elem)))))) (define (split-node! node key orig-edge prefix-len) (let* ([bit (first key)] [setter! (rt-setter bit)] @@ -82,54 +77,52 @@ (let* ([next-bit (list-ref orig-label prefix-len)] [common-node (rt-node (if next-bit #f new-orig-edge) (if next-bit new-orig-edge #f) - (updater (failure-result)))] + (list elem))] [common-edge (rt-edge (take key prefix-len) common-node)]) (setter! node common-edge)) (let* ([new-insert-edge (rt-edge (drop key prefix-len) - (rt-node #f #f (updater (failure-result))))] + (rt-node #f #f (list elem)))] [diff-bit (list-ref key prefix-len)] [common-node (rt-node (if diff-bit new-orig-edge new-insert-edge) (if diff-bit new-insert-edge new-orig-edge) - empty-node-data)] + '())] [common-edge (rt-edge (take key prefix-len) common-node)]) (setter! node common-edge))))) (match (rt-partial-iterate node key) [(list 'exact node) - (set-rt-node-data! - node - (let ([d (rt-node-data node)]) - (updater - (if (eq? d empty-node-data) (failure-result) d))))] + (set-rt-node-data! node + (cons elem (rt-node-data node)))] [(list 'partial node orig-edge prefix-len partial-key visited) (split-node! node partial-key orig-edge prefix-len)] [(list 'no-match node partial-key visited) (insert-node! node partial-key)])) -;; RT RTkey (-> Any) -> Any -;; Looks up the most specific match for the given key in the tree, using failure-result if nothing -;; was found -(define (rt-lookup node key failure-result) - (define (find-first-with-data nodes) - (or (for/first ([node (in-list nodes)] - #:when (not (eq? empty-node-data (rt-node-data node)))) - (rt-node-data node)) - (failure-result))) - (find-first-with-data - (match (rt-partial-iterate node key) - [(list 'exact node) - (list node)] - [(list _ ... visited) - visited]))) +;; RT RTKey (Any -> Boolean) -> Void +;; Delete all entries under the given key +(define (rt-del! node key del?) + (for ([node (in-list (match (rt-partial-iterate node key) + [(list 'exact node) (list node)] + [(list _ ... visited) visited]))]) + (set-rt-node-data! node + (filter (negate del?) + (rt-node-data node))))) + +;; RT RTkey -> [Listof Any] +;; Looks up all the matches for the given key in the tree, ordered from most-specific to +;; least-specific. +(define (rt-lookup node key) + (match (rt-partial-iterate node key) + [(list 'exact node) (rt-node-data node)] + [(list _ ... visited) (append-map rt-node-data visited)])) ;; RT -> [Listof Any] ;; Converts the tree into a flat list of all contained node data (define (rt-flatten node) - (define (flatten-edge e) (if e (rt-flatten (rt-edge-target e)) '())) - (let* ([e1 (rt-node-edge0 node)] - [e2 (rt-node-edge1 node)] - [data (rt-node-data node)] - [rst (apply append (map flatten-edge (list e1 e2)))]) - (if (equal? data empty-node-data) rst (cons data rst)))) + (define (flatten-edge e) + (if e (rt-flatten (rt-edge-target e)) '())) + (append (rt-node-data node) + (flatten-edge (rt-node-edge0 node)) + (flatten-edge (rt-node-edge1 node)))) ;; RT [Str] -> ;; Debug print function that dumps the tree to current-output-port in a vaguely human-readable @@ -145,27 +138,30 @@ (displayln (format "~a edge1 ~a" prefix (rt-edge-label edge1))) (rt-dump (rt-edge-target edge1) (string-append prefix " ")))) -(define test (make-rt)) -(define (str->bl x) - (map (curry equal? #\1) (string->list x))) -(define (test-insert! x) - (rt-update! - test - (str->bl x) - (lambda (_) x) - (lambda () x))) -; (test-insert! "0001") -; (test-insert! "") -; (rt-dump test) -; (test-insert! "0001") -; (test-insert! "000") -; (test-insert! "0") -; (rt-dump test) -; (rt-partial-iterate test (str->bl "0001")) -; (rt-lookup test (str->bl "0000") (lambda () (error "bad"))) -; (test-insert! "0001") -; (test-insert! "1000") -; (test-insert! "1010") -; (test-insert! "0011") -; (test-insert! "0000") +(module+ test + + (define (str->bl x) + (map (curry equal? #\1) (string->list x))) + + (define test (make-rt)) + + (define (test-insert! x) + (rt-add! test (str->bl x) x)) + + (test-insert! "0001") + (test-insert! "") + (rt-dump test) + (test-insert! "0001") + (test-insert! "000") + (test-insert! "0") + (rt-dump test) + (rt-partial-iterate test (str->bl "0001")) + (rt-lookup test (str->bl "0000")) + + ; (test-insert! "0001") + ; (test-insert! "1000") + ; (test-insert! "1010") + ; (test-insert! "0011") + ; (test-insert! "0000") + ) diff --git a/router b/router index a0b91e0..9fdb9e6 100755 --- a/router +++ b/router @@ -34,30 +34,25 @@ (define flipped-net (subnet-flip-last (route-subnet r))) (define flipped-bl (subnet->bl flipped-net)) (define flipped-route (struct-copy route r [subnet flipped-net])) - (define aggregate-route (rt-lookup rt flipped-bl (lambda () '()))) (cond - [(member (cons peer flipped-route) aggregate-route) - (define new-aggregate-route (remove (cons peer flipped-route) aggregate-route)) - (rt-update! rt flipped-bl (lambda (_) new-aggregate-route) (lambda () '())) - (router-add! rt (struct-copy route r [subnet (subnet-drop-last (route-subnet r))]) peer)] - [else (rt-update! rt - (subnet->bl (route-subnet r)) - (lambda (rst) (cons (cons peer r) rst)) - (lambda () '()))])) + [(member (cons peer flipped-route) + (rt-lookup rt flipped-bl)) + (define r* (struct-copy route r [subnet (subnet-drop-last (route-subnet r))])) + (rt-del! rt flipped-bl (curry equal? (cons peer flipped-route))) + (router-add! rt r* peer)] + [else + (rt-add! rt + (subnet->bl (route-subnet r)) + (cons peer r))])) ;; Router Route Peer -> Void ;; Tries to find the given route and removes it from the routing database (define (router-revoke! rt subnet peer) - ;; [Listof [Cons Peer Route]] -> [Listof [Cons Peer Route]] - ;; Removes route r from the given list, if present - (define (remove-route routes) - (filter (lambda (el) (not (and (equal? (car el) peer) - (equal? (route-subnet (cdr el)) subnet)))) - routes)) - (rt-update! rt - (subnet->bl subnet) - (lambda (lst) (remove-route lst)) - (lambda () '()))) + (rt-del! rt + (subnet->bl subnet) + (lambda (el) + (and (equal? (car el) peer) + (equal? (route-subnet (cdr el)) subnet))))) ;; IP -> IP ;; Calculates our local IP on the subnet with peer p @@ -83,6 +78,7 @@ [y2 (mapper r2)]) (cond [(< x2 y2) (meow #t)] [(> x2 y2) (meow #f)]))) + (cmp (compose - subnet-mask route-subnet)) (cmp (compose - route-pref)) (cmp (lambda (x) (if (route-self-origin? x) 0 1))) (cmp (compose length route-as-path)) @@ -93,24 +89,19 @@ ;; Router IP -> (U Peer #f) ;; Finds the most specific route for the given IP (define (router-find-best rt src-ip) - (match (sort (rt-lookup rt - (ip->bl src-ip) - (λ () '())) - route< - #:key cdr) + (match (sort (rt-lookup rt (ip->bl src-ip)) + route< + #:key cdr) [(list* (cons peer _) _) peer] [_ #f])) ;; Router -> Msg ;; Creates a table message with a dump of the current routing table (define (router-dump rt src dst) - (define routing-table (rt-flatten rt)) (msg:table (peer-ip->own-ip src) src - (for/fold ([entries '()]) ([routes (in-list routing-table)]) - (append entries (map (lambda (route) - (list (route-subnet (cdr route)) - (route-nexthop (cdr route)))) - routes))))) + (for/list ([el (in-list (rt-flatten rt))]) + (list (route-subnet (cdr el)) + (route-nexthop (cdr el)))))) ;; Peer Route Int -> Msg ;; Creates an update message based on a received update message r that we can forward to other