module rosePakcs where infixl 5 ->- infixl 5 -@- infixl 5 =>- infixl 5 ->= infixl 5 =>= --================ DATA TYPES type Packet = [Int] type Stream = [Packet] type Ip = [Int] data Conf = Eth0 | Eth1 | E1ArpQ | I Int | Pat [Int] | Col Int | Ip [Int] | Eth [Int] | Mapt [Patt_mapTable] | Queue [Stream] | Err Ip Int Int | RT [Patt_route] | Eh [Int] | TTL Int | Ea [Int] --================ AUXILIAR DATA TYPES type Ippatt = [Int] --routing table types type Mask = Int type Gw = [Int] type OutPort = Int type Patt_route = ( Ippatt, Mask, Gw, OutPort ) type Ethpatt = [Int] type Patt_mapTable =( Ippatt, Ethpatt ) --================ AUXILIAR FUNCTIONS & PACKET POSITIONS colAnnE = 38 -- color annotation in Ethernet Packet colAnnIP = colAnnE - 14 -- color annotation in IP Packet iptgAnnIP = 25 -- Ip target annotation position at ip packet outEthAnnIP= 30 -- Ethernet output annotation llbAnnIP = 29 -- link level broadcast flag annotation at IP packet fixIpAnnIP = 31 -- fix IP annotation begIpTarg = 16 -- Begin ip target address at ip packet ttl = 8 -- TTL field position at ip packet broadcst = [16,16,16,16,16,16] -------------------------// applicate a function to packet position appf (p:ps) f n | n ==0 = (f p):ps | n > 0 = p: appf ps f (n-1) -------------------------// Put ip address in ip packet at position indicated putIPin [] pk _ = pk putIPin (h:t) pk n = appf (putIPin t pk (n+1)) (\_->h) n ------------------------// Verifies that an ip address is in packet at position n isIPin [] _ _ = True isIPin (h:t) p n = if h == (p !! n) then isIPin t p (n+1) else False -------------------------// Insert a packet at stream of n position ins r p qs = if r==0 then ((p:(qs!!0)):(tail qs)) else (qs!!0) : (ins (r-1) p (tail qs)) -------------------------// subList, returns a subList of n length without preffix subList n pref l = take n (drop pref l) -------------------------// isBroadCastIP, isBroadCastIP [] = False isBroadCastIP (h:t) = if h == 255 then True else isBroadCastIP t -------------------------// isUnivIP, isUnivIP [] = True isUnivIP (h:t) = if h /= 0 then False else isUnivIP t -------------------------// newPacket: creates a new IP packet newPacket :: Packet ---| --22 --38 newPacket = [1,1,1,1,1,1,9,9,9,9,9,9,8,0,4,5,7,7,0,0,2,2,200,80,0,0, 154,250,159,2,148,208,179,3,7,7,7,7,-7,0,0,0,0,0,-1,0] newPacket2 :: Packet ---| --22 --38 newPacket2 = [1,1,1,1,1,1,9,9,9,9,9,9,8,0,4,5,7,7,0,0,2,2,250,80,0,0, 148,208,179,3,154,250,159,2,7,7,7,7,-7,0,0,0,0,0,-1,0] -------------------------// Create a new ARP Request packet newARP1Packet ::Packet newARP1Packet =[1,5,9,0,0,5,16,16,16,16,16,16,8,6,0,1,8,0,6,4,0,1,1,5,9,0,0,5,154,250,159,5,16,16,16,16,16,16,148,208,179,1] --================ ELEMENTS -------------------------// infiniteSource: produces ARP packets & IP packets infiniteSource :: [Conf] -> [Stream] -> [Stream] infiniteSource [eth] [] = [infiniteSource_ eth] where infiniteSource_ Eth0 = (newPacket : infiniteSource_ Eth0) infiniteSource_ Eth1 = (newPacket2 : infiniteSource_ Eth1) infiniteSource_ E1ArpQ=(newARP1Packet : infiniteSource_ E1ArpQ) -------------------------// fromDevice: generates packets from ethernet source fromDevice :: [Conf] -> [Stream] -> [Stream] fromDevice [eth] [] = infiniteSource [eth] [] fromDevice (eth : I n: _) [] = [take n (head (infiniteSource [eth] [])) ] fromDevice_u :: [Conf] -> [Stream] -> [Stream] fromDevice_u params [] = infiniteSource_u params [] infiniteSource_u :: [Conf] -> [Stream] -> [Stream] infiniteSource_u params [] = [ iSrc params ] where iSrc [ Eh ethh, Ip ipsrc, Ip iptg, TTL tt] = (ethh ++[8,0,4,5,7,7,0,0,2,2]++[tt]++[80,0,0]++ ipsrc ++ iptg ++ [7,7,7,7,-7,0,0,0,0,0,-1,0]) : iSrc [Eh ethh, Ip ipsrc, Ip iptg, TTL tt] iSrc [I n, Eh ethh, Ip ipsrc, Ip iptg, TTL tt] = take n ( iSrc [Eh ethh, Ip ipsrc, Ip iptg, TTL tt] ) iSrc [ Ea esrc, Ip ips, Ip ipt] = ( esrc ++ [15,15,15,15,15,15,8,6,0,1,8,0,6,4,0,1] ++ esrc++ ips++[15,15,15,15,15,15]++ipt) : iSrc [Ea esrc, Ip ips, Ip ipt] iSrc [I n, Ea esrc, Ip ips, Ip ipt] = take n ( iSrc [Ea esrc, Ip ips, Ip ipt] ) --newARP1Packet =[1,5,9,0,0,5, --ethernet source -- 15,15,15,15,15,15, --ethernet target -- 8,6,0,1,8,0,6,4,0,1, --configuration field -- 1,5,9,0,0,5, --ethernet src -- 154,250,159,5, --ip src -- 16,16,16,16,16,16, --eth tgt -- 148,208,179,1] -- ip tgt -------------------------// classifier: classifies packet type classifier :: [Conf] -> [Stream] -> [Stream] classifier pats [p:ps] = ins n p qs where n = class pats p qs = classifier pats [ps] classifier _ [[]] = [ [], [], [] ] --a pattern is a list [pos,val,pos,val,...,pos,val,n] class (Pat pat : pats) p = let n = class_ pat p in if n == (-1) then class pats p else n class_ [n] _ = n class_ (pos:val:es) p = if p!!pos == val then class_ es p else -1 -------------------------// strip: transforms packets from ethernet to ip strip :: [Conf]->[Stream]->[Stream] strip [I n] [ps]= [strip_ n ps] where strip_ _ [] = [] strip_ m (q:qs) = drop m q : strip_ m qs -------------------------// paint: puts color annotation at position 38 in eth packet paint :: [Conf] -> [Stream] -> [Stream] paint [Col c] [st]= [paint_ c st] where paint_ _ [] = [] paint_ cl (p:ps) = appf p (\_->cl) colAnnE : paint_ cl ps -------------------------// checkIPHeader: verifes that isn't universal or broadcast packet at source checkIPHeader :: [Conf] -> [Stream] -> [Stream] checkIPHeader _ [st]= [checkIPHeader_ st] where checkIPHeader_ [] = [] checkIPHeader_ (p:ps) = if ( checkIPvalid (subList 4 12 p) ) then p : checkIPHeader_ ps else checkIPHeader_ ps checkIPvalid ip = if ( (isBroadCastIP ip) || (isUnivIP ip) ) then False else True -------------------------// GetIPAddress: copy ip target to ip target annotation in ip packet 25,26,27,28 getIPAddress :: [Conf] -> [Stream] -> [Stream] getIPAddress _ [st]= [getIPAddress_ st] where getIPAddress_ [] = [] getIPAddress_ (p:ps) = putIPin (subList 4 16 p) p 25: getIPAddress_ ps -------------------------// LookUpIPRoute, rounting packets, mark packet with output port lookupIPRoute :: [Conf] -> [Stream] -> [Stream] lookupIPRoute [RT rt] [p:ps] = ins n pk qs where (pk,n) = lookup p rt qs = lookupIPRoute [RT rt] [ps] lookupIPRoute _ [[]] = [ [],[],[] ] lookup pk (r:rs) = let (packet,eth) = lookup_ r pk 0 in if (eth == (-1)) then lookup pk rs -- if not match in first route try again else (packet, eth) -- it has matched lookup_ :: Patt_route -> Packet -> Int -> (Packet,Int) lookup_ (ippat, mask, gw, eth) pk n | mask == 0 = lookup__ pk eth gw --matching then prepare packet !!! | mask > 0 = if (ippat !! n) == (pk !! (begIpTarg+n)) --try match then lookup_ (ippat, (mask-8),gw,eth) pk (n+1) else (pk,-1) -- not match -- in order to prepare outgoing packet, put next skip ip & out eth ann lookup__ :: Packet -> Int -> Gw -> (Packet ,Int) lookup__ pk eth gw = if ((gw !! 0)/=(-1)) then (out,eth) -- when packet has out eth & valid gateway else (pk, eth) -- when packet don't have skip where out = appf (putIPin gw pk iptgAnnIP) (\_-> eth ) outEthAnnIP -------------------------// toLinux, Should deliver packets to linux kernel toLinux :: [Conf] -> [Stream] -> [Stream] toLinux _ [st] = [toLinux_ st] where toLinux_ [] = [] toLinux_ (q:qs) = q : toLinux_ qs -------------------------// Drop packets marked with link level broadcast dropBroadcasts :: [Conf] -> [Stream] -> [Stream] dropBroadcasts _ [st] = [dropBroadcasts_ st] where dropBroadcasts_ [] = [] dropBroadcasts_ (p:ps) = if ( doDropBroadcasts p ) then dropBroadcasts_ ps else p: dropBroadcasts_ ps doDropBroadcasts pk = if ( (pk !! llbAnnIP ) == 0) then False --linklevelBroad is off else True -- on -------------------------// PaintTee generates an error when a packet leaves same ethernet card of input paintTee :: [Conf] -> [Stream] -> [Stream] paintTee [Col c] [p:ps] = if (p!!colAnnIP)==c then ins 0 p (ins 1 p qs) else ins 0 p qs where qs = paintTee [Col c] [ps] paintTee _ [[]] = [[],[]] ------------------------// Functions specifics to router ipgwOptions :: [Conf] -> [Stream] -> [Stream] ipgwOptions _ x = x ------------------------// Put ip source when an error packet is delivered fixIPSrc :: [Conf] -> [Stream] -> [Stream] fixIPSrc [Ip src] [st] = [fixIPSrc_ st src] where fixIPSrc_ [] _ = [] fixIPSrc_ (p:ps) source = if (p !! fixIpAnnIP) == 1 then fixIPSrc__ p source : fixIPSrc_ ps source else p : fixIPSrc_ ps source fixIPSrc__ p ipsrc = putIPin ipsrc (appf p (\_->0) fixIpAnnIP) 12 -- Clear fix ip flag & put ip src -----------------------//Decrements TTL Field decIPTTL :: [Conf] -> [Stream] -> [Stream] decIPTTL _ [p:ps] = ins n p2 qs where (p2,n) = decIPTTL_ p qs= decIPTTL [] [ps] decIPTTL _ [[]] = [[], []] decIPTTL_ p = let pk = appf p (\x->x-1) ttl in if ( pk !! ttl ) > 0 then (pk,0) else (pk,1) ----------------------// Packet less than size indicated, generates error ipFragmenter :: [Conf] -> [Stream] -> [Stream] ipFragmenter [I size] [p:ps] = ins n p qs where n = if (length p) <= size then 0 else 1 qs= ipFragmenter [I size] [ps] ipFragmenter _ [[]] = [[],[]] ----------------------// ARPQuerier, Map ip packet->Ethernet arpQuerier :: [Conf] -> [Stream] -> [Stream] arpQuerier _ [] = [] arpQuerier conf (st:sts) = arpQuerier_ conf st: arpQuerier conf sts arpQuerier_ (c:d:e:_) st= arpQ_ st c d e where arpQ_ [] _ _ _ = [] arpQ_ (p:ps) (Ip ipl) (Eth ethl) (Mapt m)= arpQuery p ipl ethl m : arpQ_ ps (Ip ipl) (Eth ethl) (Mapt m) arpQuery :: Packet-> Ippatt -> Ethpatt ->[Patt_mapTable]-> Packet arpQuery pk iploc ethloc mapTable | (eth !! 0) == (-1) = (ethloc++ broadcst ++[8,6,0,1,8,0,6,4,0,1]++ethloc++iploc++broadcst++iptgt ) | otherwise = (ethloc++eth++[8,0]++pk) where iptgt = subList 4 begIpTarg pk eth = ethIfisIPinMap iptgt mapTable ethIfisIPinMap:: Ippatt -> [Patt_mapTable]-> Ethpatt --search ip in maptable return Eth ethIfisIPinMap _ [] = [-1] ethIfisIPinMap iptgt ((ipmap,eth):xs)= if (isIPin iptgt ipmap 0) then eth else ethIfisIPinMap iptgt xs ----------------------// Queue queue :: [Conf] -> [Stream] -> [Stream] queue [Queue q] st = concat [q, st] ----------------------// ToDevice, put packets at ethernet card toDevice :: [Conf] -> [Stream] -> [Stream] toDevice [_] [ps] = [toDevice_ ps] where toDevice_ [] = [] toDevice_ (q:qs) = q : toDevice_ qs ----------------------// Discard, discard packets discard :: [Conf] -> [Stream] -> [Stream] discard _ _ = [] ----------------------// Print packets, warning [_] forces list with argument, correct is _ printf :: [Conf] -> [Stream] -> [Stream] printf _ [] = [] printf _ (s:sts) = printf_ s : printf [] sts where printf_ [] = [] printf_ (p:ps) = (p : printf_ ps) ----------------------// Throw a new ip packet that contains a ICMP message icmpError :: [Conf] -> [Stream] -> [Stream] icmpError [Err ips t c ] [ps] = [icmpError_ ps] where icmpError_ [] = [] icmpError_ (q:qs) = icmpError__ q ips t c : icmpError_ qs icmpError__ :: Packet -> [Int] -> Int -> Int-> Packet icmpError__ pk ipsrc typ code = out where pktyped = appf pk (\_->typ ) 20 -- put type & code of error pkcoded = appf pktyped (\_->code) 21 -- move ipsrc to iptgt & ipsrc now is the argument pktgted = putIPin (subList 4 12 pkcoded) pkcoded begIpTarg pksrced = putIPin ipsrc pktgted 12 i = appf pksrced (\_->0) colAnnIP -- del col ann, it could make rings j = appf i (\_->255) ttl -- beg ttl field out = appf j (\_->1) fixIpAnnIP -- put flag fix ip source ------------arpResponder arpResponder :: [Conf] -> [Stream] -> [Stream] arpResponder [Mapt m] [ps] = [arpResponder_ m ps] where arpResponder_ _ [] = [] arpResponder_ m2 (q:qs) = arpResponse m2 q : arpResponder_ m2 qs arpResponse m p = let (i,e)= arpResponder__ m p in if i == [] then [] else arpReplay p i e m arpReplay pq i e ((_,el): _)= ethHdr ++ body where ethHdr = el ++ (take 6 pq) body = [8,6,0,1,8,0,6,4]++[0,2] ++ e ++ i ++ (take 6 pq) ++ (take 4 (drop 28 pq)) arpResponder__ [] _ = ([],[]) arpResponder__ ((i,e): ms) pq = if (isIPin i pq 38) then (i,e) else arpResponder__ ms pq --================ CONNECTORS -------------------------// Sequencial Connector seqq :: [[Stream] -> [Stream]] -> [Stream] -> [Stream] seqq [] = id seqq (elem : es) = \input -> seqq es (elem input) -------------------------// Multiple Connector (1..n) mult :: ([Stream] -> [Stream]) -> [[Stream] -> [Stream]] -> [Stream] -> [Stream] mult elem es = \input -> mult_ es (elem input) mult_ :: [[Stream] -> [Stream]] -> [Stream] -> [Stream] mult_ es ss = concat (mult__ es ss) mult__ [] [] = [] mult__ (e:es) (s:ss) = (e [s]) : mult__ es ss -------------------------// Port Selector portSelect :: [Conf] -> ([Stream] -> [Stream]) -> [Stream] -> [Stream] portSelect [I n] elem = \input -> [(elem input)!! n ] ptS :: [Conf] -> ([Stream] -> [Stream]) -> [Stream] -> [Stream] ptS [I n] elem = \input -> [(elem input)!! n ] -- Connector 1 to 1, same port, pass [[]] (->-)::([Stream]->[Stream])->([Stream]->[Stream])->[Stream]->[Stream] elem1 ->- elem2 = \inp -> let med=elem1 inp in elem2 med -- Connector 1 to 1, same port, dont pass [[]] (-@-)::([Stream]->[Stream])->([Stream]->[Stream])->[Stream]->[Stream] elem1 -@- elem2 = \inp -> stopnulls elem1 elem2 inp stopnulls elem1 elem2 inp | inp/=[[]] = let med=elem1 inp in elem2 med -- Connector elem [port] to 1 (=>-)::(([Stream]->[Stream]), Int )->([Stream]->[Stream])->[Stream]->[Stream] (elem1, sp) =>- elem2 = \inp ->let mid = elem1 inp in elem2 [mid !! sp] -- Connector elem [port] to [port]elem2 (=>=)::(([Stream]->[Stream]), Int )->(Int,([Stream]->[Stream]) )->[Stream]->[Stream] (elem1, sp) =>= (tp, elem2) = \inp ->let mid = elem1 inp in elem2 ( inst tp (mid !! sp) [[[ ]]] ) inst r st sts = if r==0 then (st:sts) else (sts!!0) : (inst (r-1) st (tail sts)) -- Connector mult as binary operator (->=) :: ([Stream] -> [Stream]) -> [[Stream] -> [Stream]] -> [Stream] -> [Stream] elem1 ->= elems = \input -> mult_ elems (elem1 input) -------------------------// RoundRobin rr :: [Conf]-> [Stream]->[Stream] rr [] strm = [rr_ strm] rr_ [] = [] rr_ ( st :sts) = if st==[] then rr_ sts else head st: rr_ ( sts++ [tail st]) -----------------------//receives an element an execute it simulfr:: ([Stream] -> [Stream])-> [Stream] simulfr elem = elem [] simuln:: Int -> ( [Stream] -> [Stream] ) -> [Stream] simuln n elem = [ take n (head (elem [])) ]