286 lines
9.6 KiB
Racket
Executable File
286 lines
9.6 KiB
Racket
Executable File
#!/usr/bin/env racket
|
|
#lang racket
|
|
; vim:ft=racket
|
|
|
|
; __ __ __
|
|
; __/ // /_/ /___ _____ ____ _ __ ___ ____ __
|
|
; /_ _ __/ / __ `/ __ \/ __ `/ / / / / | /| / / / / /
|
|
; /_ _ __/ / /_/ / / / / /_/ / / /_/ /| |/ |/ / /_/ /
|
|
; /_//_/ /_/\__,_/_/ /_/\__, / \__,_/ |__/|__/\__,_/
|
|
; /____/
|
|
|
|
(require "private/iputil.rkt"
|
|
"private/unix-socket.rkt"
|
|
"private/msg.rkt"
|
|
"private/radix-tree.rkt")
|
|
|
|
;; info : Peer
|
|
;; sock-in : Input-Port
|
|
;; sock-out : Output-Port
|
|
(struct peer-conn
|
|
[info sock-in sock-out]
|
|
#:transparent)
|
|
|
|
;; a Router is a [RTof [Listof [Cons Peer Route]]]
|
|
|
|
;; -> Router
|
|
(define (make-router)
|
|
(make-rt))
|
|
|
|
;; Router Route Peer -> Void
|
|
;; Adds route r from peer to the routing database
|
|
;; Aggregates routes according to the aggregation rules
|
|
(define (router-add! rt r peer)
|
|
(define flipped-net (subnet-flip-last (route-subnet r)))
|
|
(define flipped-bl (subnet->bl flipped-net))
|
|
(define flipped-route (route-update-subnet r flipped-net))
|
|
(cond
|
|
[(member (cons peer flipped-route)
|
|
(rt-lookup rt flipped-bl))
|
|
(define r* (route-update-subnet r (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)
|
|
(define sub-bl (subnet->bl subnet))
|
|
(define existing (filter (compose (curry equal? peer) car) (rt-lookup rt sub-bl)))
|
|
(match existing
|
|
;; disaggregation is necessary
|
|
[(cons fst _) #:when (not (equal? subnet (route-subnet (cdr fst))))
|
|
;; figure out how to disaggregate
|
|
(define agg-route (cdr fst))
|
|
(define new-subs (subnet-disaggregate (route-subnet agg-route) subnet))
|
|
;; delete agg route
|
|
(rt-del! rt
|
|
(subnet->bl (route-subnet agg-route))
|
|
(lambda (el) (equal? el (cons peer agg-route))))
|
|
;; add new parts
|
|
(for ([sub (in-list new-subs)])
|
|
(rt-add! rt (subnet->bl sub)
|
|
(cons peer (route-update-subnet agg-route sub))))]
|
|
;; normal delete
|
|
[_ (rt-del! rt
|
|
sub-bl
|
|
(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
|
|
(define (peer-ip->own-ip p)
|
|
(sub1 p))
|
|
|
|
;; Route Subnet -> Route
|
|
;; Changes the subnet for a route data object
|
|
(define (route-update-subnet r s)
|
|
(struct-copy route r [subnet s]))
|
|
|
|
;; Route Route -> Bool
|
|
;; Checks if route r1 is "less than"/higher priority than r2 according to the specified rules
|
|
(define (route< r1 r2)
|
|
#|
|
|
(route< r1 r2) iff "r1 wins"
|
|
|
|
1. The path with the highest "localpref" wins. If the "localpref"s are equal...
|
|
2. The path with "selfOrigin" = true wins. If all selfOrigins are the equal...
|
|
3. The path with the shortest "ASPath" wins. If multiple routes have the shortest length...
|
|
4. The path with the best "origin" wins, were IGP > EGP > UNK.
|
|
If multiple routes have the best origin...
|
|
5. The path from the neighbor router with the lowest IP address.
|
|
|#
|
|
(let/ec meow
|
|
(define (cmp mapper)
|
|
(let ([x2 (mapper r1)]
|
|
[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))
|
|
(cmp (lambda (x) (match (route-origin x) ['IGP 1] ['EGP 2] ['UNK 3])))
|
|
(cmp route-nexthop)
|
|
(error "your router is angery...")))
|
|
|
|
;; 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)
|
|
[(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)
|
|
(msg:table (peer-ip->own-ip src) src
|
|
(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
|
|
;; routers
|
|
(define (router-format-update peer r asn)
|
|
;; Route -> Route
|
|
(define (update-aspath r asn)
|
|
(struct-copy route r [as-path (append (route-as-path r) (list asn))]))
|
|
(msg:update
|
|
(peer-ip->own-ip (peer-ip peer))
|
|
(peer-ip peer)
|
|
(update-aspath r asn)))
|
|
|
|
;; Peer Peer -> Bool
|
|
;; Checks if we should send a route update from the given src peer to the dst peer
|
|
(define (router-should-update? src-peer dst-peer)
|
|
(match (peer-type src-peer)
|
|
['cust #t]
|
|
[_ (symbol=? 'cust (peer-type dst-peer))]))
|
|
|
|
;; Int [Listof Peer-Conn] -> Void
|
|
;; --
|
|
;; Runs router logic, given a list of peer connections.
|
|
(define (run-router/conns asn peer-conns)
|
|
;; This channel collects messages from every peer connection
|
|
(define mail
|
|
(make-channel))
|
|
|
|
(define peer-threads
|
|
(for/list ([pc (in-list peer-conns)])
|
|
(match-define (peer-conn peer sock-in sock-out) pc)
|
|
(thread (λ ()
|
|
(define buf (make-bytes 65536))
|
|
(let loop ()
|
|
(define len (read-bytes-avail! buf sock-in))
|
|
(printf "got ~a bytes from ~a...\n" len peer)
|
|
(define msg (bytes->msg (subbytes buf 0 len)))
|
|
(channel-put mail (list peer msg))
|
|
(loop))))))
|
|
|
|
;; IP -> Peer
|
|
;; Looks up a peer based on their IP
|
|
(define (ip->peer ip)
|
|
(findf (λ (peer)
|
|
(equal? ip (peer-ip peer)))
|
|
(map peer-conn-info peer-conns)))
|
|
|
|
;; Peer -> Peer-Conn
|
|
;; Looks up a peer connection based on a peer object
|
|
(define (peer->peer-conn peer)
|
|
(findf (λ (pc)
|
|
(equal? peer (peer-conn-info pc)))
|
|
peer-conns))
|
|
|
|
(define router
|
|
(make-router))
|
|
|
|
(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))
|
|
(printf "====\nfrom ~a:\n~s\n" src-peer msg)
|
|
|
|
;; [Listof [Cons Peer-Conn Msg]]
|
|
(define to-send
|
|
(match msg
|
|
|
|
[(msg:update src dst r)
|
|
(router-add! router
|
|
r
|
|
(ip->peer src))
|
|
(rt-dump router)
|
|
(for/list ([pc (in-list peer-conns)]
|
|
#:when (not (eq? (peer-conn-info pc) src-peer))
|
|
#:when (router-should-update? src-peer (peer-conn-info pc)))
|
|
(cons pc (router-format-update (peer-conn-info pc) r asn)))]
|
|
|
|
[(msg:revoke src dst networks)
|
|
(for ([net (in-list networks)]) (router-revoke! router net (ip->peer src)))
|
|
(rt-dump router)
|
|
(for/list ([pc (in-list peer-conns)]
|
|
#:when (not (eq? (peer-conn-info pc) src-peer))
|
|
#:when (router-should-update? src-peer (peer-conn-info pc)))
|
|
(let ([pip (peer-ip (peer-conn-info pc))])
|
|
(cons pc (msg:revoke (peer-ip->own-ip pip) pip networks))))]
|
|
|
|
[(msg:data src dst data)
|
|
(match (router-find-best router dst)
|
|
[(? peer? dst-peer) #:when (ormap (compose (curry symbol=? 'cust) peer-type)
|
|
(list dst-peer src-peer))
|
|
(list (cons (peer->peer-conn dst-peer)
|
|
msg))]
|
|
[_
|
|
(list (cons (peer->peer-conn src-peer)
|
|
(msg:no-route (peer-ip->own-ip (peer-ip src-peer))
|
|
src)))])]
|
|
[(msg:dump src dst)
|
|
(list (cons (peer->peer-conn src-peer) (router-dump router src dst)))]
|
|
[_
|
|
(printf "----\nignored\n")
|
|
'()]))
|
|
|
|
(for ([dst+msg (in-list to-send)])
|
|
(match-define (cons dst-peer-conn resp-msg) dst+msg)
|
|
(printf "----\nwant to send to ~a:\n~a\n"
|
|
(peer-conn-info dst-peer-conn)
|
|
resp-msg)
|
|
(define dst-port
|
|
(peer-conn-sock-out dst-peer-conn))
|
|
(write-bytes (msg->bytes resp-msg) dst-port)
|
|
(flush-output dst-port))
|
|
|
|
(loop)))
|
|
|
|
;; Int [Listof Peer] ->
|
|
;; Router main
|
|
(define (run-router asn peers)
|
|
(displayln asn)
|
|
(map displayln peers)
|
|
(displayln "------------")
|
|
(with-handlers ([exn:break? (λ (e) (printf "time to die.\n"))])
|
|
(run-router/conns
|
|
asn
|
|
(for/list ([peer (in-list peers)])
|
|
(define-values [sock-in sock-out]
|
|
(unix-socket-connect (ip->string (peer-ip peer))
|
|
'SOCK-SEQPACKET))
|
|
(peer-conn peer
|
|
sock-in
|
|
sock-out)))))
|
|
|
|
;; Parse command line arguments and start router
|
|
(module+ main
|
|
(command-line
|
|
#:program "router"
|
|
#:args
|
|
(asn . peers)
|
|
(with-output-to-file "log.txt"
|
|
#:exists 'replace
|
|
(λ ()
|
|
;; Run the router
|
|
(run-router (string->number asn) (map string->peer peers))))))
|
|
|
|
(module+ test
|
|
|
|
(define-values [in1 out1] (make-pipe))
|
|
(define-values [in2 out2] (make-pipe))
|
|
(define p1 (peer-conn (string->peer "1.2.3.4-cust") in1 out1))
|
|
(define p2 (peer-conn (string->peer "1.2.3.5-peer") in2 out2))
|
|
|
|
; (define abort-router
|
|
(run-router/conns "123"
|
|
(list p1 p2))
|
|
|
|
(void
|
|
(write-string "{\"a\": 1, \"b\": [1,2,3]}" out1)))
|