module Nettle.Servers.Server
(
OpenFlowServer
, ServerPortNumber
, HostName
, startOpenFlowServer
, acceptSwitch
, closeServer
, SwitchHandle
, handle2SwitchID
, switchSockAddr
, receiveFromSwitch
, receiveBatch
, sendToSwitch
, sendBatch
, sendBatches
, sendToSwitchWithID
, closeSwitchHandle
, untilNothing
) where
import Control.Exception
import Network.Socket hiding (recv)
import Network.Socket.ByteString (recv, sendAll, sendMany)
import qualified Data.ByteString as S
import System.IO
import Data.Binary.Strict.Get
import Nettle.OpenFlow
import qualified Nettle.OpenFlow.StrictPut as Strict
import Data.Word
import Foreign
import qualified Data.ByteString.Internal as S
import Data.Map (Map)
import qualified Data.Map as Map
import Text.Printf
type ServerPortNumber = Word16
deriving instance Ord SockAddr
newtype OpenFlowServer = OpenFlowServer (Socket, IORef (Map SwitchID SwitchHandle))
startOpenFlowServer :: Maybe HostName -> ServerPortNumber -> IO OpenFlowServer
startOpenFlowServer mHostName portNumber =
do addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) mHostName (Just $ show portNumber)
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
setSocketOption sock ReuseAddr 1
bindSocket sock (addrAddress serveraddr)
listen sock queueLength
switchHandleMapRef <- newIORef Map.empty
return (OpenFlowServer (sock, switchHandleMapRef))
where
queueLength = maxListenQueue
closeServer :: OpenFlowServer -> IO ()
closeServer (OpenFlowServer (s,_)) = sClose s
data SwitchHandle = SwitchHandle !(SockAddr, Socket, ForeignPtr Word8, IORef S.ByteString, SwitchID, OpenFlowServer)
acceptSwitch :: OpenFlowServer -> IO (SwitchHandle, SwitchFeatures)
acceptSwitch ofps@(OpenFlowServer (s,shmr)) =
do (connsock, clientaddr) <- accept s
let bufferSize = 1024 * 1024
outBufferPtr <- mallocForeignPtrBytes bufferSize :: IO (ForeignPtr Word8)
inBufferRef <- newIORef S.empty
let sh = SwitchHandle (clientaddr, connsock, outBufferPtr, inBufferRef, 1, ofps)
(sid, sfr) <- handshake sh
return (SwitchHandle (clientaddr, connsock, outBufferPtr, inBufferRef, sid, ofps), sfr)
where
handshake switch
= do sendToSwitch switch (0, CSHello)
m <- receiveFromSwitch switch
case m of
Nothing -> error ("switch broke connection")
Just (xid, msg) ->
case msg of
SCHello -> go2 switch
_ -> error ("received unexpected message during handshake: " ++ show (xid, msg))
go2 switch = go2'
where go2' = do sendToSwitch switch (0, FeaturesRequest)
m <- receiveFromSwitch switch
case m of
Nothing -> error "switch broke connection during handshake"
Just (xid, msg) ->
case msg of
Features (sfr@(SwitchFeatures { switchID })) ->
do switchHandleMap <- readIORef shmr
writeIORef shmr (Map.insert switchID switch switchHandleMap)
return (switchID, sfr)
SCEchoRequest bytes ->
do sendToSwitch switch (xid, CSEchoReply bytes)
go2'
_ ->
do putStrLn ("ignoring non feature message while waiting for features: " ++ show (xid, msg))
go2'
switchSockAddr :: SwitchHandle -> SockAddr
switchSockAddr (SwitchHandle (a,_,_,_,_,_)) = a
receiveBatch :: SwitchHandle -> IO [(TransactionID, SCMessage)]
receiveBatch sh@(SwitchHandle (_, s, _, inBufferRef,_,_)) =
do newBatchBS <- recv s batchSize
inBuffer <- readIORef inBufferRef
let batchBS = S.append inBuffer newBatchBS
(chunks, remaining) <- splitChunks sh batchBS
writeIORef inBufferRef remaining
return chunks
where
batchSize = 1 * 2^10
splitChunks :: SwitchHandle -> S.ByteString -> IO ([(TransactionID, SCMessage)], S.ByteString)
splitChunks sh buffer = go buffer []
where
go buffer chunks =
if S.length buffer < headerSize
then return ( reverse chunks, buffer)
else
let (result, buffer') = runGet getHeader buffer
in case result of
Left err -> error err
Right header ->
let expectedBodyLen = fromIntegral (msgLength header) headerSize
in if expectedBodyLen <= S.length buffer'
then let (result', buffer'') = runGet (getSCMessageBody header) buffer'
in case result' of
Left err -> error err
Right msg ->
case msg of
(xid, SCEchoRequest bytes) -> do sendToSwitch sh (xid, CSEchoReply bytes)
go buffer'' chunks
_ -> go buffer'' (msg : chunks)
else return ( reverse chunks, buffer)
where headerSize = 8
receiveFromSwitch :: SwitchHandle -> IO (Maybe (TransactionID, SCMessage))
receiveFromSwitch sh@(SwitchHandle (clientAddr, s, _, _, _, _))
= do hdrbs <- recv s headerSize
if (headerSize /= S.length hdrbs)
then if S.length hdrbs == 0
then return Nothing
else error "error reading header"
else
case fst (runGet getHeader hdrbs) of
Left err -> error err
Right header ->
do let expectedBodyLen = fromIntegral (msgLength header) headerSize
bodybs <- if expectedBodyLen > 0
then do bodybs <- recv s expectedBodyLen
when (expectedBodyLen /= S.length bodybs) (error "error reading body")
return bodybs
else return S.empty
case fst (runGet (getSCMessageBody header) bodybs ) of
Left err -> error err
Right msg ->
case msg of
(xid, SCEchoRequest bytes) -> do sendToSwitch sh (xid, CSEchoReply bytes)
receiveFromSwitch sh
_ -> return (Just msg)
where headerSize = 8
sendToSwitch :: SwitchHandle -> (TransactionID, CSMessage) -> IO ()
sendToSwitch (SwitchHandle (_,s,fptr,_,_, _)) msg =
do bytes <- withForeignPtr fptr $ \ptr -> Strict.runPut ptr (putCSMessage msg)
let bs = S.fromForeignPtr fptr 0 bytes
sendAll s bs
sendBatch :: SwitchHandle -> Int -> [(TransactionID, CSMessage)] -> IO ()
sendBatch (SwitchHandle(_, s, _, _,_, _)) maxSize batch =
sendMany s $ map (\msg -> Strict.runPutToByteString maxSize (putCSMessage msg)) batch
sendBatches :: SwitchHandle -> Int -> [[(TransactionID, CSMessage)]] -> IO ()
sendBatches (SwitchHandle(_, s, fptr, _,_, _)) maxSize batches =
do bytes <- withForeignPtr fptr $ \ptr -> Strict.runPut ptr ( mapM_ (mapM_ putCSMessage) batches)
let bs = S.fromForeignPtr fptr 0 bytes
sendAll s bs
sendToSwitchWithID :: OpenFlowServer -> SwitchID -> (TransactionID, CSMessage) -> IO ()
sendToSwitchWithID (OpenFlowServer (_,shmr)) sid msg
= do switchHandleMap <- readIORef shmr
case Map.lookup sid switchHandleMap of
Nothing -> printf "Tried to send message to switch: %d, but it is no longer connected.\nMessage was %s.\n" sid (show msg)
Just sh -> sendToSwitch sh msg
closeSwitchHandle :: SwitchHandle -> IO ()
closeSwitchHandle (SwitchHandle (_, s,_,_,sid, OpenFlowServer (_, shmr))) =
do switchHandleMap <- readIORef shmr
writeIORef shmr (Map.delete sid switchHandleMap)
sClose s
handle2SwitchID :: SwitchHandle -> SwitchID
handle2SwitchID (SwitchHandle (_, _, _, _, sid, _)) = sid
untilNothing :: IO (Maybe a) -> (a -> IO ()) -> IO ()
untilNothing sense act = go
where go = do ma <- sense
case ma of
Nothing -> return ()
Just a -> act a >> go