Comments
This commit is contained in:
parent
eb4910b870
commit
e5c73f9030
|
@ -13,9 +13,19 @@
|
||||||
|
|
||||||
(require racket/struct)
|
(require racket/struct)
|
||||||
|
|
||||||
|
;; Support functions for dealing with IP addresses, subnets, and peers
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(require rackunit))
|
(require rackunit))
|
||||||
|
|
||||||
|
;; An IP is a Nat
|
||||||
|
|
||||||
|
;; A PeerType is one of
|
||||||
|
;; - 'prov
|
||||||
|
;; - 'cust
|
||||||
|
;; - 'peer
|
||||||
|
|
||||||
|
;; A Peer is a (peer IP PeerType)
|
||||||
(struct peer [ip type]
|
(struct peer [ip type]
|
||||||
#:transparent
|
#:transparent
|
||||||
#:methods gen:custom-write
|
#:methods gen:custom-write
|
||||||
|
@ -24,6 +34,7 @@
|
||||||
(lambda (x) 'peer)
|
(lambda (x) 'peer)
|
||||||
(lambda (x) (list (ip->string (peer-ip x)) (peer-type x)))))])
|
(lambda (x) (list (ip->string (peer-ip x)) (peer-type x)))))])
|
||||||
|
|
||||||
|
;; A Subnet is a (subnet IP Nat)
|
||||||
(struct subnet [ip mask]
|
(struct subnet [ip mask]
|
||||||
#:transparent
|
#:transparent
|
||||||
#:methods gen:custom-write
|
#:methods gen:custom-write
|
||||||
|
@ -32,6 +43,8 @@
|
||||||
(lambda (x) 'subnet)
|
(lambda (x) 'subnet)
|
||||||
(lambda (x) (list (subnet->string x)))))])
|
(lambda (x) (list (subnet->string x)))))])
|
||||||
|
|
||||||
|
;; Str -> IP
|
||||||
|
;; Parses the IP address contained in str
|
||||||
(define (string->ip str)
|
(define (string->ip str)
|
||||||
(define parts (reverse (string-split str ".")))
|
(define parts (reverse (string-split str ".")))
|
||||||
(for/sum ([part (in-list parts)]
|
(for/sum ([part (in-list parts)]
|
||||||
|
@ -39,6 +52,8 @@
|
||||||
(arithmetic-shift (string->number part)
|
(arithmetic-shift (string->number part)
|
||||||
(* i 8))))
|
(* i 8))))
|
||||||
|
|
||||||
|
;; IP -> Str
|
||||||
|
;; Serializes the IP address ip to a string
|
||||||
(define (ip->string ip)
|
(define (ip->string ip)
|
||||||
(define parts
|
(define parts
|
||||||
(reverse (for/list ([i (in-range 4)])
|
(reverse (for/list ([i (in-range 4)])
|
||||||
|
@ -46,33 +61,49 @@
|
||||||
255)))))
|
255)))))
|
||||||
(string-join parts "."))
|
(string-join parts "."))
|
||||||
|
|
||||||
|
;; IP -> Nat
|
||||||
|
;; Calculates how many mask bits are set in the given netmask represented as an IP address
|
||||||
|
;; Example: 255.0.0.0 -> 8
|
||||||
(define (ip-netmask ip)
|
(define (ip-netmask ip)
|
||||||
(- 32
|
(- 32
|
||||||
(for/sum ([i (in-range 32)])
|
(for/sum ([i (in-range 32)])
|
||||||
#:break (positive? (bitwise-and ip (arithmetic-shift 1 i)))
|
#:break (positive? (bitwise-and ip (arithmetic-shift 1 i)))
|
||||||
1)))
|
1)))
|
||||||
|
|
||||||
|
;; Nat -> IP
|
||||||
|
;; Creates an IP address representing the given netmask size
|
||||||
|
;; Example: 8 -> 255.0.0.0
|
||||||
(define (netmask-ip mask)
|
(define (netmask-ip mask)
|
||||||
(arithmetic-shift (sub1 (arithmetic-shift 1 mask))
|
(arithmetic-shift (sub1 (arithmetic-shift 1 mask))
|
||||||
(- 32 mask)))
|
(- 32 mask)))
|
||||||
|
|
||||||
|
;; Str -> Subnet
|
||||||
|
;; Parses a subnet from string
|
||||||
(define (string->subnet str)
|
(define (string->subnet str)
|
||||||
(match-define (list ipstr maskstr) (string-split str "/"))
|
(match-define (list ipstr maskstr) (string-split str "/"))
|
||||||
(subnet (string->ip ipstr)
|
(subnet (string->ip ipstr)
|
||||||
(string->number maskstr)))
|
(string->number maskstr)))
|
||||||
|
|
||||||
|
;; Subnet -> Str
|
||||||
|
;; Serializes a subnet to string
|
||||||
(define (subnet->string sub)
|
(define (subnet->string sub)
|
||||||
(format "~a/~a"
|
(format "~a/~a"
|
||||||
(ip->string (subnet-ip sub))
|
(ip->string (subnet-ip sub))
|
||||||
(subnet-mask sub)))
|
(subnet-mask sub)))
|
||||||
|
|
||||||
|
;; Subnet -> [Listof Bool]
|
||||||
|
;; Converts a subnet into a list of booleans representing its bits
|
||||||
(define (subnet->bl sub)
|
(define (subnet->bl sub)
|
||||||
(ip->bl (subnet-ip sub) (subnet-mask sub)))
|
(ip->bl (subnet-ip sub) (subnet-mask sub)))
|
||||||
|
|
||||||
|
;; IP -> [Listof Bool]
|
||||||
|
;; Converts an IP address into a list of booleans representing its bits
|
||||||
(define (ip->bl ip [bits 32])
|
(define (ip->bl ip [bits 32])
|
||||||
(for/list ([i (in-range bits)])
|
(for/list ([i (in-range bits)])
|
||||||
(= 1 (bitwise-and 1 (arithmetic-shift ip (- i 31))))))
|
(= 1 (bitwise-and 1 (arithmetic-shift ip (- i 31))))))
|
||||||
|
|
||||||
|
;; Str -> Peer
|
||||||
|
;; Parses a peer from string
|
||||||
(define (string->peer str)
|
(define (string->peer str)
|
||||||
(match-define (list ip type) (string-split str "-"))
|
(match-define (list ip type) (string-split str "-"))
|
||||||
(peer (string->ip ip) (string->symbol type)))
|
(peer (string->ip ip) (string->symbol type)))
|
||||||
|
|
|
@ -4,6 +4,8 @@
|
||||||
(require json
|
(require json
|
||||||
"iputil.rkt")
|
"iputil.rkt")
|
||||||
|
|
||||||
|
;; Types and helper functions for router messages
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(require rackunit))
|
(require rackunit))
|
||||||
|
|
||||||
|
|
|
@ -4,11 +4,24 @@
|
||||||
|
|
||||||
(provide make-rt rt-update! rt-lookup rt-dump rt-flatten)
|
(provide make-rt rt-update! 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.
|
||||||
|
|
||||||
|
;; An RT is a (rt-node RTedge RTedge Any)
|
||||||
|
;; An RTkey is a [Listof Bool]
|
||||||
|
;; An RTedge is a (rt-edge RTkey RT)
|
||||||
(struct rt-node [edge0 edge1 data] #:transparent #:mutable)
|
(struct rt-node [edge0 edge1 data] #:transparent #:mutable)
|
||||||
|
;; Edge labels always contain all of their bits, even though the first bit is redundant
|
||||||
|
;; (represented by whether this was an edge0 or edge1 in the parent node)
|
||||||
(struct rt-edge [label target] #:transparent)
|
(struct rt-edge [label target] #:transparent)
|
||||||
|
|
||||||
|
;; A unique symbol representing no data associated with a certain node
|
||||||
(define empty-node-data (gensym 'MEOW))
|
(define empty-node-data (gensym 'MEOW))
|
||||||
|
|
||||||
|
;; -> RT
|
||||||
|
;; Creates a new empty RT
|
||||||
(define (make-rt)
|
(define (make-rt)
|
||||||
(rt-node #f #f empty-node-data))
|
(rt-node #f #f empty-node-data))
|
||||||
|
|
||||||
|
@ -16,12 +29,25 @@
|
||||||
(define (rt-getter bit) (if bit rt-node-edge1 rt-node-edge0))
|
(define (rt-getter bit) (if bit rt-node-edge1 rt-node-edge0))
|
||||||
(define (rt-setter bit) (if bit set-rt-node-edge1! set-rt-node-edge0!))
|
(define (rt-setter bit) (if bit set-rt-node-edge1! set-rt-node-edge0!))
|
||||||
|
|
||||||
|
;; RTkey RTkey -> Nat
|
||||||
|
;; Computes the length of the longest common prefix in bl1 and bl2
|
||||||
(define (bl-common-len bl1 bl2)
|
(define (bl-common-len bl1 bl2)
|
||||||
(for/sum ([b1 (in-list bl1)]
|
(for/sum ([b1 (in-list bl1)]
|
||||||
[b2 (in-list bl2)])
|
[b2 (in-list bl2)])
|
||||||
#:break (not (equal? b1 b2))
|
#:break (not (equal? b1 b2))
|
||||||
1))
|
1))
|
||||||
|
|
||||||
|
;; An RTresult is one of
|
||||||
|
;; (list 'exact RT) - An exact match for the given key that landed on the returned RT
|
||||||
|
;; (list 'partial RT RTedge Nat RTkey [Listof RT]) - A partial match stopping at the given
|
||||||
|
;; RT, next partially matched edge, length of partial match, tail of the key not exactly
|
||||||
|
;; matched, and a list of visited nodes ordered by most recent first
|
||||||
|
;; (list 'no-match RT RTkey [Listof RT]) - No match was found, but we stopped at the given
|
||||||
|
;; RT, with tail of the key that did not match, and list of visited nodes ordered by most
|
||||||
|
;; recent first
|
||||||
|
|
||||||
|
;; RT RTkey [[Listof RT]] -> RTresult
|
||||||
|
;; Helper function that performs tree iteration
|
||||||
(define (rt-partial-iterate node key [visited '()])
|
(define (rt-partial-iterate node key [visited '()])
|
||||||
(cond
|
(cond
|
||||||
[(empty? key) (list 'exact node)]
|
[(empty? key) (list 'exact node)]
|
||||||
|
@ -38,6 +64,9 @@
|
||||||
[next-edge (list 'partial node next-edge next-common-len key (cons node visited))]
|
[next-edge (list 'partial node next-edge next-common-len key (cons node visited))]
|
||||||
[else (list 'no-match node 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)
|
(define (rt-update! node key updater failure-result)
|
||||||
(define (insert-node! node key)
|
(define (insert-node! node key)
|
||||||
(let* ([bit (first key)]
|
(let* ([bit (first key)]
|
||||||
|
@ -69,6 +98,9 @@
|
||||||
[(list 'no-match node partial-key visited)
|
[(list 'no-match node partial-key visited)
|
||||||
(insert-node! node partial-key)]))
|
(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 (rt-lookup node key failure-result)
|
||||||
(define (find-first-with-data nodes)
|
(define (find-first-with-data nodes)
|
||||||
(or (for/first ([node (in-list nodes)]
|
(or (for/first ([node (in-list nodes)]
|
||||||
|
@ -82,6 +114,8 @@
|
||||||
[(list _ ... visited)
|
[(list _ ... visited)
|
||||||
visited])))
|
visited])))
|
||||||
|
|
||||||
|
;; RT -> [Listof Any]
|
||||||
|
;; Converts the tree into a flat list of all contained node data
|
||||||
(define (rt-flatten node)
|
(define (rt-flatten node)
|
||||||
(define (flatten-edge e) (if e (rt-flatten (rt-edge-target e)) '()))
|
(define (flatten-edge e) (if e (rt-flatten (rt-edge-target e)) '()))
|
||||||
(let* ([e1 (rt-node-edge0 node)]
|
(let* ([e1 (rt-node-edge0 node)]
|
||||||
|
@ -103,6 +137,9 @@
|
||||||
; (test-insert! "0011")
|
; (test-insert! "0011")
|
||||||
; (test-insert! "0000")
|
; (test-insert! "0000")
|
||||||
|
|
||||||
|
;; RT [Str] ->
|
||||||
|
;; Debug print function that dumps the tree to current-output-port in a vaguely human-readable
|
||||||
|
;; format
|
||||||
(define (rt-dump node [prefix ""])
|
(define (rt-dump node [prefix ""])
|
||||||
(displayln (format "~a node ~a" prefix (rt-node-data node)))
|
(displayln (format "~a node ~a" prefix (rt-node-data node)))
|
||||||
(define edge0 (rt-node-edge0 node))
|
(define edge0 (rt-node-edge0 node))
|
||||||
|
|
28
router
28
router
|
@ -3,6 +3,13 @@
|
||||||
; vim:syntax=racket
|
; vim:syntax=racket
|
||||||
; vim:ft=racket
|
; vim:ft=racket
|
||||||
|
|
||||||
|
; __ __ __
|
||||||
|
; __/ // /_/ /___ _____ ____ _ __ ___ ____ __
|
||||||
|
; /_ _ __/ / __ `/ __ \/ __ `/ / / / / | /| / / / / /
|
||||||
|
; /_ _ __/ / /_/ / / / / /_/ / / /_/ /| |/ |/ / /_/ /
|
||||||
|
; /_//_/ /_/\__,_/_/ /_/\__, / \__,_/ |__/|__/\__,_/
|
||||||
|
; /____/
|
||||||
|
|
||||||
(require json
|
(require json
|
||||||
"private/iputil.rkt"
|
"private/iputil.rkt"
|
||||||
"private/unix-socket.rkt"
|
"private/unix-socket.rkt"
|
||||||
|
@ -23,6 +30,7 @@
|
||||||
(make-rt))
|
(make-rt))
|
||||||
|
|
||||||
;; Router Route Peer -> Void
|
;; Router Route Peer -> Void
|
||||||
|
;; Adds route r from peer to the routing database
|
||||||
(define (router-add! rt r peer)
|
(define (router-add! rt r peer)
|
||||||
(rt-update! rt
|
(rt-update! rt
|
||||||
(subnet->bl (route-subnet r))
|
(subnet->bl (route-subnet r))
|
||||||
|
@ -30,9 +38,12 @@
|
||||||
(lambda () '())))
|
(lambda () '())))
|
||||||
|
|
||||||
;; IP -> IP
|
;; IP -> IP
|
||||||
|
;; Calculates our local IP on the subnet with peer p
|
||||||
(define (peer-ip->own-ip p)
|
(define (peer-ip->own-ip p)
|
||||||
(sub1 p))
|
(sub1 p))
|
||||||
|
|
||||||
|
;; Route Route -> Bool
|
||||||
|
;; Checks if route r1 is "less than"/higher priority than r2 according to the specified rules
|
||||||
(define (route< r1 r2)
|
(define (route< r1 r2)
|
||||||
#|
|
#|
|
||||||
(route< r1 r2) iff "r1 wins"
|
(route< r1 r2) iff "r1 wins"
|
||||||
|
@ -58,6 +69,7 @@
|
||||||
(error "your router is angery...")))
|
(error "your router is angery...")))
|
||||||
|
|
||||||
;; Router IP -> (U Peer #f)
|
;; Router IP -> (U Peer #f)
|
||||||
|
;; Finds the most specific route for the given IP
|
||||||
(define (router-find-best rt src-ip)
|
(define (router-find-best rt src-ip)
|
||||||
(match (sort (rt-lookup rt
|
(match (sort (rt-lookup rt
|
||||||
(ip->bl src-ip)
|
(ip->bl src-ip)
|
||||||
|
@ -68,7 +80,7 @@
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
|
|
||||||
;; Router -> Msg
|
;; Router -> Msg
|
||||||
;; Dumps routing table
|
;; Creates a table message with a dump of the current routing table
|
||||||
(define (router-dump rt src dst)
|
(define (router-dump rt src dst)
|
||||||
(define routing-table (rt-flatten rt))
|
(define routing-table (rt-flatten rt))
|
||||||
(msg:table (peer-ip->own-ip src) src
|
(msg:table (peer-ip->own-ip src) src
|
||||||
|
@ -78,6 +90,9 @@
|
||||||
(route-nexthop (cdr route))))
|
(route-nexthop (cdr route))))
|
||||||
routes)))))
|
routes)))))
|
||||||
|
|
||||||
|
;; Peer Route Int -> Msg
|
||||||
|
;; Creates an update message based on a received update message r that we can forward to other
|
||||||
|
;; routers
|
||||||
(define (router-format-update peer r asn)
|
(define (router-format-update peer r asn)
|
||||||
;; Route -> Route
|
;; Route -> Route
|
||||||
(define (update-aspath r asn)
|
(define (update-aspath r asn)
|
||||||
|
@ -91,6 +106,7 @@
|
||||||
;; --
|
;; --
|
||||||
;; Runs router logic, given a list of peer connections.
|
;; Runs router logic, given a list of peer connections.
|
||||||
(define (run-router/conns asn peer-conns)
|
(define (run-router/conns asn peer-conns)
|
||||||
|
;; This channel collects messages from every peer connection
|
||||||
(define mail
|
(define mail
|
||||||
(make-channel))
|
(make-channel))
|
||||||
|
|
||||||
|
@ -106,11 +122,15 @@
|
||||||
(channel-put mail (list peer msg))
|
(channel-put mail (list peer msg))
|
||||||
(loop))))))
|
(loop))))))
|
||||||
|
|
||||||
|
;; IP -> Peer
|
||||||
|
;; Looks up a peer based on their IP
|
||||||
(define (ip->peer ip)
|
(define (ip->peer ip)
|
||||||
(findf (λ (peer)
|
(findf (λ (peer)
|
||||||
(equal? ip (peer-ip peer)))
|
(equal? ip (peer-ip peer)))
|
||||||
(map peer-conn-info peer-conns)))
|
(map peer-conn-info peer-conns)))
|
||||||
|
|
||||||
|
;; Peer -> Peer-Conn
|
||||||
|
;; Looks up a peer connection based on a peer object
|
||||||
(define (peer->peer-conn peer)
|
(define (peer->peer-conn peer)
|
||||||
(findf (λ (pc)
|
(findf (λ (pc)
|
||||||
(equal? peer (peer-conn-info pc)))
|
(equal? peer (peer-conn-info pc)))
|
||||||
|
@ -120,6 +140,11 @@
|
||||||
(make-router))
|
(make-router))
|
||||||
|
|
||||||
(let loop ()
|
(let loop ()
|
||||||
|
;; Main router loop
|
||||||
|
;; - Get next message
|
||||||
|
;; - Generate some messages to send out, maybe
|
||||||
|
;; - Send out those messages
|
||||||
|
|
||||||
(match-define (list src-peer msg) (channel-get mail))
|
(match-define (list src-peer msg) (channel-get mail))
|
||||||
(printf "====\nfrom ~a:\n~s\n" src-peer msg)
|
(printf "====\nfrom ~a:\n~s\n" src-peer msg)
|
||||||
|
|
||||||
|
@ -180,6 +205,7 @@
|
||||||
sock-in
|
sock-in
|
||||||
sock-out)))))
|
sock-out)))))
|
||||||
|
|
||||||
|
;; Parse command line arguments and start router
|
||||||
(module+ main
|
(module+ main
|
||||||
(command-line
|
(command-line
|
||||||
#:program "router"
|
#:program "router"
|
||||||
|
|
Loading…
Reference in New Issue