module Nettle.Discovery.Discovery (
topoTracker
) where
import Nettle.FRPControl.NettleSF
import Nettle.FRPControl.NetInfo
import Nettle.Ethernet.EthernetFrame
import Nettle.OpenFlow.Switch
import Nettle.OpenFlow.Packet
import qualified Nettle.OpenFlow.Port as Port
import Nettle.OpenFlow.Action
import Nettle.Discovery.Topology
import Nettle.LLDP.LLDP hiding (portID)
import qualified Nettle.LLDP.LLDP as LLDP
import Data.Binary.Get
import Data.Binary.Put
import Data.Binary
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import Data.IP
import Data.Header
topologyController :: SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand, Event String)
topologyController = proc msgE -> do
(msgE', cmdE, topoE) <- topoTracker -< msgE
returnA -< (cmdE, liftE (line . show) topoE)
line :: String -> String
line s = s ++ "\n"
topoTracker :: SF (Event (SwitchID, SwitchMessage)) (Event (SwitchID, SwitchMessage), Event SwitchCommand, Event Topology)
topoTracker = proc evt -> do
netInfo <- switchInfo -< evt
pktInE <- (arr (filteredPacketInE (ethFrameTypeIs ethTypeLLDP))) -< evt
let switchTuples = [ (dPID p, portAddr p, portID p) | p <- portTable netInfo ]
clock <- repeatedly 60 () -< ()
let swJoinLLDPCmdE = liftE (switchUpSendLLDPCommand (portTable netInfo)) (arrivalE evt)
let portUpdateCmdE = liftE (\(dpid, (_,portDesc)) -> sendPortLLDPCommand dpid portDesc) (portUpdateE evt)
let periodicCmdE = tag clock (sendLLDPCommand switchTuples)
let topoRemoveSwitch = liftE (removeSwitch . fst) (departureE evt)
removePortE = liftE (\(dpid, (_,portDesc)) -> removePortTopoUpdate dpid portDesc) (portUpdateE evt)
lldpTopoUpdate = mapFilterE readLLDPPacket pktInE
topologyE <- accum empty -< mergeEvents [topoRemoveSwitch, removePortE, lldpTopoUpdate]
returnA -< (removeLLDPPacketIns evt,
mergeEventsBy (<+>) [swJoinLLDPCmdE, portUpdateCmdE, periodicCmdE],
topologyE)
linkDownRemovePorts :: [Link] -> Topology -> Topology
linkDownRemovePorts lst t = foldr removeLink t lst
removeLLDPPacketIns :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, SwitchMessage)
removeLLDPPacketIns = mapFilterE f
where f (sid, msg) =
case msg of
PacketIn pktInfo ->
case packetInMatches pktInfo lldp of
Left err -> Just (sid, PacketIn pktInfo)
Right b -> if b then Nothing else Just (sid, PacketIn pktInfo)
_ -> Just (sid, msg)
switchUpSendLLDPCommand :: PortTable -> (SwitchID, SwitchFeatures) -> SwitchCommand
switchUpSendLLDPCommand portTable (dpid,_) = sendLLDPCommand [(dpid, portAddr p, portID p) | p <- portTable, dPID p == dpid ]
sendPortLLDPCommand :: SwitchID -> Port.Port -> SwitchCommand
sendPortLLDPCommand dpid portDesc
| Port.portLinkDown portDesc == True = noOp
| otherwise = sendLLDPCommand [(dpid, Port.portAddress portDesc, Port.portID portDesc)]
removePortTopoUpdate :: SwitchID -> Port.Port -> Topology -> Topology
removePortTopoUpdate dpid portDesc
| Port.portLinkDown portDesc == True = removePort (dpid, Port.portID portDesc)
| otherwise = id
readLLDPPacket :: (SwitchID, PacketInfo) -> Maybe (Topology -> Topology)
readLLDPPacket (dpid, pktInRecord) =
case runGetE getLLDPInEthernet (packetData pktInRecord) of
Left _ -> Nothing
Right lldp -> let sourcePort = (chassisID lldp, LLDP.portID lldp)
destinationPort = (dpid, receivedOnPort pktInRecord)
in Just (addLink sourcePort destinationPort)
sendLLDPCommand :: [ (SwitchID, EthernetAddress, Port.PortID) ] -> SwitchCommand
sendLLDPCommand = mconcat . map f
where f switchInfo@(dpid, ethAddr, pid) = sendPacket dpid (unbufferedPacketOut (generateLLDPFrame switchInfo) Nothing (sendOnPort pid))
generateLLDPFrame :: (SwitchID, EthernetAddress, Port.PortID) -> ByteString
generateLLDPFrame (dpid, ethAddr, pid) = runPut frame
where packet = LLDPDU { chassisID = dpid,
LLDP.portID = pid,
timeToLive = 0 }
header = EthernetHeader { destMACAddress = ethAddr,
sourceMACAddress = ethAddr,
typeCode = ethTypeLLDP }
frame = do putEthHeader header
put packet