{-# LANGUAGE Arrows #-}

-- | Experimental version of topology discovery algorithm.
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"
  
-- | A signal function tracking the topology of the network. The signal function sends LLDP-like
-- packets from various points in the network and infers the topology based on packet-in events
-- generated by those packets. In order to ensure that your controller does not interfere with the 
-- operation of @topoTracker@, you should drive your controllers with the switch message stream output
-- by the @topoTracker@ (the first output stream), which has the packet-in events generated by the LLDP-like packets filtered out.
-- The second output stream is a stream of commands which must be merged into the overall output of your
-- controller in order for the @topoTracker@ to inject its discovery packets into the network.
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)

-- .|. (linkDownListE =>> linkDownRemovePorts)                            
--                    pktInLinkE           = pktInE =>> pktInGenerateLink
--                 linkDownListE <- timerCollection 10 -< pktInLinkE


linkDownRemovePorts :: [Link] -> Topology -> Topology
linkDownRemovePorts lst t = foldr removeLink t lst

{-
pktInGenerateLink :: (SwitchID, PacketInfo) -> Link
pktInGenerateLink (dpid, pktInfo) = 
    let lldp = runGet getLLDPInEthernet (packetData pktInfo)
        sourcePort = (chassisID lldp, LLDP.portID lldp)
        destinationPort = (dpid, receivedOnPort pktInfo)
    in link (sourcePort, destinationPort)
-}

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