(* Copyright 2004 Lodewijk Voge / Stichting Wireless Leiden,
 *                All Rights Reserved.
 * License: http://www.wirelessleiden.nl/LICENSE. *)

(*
  \abstract{This program calculates static routing tables for all nodes in the
  WirelessLeiden network. Note that this is not generic because O'Caml
  doesn't have unsigned integers and upgrading to int64's is not at all
  transparant. The high byte of addresses are actually filtered out and
  assumed to be 172!}
 *)
open Pxp_yacc
open Pxp_types

(*s Declarations *)
(* The cost of unconnected nodes. This should be infinite, but the asp routine
   will add two weights together, so it must be less than half of max\_int or
   that addition will overflow *)
let maxWT = (max_int / 2) - 1

(* A netblock is an address and a netmask. The address is a simple 4-byte
   integer, with the high-byte assumed to be 172 because of the lack of
   unsigned integers. The netmask is simply the number of 1 bits from the
   left, a mask of /24 is simply 24 here. *)
type netblock = {
	address: int;
	netmask: int
}

(* A route is a netblock and a gateway. The gateway's high-byte is again fixed
   to 172 *)
type route = {
	dest: netblock;
	gw: int;
}

(* An endpoint is an IP address and a list of "directly" connected peers. The
   list of peers is mutable because that gets filled only after all the 
   endpoints have been parsed. *)
type endpoint = {
	endpoint_block: netblock;
	weight: int;
	mutable peers: (endpoint ref) list
}

(* Finally, a node is a name and a list of endpoints. *)
type node = {
	nodename: string;
	endpoints: endpoint list;
}

(*s WirelessLeiden assumptions *)
(* This stuff is full of assumptions that are true for WirelessLeiden but
   probably not true for any other setting. *)
 
(* Is the given address of a proxy or a node connected directly to a proxy?
   In wleiden, these are all in 172.31.255.1/24 *)
let is_proxy a = a > ((31 lsl 16) + (255 lsl 8))

(* Interlinks in wleiden have the second byte set to 16 *)
let is_no_interlink b = ((b.address lsr 16) land 255) != 16

(* The largest possible route that can come out of all this is a /12. *)
let largest_mask = 12

(* A list of prefixes of node names to skip *)
let skip_prefixes = [
		"demo";
		"proxy";
		"test";
		"vuilnis";
	]

(*s Functions *)

(* Mask the address a with the netmask m to give the network address. *)
let mask m a =
	let foo = lnot (1 lsl 24) - ((1 lsl (32 - m)) - 1) in
	a land foo

(* Two blocks are the same if they are the same when masked. *)
let cmp_blocks b1 b2 = 
	let m1 = mask b1.netmask b1.address in
	let m2 = mask b2.netmask b2.address in
	(mask b1.netmask b1.address) == (mask b2.netmask b2.address)

(* Return the position of element $e$ in list $l$. There has to be a builtin
   that does this, but I couldn't find it. *)
let rec pos_list l e = 
	if List.length l == 0 then raise Not_found
	else if List.hd l == e then 0
	else 1 + pos_list (List.tl l) e

(* Return the position of element $e$ in array $a$ *)
let rec pos_array a e = 
	let found = ref false in
	let i = ref 0 in
	let l = Array.length a in
	while not !found do
	  if !i == l then raise Not_found
	  else begin
	    found := a.(!i) = e;
	    incr i
	  end
	done;
	!i - 1

(* Make the given address human-readable. *)
let showaddr a = 
	let p x = (a lsr x) land 0xff in
	"172." ^
	string_of_int (p 16) ^ "." ^
	string_of_int (p 8) ^ "." ^
	string_of_int (p 0)

(* Make the given netblock human-readable. *)
let showblock b = showaddr b.address ^ "/" ^ string_of_int b.netmask

(* Get the peer address that should be used to go from node $n1$ to node $n2$.
   IOW, get the address of $n2$'s endpoint that ties to one of $n1$'s
   endpoints. *)
let get_peer_point n1 n2 =
	let all_n1_peers = List.concat (List.map (fun e -> e.peers) n1.endpoints) in
	List.find (fun e ->
		List.exists (fun e' -> e.endpoint_block == !e'.endpoint_block) all_n1_peers
	) n2.endpoints

(* Endpoints are equal if their netblocks are equal. *)
let cmp_endpoints a b = a.endpoint_block = b.endpoint_block

(*s The core algorithm *)
(* For the given array of nodes, set things up for a run of All-pairs Shortest
   Paths, and then do it. *)
let asp nodes =
	let all_endpoints = Array.concat (
			      Array.to_list (
			        Array.map (fun n ->
				  Array.of_list n.endpoints) nodes)) in
	let is_not_proxy = fun e -> not (is_proxy e.endpoint_block.address) in

(* Tie together the peers. Don't tie together proxy subnets, they're strange in
   that all proxy's in the network are aliased to 172.31.255.1 and the directly
   connected nodes are aliased into that subnet as well. Two machines in the
   same subnet are only peers if it isn't a proxy subnet. *)
	let l = Array.length all_endpoints in
	for i = 0 to l - 1 do
	  let e = all_endpoints.(i) in
	  for j = i to l - 1 do
	    let e' = all_endpoints.(j) in
	      if is_not_proxy e && is_not_proxy e' &&
	         cmp_blocks e.endpoint_block e'.endpoint_block then begin
		e.peers <- (ref e')::e.peers;
		e'.peers <- (ref e)::e'.peers
	      end
	  done
	done;

(* Now construct an adjacency matrix and mark directly connected nodes
   with the proper weights. *)
	let l = Array.length nodes in
	let adj = Array.make_matrix l l maxWT in
	for i = 0 to l - 1 do
	  let n1 = nodes.(i) in
	  for j = i to l - 1 do
	    try
	        let n2 = nodes.(j) in
	    	let weight = (get_peer_point n1 n2).weight in
	        adj.(i).(j) <- weight;
	        adj.(j).(i) <- weight;
	    with Not_found -> ()
	  done
	done;
	  
(* This is Floyd's algorithm for all-pairs shortest paths
   code transcribed from Algorithms in C, 3rd edition
     by Sedgewick.
   
   $d$ is the distance matrix. $d.(i).(j)$ is the shortest distance
   currently found between the node with index $i$ and the node
   with index $j$.
   
   $p$ is the matrix in which next-hop information will accumulate.
   at the end of the algorithm, $p.(i).(j)$ will be the next hop
   to take when going from $i$ to $j$. This is the final result of
   this whole routine.
   *)
	let l = Array.length adj in
	let d = Array.make_matrix l l maxWT in
	let p = Array.make_matrix l l l in
	for s = 0 to l - 1 do 
	  for t = 0 to l - 1 do
	    d.(s).(t) <- adj.(s).(t);
	    if d.(s).(t) < maxWT then
	      p.(s).(t) <- t
	  done
	done;
	for i = 0 to l - 1 do
	  for s = 0 to l - 1 do
	    if d.(s).(i) < maxWT then begin
	      for t = 0 to l - 1 do
	        if d.(s).(t) > d.(s).(i) + d.(i).(t) then begin
		  p.(s).(t) <- p.(s).(i);
		  d.(s).(t) <- d.(s).(i) + d.(i).(t)
		end
	      done
	    end
	  done
	done;

(* At this point $p$ is a matrix with on $p.(i).(j)$ the index of the
   gateway to use to get from the node with index $i$ to the node with
   index $j$. If there is no such route, $p.(i).(j)$ will be out of
   bounds, which subsequent code can check for. *)
	p

(*s Route aggregation *)

(* Does $b1$ include the whole of $b2$? *)
let includes b1 b2 = 
	(b1.netmask < b2.netmask) &&
	  (mask b1.netmask b1.address = mask b1.netmask b2.address)

(* Given a list of routes to process and a list of routes already processed,
   try to clump together as many routes as possible.

\begin{verbatim}
   Take the first route on the todo list:
     Expand the netmask by one bit.
     Check if it gobbles up any routes to different gateways.
       If so, move the route to the done list and recurse
       If not, remove all routes now covered by the newly expanded route from
         the todo list and recurse
\end{verbatim} *)
let rec aggregate todo done_ =
	match todo with
	  []		-> done_
	| r :: rs	->
		if r.dest.netmask == largest_mask then
		  (r::rs)@done_
		else begin
		  let d' = { r.dest with netmask = (r.dest.netmask - 1) } in
		  let r' = { r with dest = d' } in
		  let f = fun t -> t.gw != r.gw && 
				   includes r'.dest t.dest in
		    if List.exists f (rs@done_) then
		  	  aggregate rs (r::done_)
		    else let rs' = List.filter (fun t -> not (includes r'.dest t.dest)) rs in
		  	  aggregate (r'::rs') done_
		end

(*s Input parsing. See http://www.ocaml-programming.de/packages/documentation/pxp/manual/ *)

(* Convenience function. Iterate over domnode's subnodes that are elements
   with the given elementname and call f for each one *)
let domiter domnode elementname f = domnode#iter_nodes (fun n ->
	match n#nodetype with
	  Pxp_document.T_element elementname -> f n;
	| _ -> ())

class warner = object
	method warn w = print_endline ("WARNING: " ^ w)
end

(* Split string $s$ along delimiter $d$ and return a list of pieces. *)
let rec split d s =
	try
		let pos = String.index s d in
		let piece = String.sub s 0 pos in
		let rest = String.sub s (pos + 1) ((String.length s) - pos - 1) in
		piece::(split d rest)
	with Not_found -> 
		[ s ]

let parse_addr s =
	let a = List.nth (List.map int_of_string (split '.' s)) in
	((*(a 0) lsl 24 +*) (* READ NOTE AT TOP *)
	 (a 1) lsl 16 +
	 (a 2) lsl 8 +
	 (a 3) lsl 0)

let parse_node n =
	let nodename = n#required_string_attribute "name" in
	let ethernets = List.map (fun e -> e#required_string_attribute "iface")
				 (Pxp_document.find_all_elements "ethernet" n) in
	let wireless = List.map (fun e -> e#required_string_attribute "iface")
				(Pxp_document.find_all_elements "wireless" n) in
	let weight iface = if List.exists ((==) iface) ethernets then 1
			   else 100 in
	let links = Pxp_document.find_all_elements "link" n in
	let endpoints = List.map (fun l ->
		let iface = l#required_string_attribute "iface" in
		let mask = int_of_string (l#required_string_attribute "mask") in
		let ip = l#required_string_attribute "ip" in
		{ endpoint_block = { address = parse_addr ip;
				     netmask = mask };
		  weight = weight iface;
		  peers = []}) links in
	let cmp_endpoints e1 e2 = compare e1.endpoint_block.address
					  e2.endpoint_block.address in
	{ nodename = nodename; endpoints = List.sort cmp_endpoints endpoints }

let parse skipfunc fname = 
	try
		let config = { default_config with warner = new warner } in
		let d = parse_document_entity config (from_file fname)
					      default_spec in
		let nodes = ref [] in
		d#root#iter_nodes (fun n ->
			match n#node_type with
			  Pxp_document.T_element "node" ->
			    if not (skipfunc n) then
			      nodes := (parse_node n)::(!nodes);
			| _ -> ());
		!nodes
	with e ->
		print_endline (Pxp_types.string_of_exn e);
		[]

let has_prefix s p = 
	let len = String.length p in
	if String.length s < len then false
	else begin
		let s' = String.sub s 0 len in
		p = s'
	end

let skip node = 
	let nodename = node#required_string_attribute "name" in
	let status = node#required_string_attribute "status" in
	List.exists (fun p -> has_prefix nodename p) skip_prefixes ||
	status <> "up"

(*s Output *)

(* Print all routes for all nodes. *)
let dump nodes gws =
	let l = Array.length nodes in

(* For all nodes *)
	for i = 0 to l - 1 do
	  let node = nodes.(i) in
	  print_string (node.nodename ^ ":\n");

(* Generate routes to all other nodes *)
	  let routes = ref [] in
	  for j = 0 to l - 1 do
	    let destnode = nodes.(j) in

(* See what gateway to use to get from node to destnode. If it's out of
   bounds, there is no valid route. *)
	    let gw_index = gws.(i).(j) in
	    if gw_index < l then begin

(* The gateway is legal. find out how to get to it *)
	      let gw = get_peer_point node nodes.(gw_index) in 

(* At this point there's a whole bunch of bogus routes through
   non-interlinks and local addresses, mostly for directly
   connected blocks. Remove the if to see what happens *)

	      if not (is_no_interlink gw.endpoint_block) &&
	         not (List.exists (fun e -> e.endpoint_block.address == gw.endpoint_block.address) node.endpoints) then

(* Generate a route to every address in destnode, the
   aggregater will clean it up anyway *)
	         routes := List.append !routes (List.map (fun e ->
	      			{ dest = e.endpoint_block; gw = gw.endpoint_block.address }
	      				     ) destnode.endpoints)
	    end else begin
(* The gateway is not legal, meaning there is no route from
   node to destnode. This shouldn't happen in wleiden. *)
	    end;

(* Routes to proxies on nodes directly connected to proxies will
	be bogus at this point. filter them out *)
	    if List.exists (fun e -> is_proxy e.endpoint_block.address) node.endpoints then
	      routes := List.filter (fun r -> not (is_proxy r.dest.address)) !routes
	    else begin

(* On nodes not directly connected to a proxy, the algorithm
   can generate multiple routes to a proxy. filter out any but
   the first *)
	      let (proxy, noproxy) = List.partition (fun r -> is_proxy r.dest.address) !routes in
	      if List.length proxy > 0 then
	        routes := (List.hd proxy)::noproxy
	    end
	  done;

(* Optimize the table *)
	  routes := aggregate (!routes) [];

(* Make it more readable *)
	  routes := List.sort (fun r1 r2 -> compare r1.dest.address r2.dest.address) !routes;

(* And print *)
	  List.iter (fun r -> 
			print_string ("\t" ^ (showblock r.dest) ^ " -> " ^ (showaddr r.gw) ^ "\n")
		) !routes
	done

let main =
	let nodes = Array.of_list (parse skip "nodes.xml") in
	dump nodes (asp nodes)