module PupEventsServer (server) where
import GHC.IO.Handle
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan (tryReadTChan)
import Control.Concurrent
import Control.Monad
import Text.Parsec
import Network.Socket
import System.IO
import PupEventsPQueue
import Data.Functor.Identity
server :: Maybe [Char]
-> Int
-> (t -> Int)
-> (t1 -> t1 -> String)
-> (t -> t -> IO t1)
-> [ParsecT [Char] () Data.Functor.Identity.Identity t]
-> Maybe t
-> IO b
server Nothing priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent = server (Just "0.0.0.0") priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent
server ip priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent =
do
addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
ip (Just "1267")
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream 6
bindSocket sock (addrAddress serveraddr)
listen sock 5
forever $ acceptCon sock priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent
handleEvents :: Handle
-> PQueue t
-> (t1 -> t1 -> String)
-> (t -> t -> IO t1)
-> IO b
handleEvents handle pqueue lookupUnHandler lookupHandler = forever $
do event <- atomically $
do event <- getThing pqueue
case event of
Nothing -> retry
Just event -> return event
event' <- lookupHandler event event
hPutStr handle (lookupUnHandler event' event')
hFlush handle
acceptCon :: Socket
-> Int
-> (t -> Int)
-> (t1 -> t1 -> String)
-> (t -> t -> IO t1)
-> [ParsecT [Char] () Data.Functor.Identity.Identity t]
-> Maybe t
-> IO ThreadId
acceptCon sock priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent =
do putStrLn "Accepting Connections"
(connsock, clientaddr) <- accept sock
putStrLn $ "Connection received from: " ++ show clientaddr
connHandle <- socketToHandle connsock ReadWriteMode
hSetBuffering connHandle NoBuffering
hSetBinaryMode connHandle True
pqueue <- makeQueues priorities
forkIO (recvEvents connHandle pqueue lookupPriority parsers dcEvent)
forkIO (handleEvents connHandle pqueue lookupUnHandler lookupHandler)
recvEvents :: Handle
-> PQueue a
-> (a -> Int)
-> [ParsecT [Char] () Data.Functor.Identity.Identity a]
-> Maybe a
-> IO ()
recvEvents handle pqueue lookupPriority parsers dcEvent =
do messages <- hGetContents handle
mapM_ toDispatch (nullLines messages)
hClose handle
case dcEvent of
Just x -> atomically $ writeThing pqueue (lookupPriority x) x
Nothing -> return ()
where
toDispatch str =
case parse parseMsg "" str of
Left e -> putStrLn $ "ParseError: " ++ show e ++ "\nString: " ++ show str
Right a -> atomically $ writeThing pqueue (lookupPriority a) a
parseMsg = choice parsers
nullLines "" = []
nullLines str = x:nullLines xs
where (x, xs) = splitAt (nullLines' 0 str) str
nullLines' n [] = n
nullLines' n ('\0':'\0':str) = n+2
nullLines' n (s:str) = nullLines' (n+1) str