{-# OPTIONS_HADDOCK ignore-exports #-}
-- |The Server module of the PupEvents framework is designed to be run from
-- the file that specifies the Events that you are handling. The only thing
-- that would need to be written to use this is the Events file, it does
-- not depend on the application code.
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 Control.Exception.Base (finally)
import qualified Control.Exception as C
import Text.Parsec
import Network.Socket
import System.IO
import PupEventsPQueue
import Data.Functor.Identity
-- Make a socket, communication channels and start listening for connections
-- |The main entry point of the program. This ends by forever calling 'acceptCon'.
server :: Maybe [Char] -- ^ The address to listen on, if it's not given default to "0.0.0.0".
-> Int -- ^ The number of priority levels to create the PQueue with
-> String -- ^ The port to start on
-> (t -> Int) -- ^ The function to look up the priority level of an event
-> (t1 -> t1 -> String) -- ^ The lookup function to convert an event to a string representation
-> (t -> t -> IO t1) -- ^ The lookup function to look up the handler for an event
-> [ParsecT [Char] () Data.Functor.Identity.Identity t] -- ^ The list of parsers to try and parse events with
-> Maybe t -- ^Optional. The event to put on the pqueue when a client disconnects
-> IO b
server Nothing priorities port lookupPriority lookupUnHandler lookupHandler parsers dcEvent = server (Just "0.0.0.0") priorities port lookupPriority lookupUnHandler lookupHandler parsers dcEvent
server ip priorities port lookupPriority lookupUnHandler lookupHandler parsers dcEvent =
do -- get port
addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
ip (Just port)
let serveraddr = head addrinfos
-- create socket
sock <- socket (addrFamily serveraddr) Stream 6
-- bind to the address we're listening on
bindSocket sock (addrAddress serveraddr)
-- listen with maximum 5 queued requests
listen sock 5
-- accept forever
finally (forever $ acceptCon sock priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent) ({-hPutStr stderr "Shutting down server..." >> -}sClose sock)
-- |Checks the given PQueue for an event to handle and calls the handler
-- for it, then sends the event returned by the handler to the client.
handleEvents :: Handle -- ^ The handle to send the handled event on
-> PQueue t -- ^ The PQueue on which to listen for events to be handled
-> (t1 -> t1 -> String) -- ^ The lookup function to find the function that returns a string representation of the event.
-> (t -> t -> IO t1) -- ^ The lookup function that returns the event handler
-> IO ()
handleEvents handle pqueue lookupUnHandler lookupHandler =
do event <- atomically $
do event <- getThing pqueue
case event of
Nothing -> retry
Just event -> return event
event' <- lookupHandler event event
C.catch (
do hPutStr handle (lookupUnHandler event' event')
hFlush handle
handleEvents handle pqueue lookupUnHandler lookupHandler
) (\e -> do let err = show (e :: C.IOException)
{-hPutStr stderr ("Client disconnected"-}
return ()
)
-- accept a connection and fork a new thread to handle receiving events from it
-- after the connection is accepted, create a new channel for the dispatcher to
-- receive events from.
-- |Listens for an incoming connection. When it gets one it spawns two threads for the connection, one using 'handleEvents' and the other using 'recvEvents'.
acceptCon :: Socket -- ^ The socket to listen for incoming connections on
-> Int -- ^ The number of priorities for the PQueues to have
-> (t -> Int) -- ^ The function to lookup the priority level of an event
-> (t1 -> t1 -> String) -- ^ The function to lookup the string representation for an event
-> (t -> t -> IO t1) -- ^ The function to lookup the handler for the event
-> [ParsecT [Char] () Data.Functor.Identity.Identity t] -- ^ A list of parsers to use when trying to parse Events
-> Maybe t -- ^Optional. The event to put on the pqueue when a client disconnects
-> IO ThreadId
acceptCon sock priorities lookupPriority lookupUnHandler lookupHandler parsers dcEvent =
do {-hPutStr stderr "Accepting Connections\n"-}
(connsock, clientaddr) <- accept sock
--hPutStr stderr $ "Connection received from: " ++ show clientaddr ++ "\n"
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)
-- Receive events until the connection is closed, parse them, and push them on the
-- channel to the dispatcher
-- |Listens for events from the Client and sends them to the 'handleEvents' thread.
recvEvents :: Handle -- ^ The handle to listen for events on
-> PQueue a -- ^ The PQueue used to send events to the 'handleEvents' thread
-> (a -> Int) -- ^ The function to lookup the priority level of an event
-> [ParsecT [Char] () Data.Functor.Identity.Identity a] -- ^ A list of parsers to use when trying to parse Events
-> Maybe a -- ^Optional. The event to put on the pqueue when a client disconnects
-> IO ()
recvEvents handle pqueue lookupPriority parsers dcEvent =
-- I don't really understand how these two lines work, but I think its
-- got something to do with lazy evalution. they're from RWH.
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 -> hPutStr stderr $ "ParseError: " ++ show e ++ "\nString: " ++ show str ++ "\n"
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