module Network.SimpleServer(
ConnectionHandler,
DisconnectHandler,
CmdHandler,
Server(),
new,
addCommand,
start,
stop,
ClientConn(),
cid,
lookup,
modify,
respond,
broadcast,
disconnect,
clientList) where
import Control.Concurrent hiding(modifyMVar)
import qualified Control.Concurrent.Lock as Lock
import Control.Concurrent.MVar hiding(modifyMVar)
import Control.Concurrent.Thread.Delay
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as ByteS
import Data.Foldable(toList)
import qualified Data.HashTable.IO as HT
import Data.IORef
import Data.Time.Clock
import qualified Data.Sequence as Seq
import qualified Network as Net
import qualified Network.Socket as Net(close)
import System.IO(Handle, hSetBuffering, BufferMode(NoBuffering))
import Prelude hiding(lookup)
type CmdHandler = [String] -> Server -> ClientConn -> IO ()
type ConnectionHandler = Server -> ClientConn -> IO ()
type DisconnectHandler = Server -> ClientConn -> IO ()
data ClientConn = ClientConn {
cid :: Integer,
lookup :: (String -> IO String),
modify :: (String -> String -> IO ()),
chandle :: Handle,
host :: Net.HostName,
pid :: Net.PortNumber,
msgList :: List String,
dead :: MVar Bool,
timestamp :: TimeStamp,
tid :: MVar (ThreadId, ThreadId),
serv :: Server}
instance Eq ClientConn where
(==) c0 c1 = (cid c0) == (cid c1)
data Server = Server { port :: Net.PortID,
socket :: IORef (Maybe Net.Socket),
clients :: List ClientConn,
cmdList :: List Message,
lastclean :: TimeStamp,
timeout :: NominalDiffTime,
lock :: Lock.Lock,
cmdTable :: CmdTable,
nextID :: MVar Integer,
cHandler :: ConnectionHandler,
dHandler :: DisconnectHandler,
threads :: MVar (ThreadId, ThreadId)}
new :: ConnectionHandler -> DisconnectHandler -> Int -> IO Server
new cHandler dHandler pid = do
socket <- newIORef Nothing
clients <- emptyList
cmdList <- emptyList
time <- getCurrentTime
lastClean <- newMVar time
serverLock <- Lock.new
let allowed = 60
cmdTable <- HT.new
nextID <- newMVar 0
threads <- newEmptyMVar
return $ Server (Net.PortNumber $ fromIntegral pid) socket clients cmdList lastClean allowed serverLock cmdTable nextID cHandler dHandler threads
addCommand :: Server -> String -> CmdHandler -> IO ()
addCommand server cmd handler = HT.insert (cmdTable server) cmd handler
start :: Server -> IO ()
start server = Net.withSocketsDo $ do
maybeSocket <- readIORef $ socket server
case maybeSocket of
Nothing -> do
s <- try $ Net.listenOn (port server) :: IO (Either IOException Net.Socket)
case s of
Left e -> debugLn' (lock server) $ "The server could not be started: " ++ (show e)
Right s -> do
writeIORef (socket server) (Just s)
rt <- forkIO $ runServer server
at <- forkIO $ acceptCon server s
putMVar (threads server) (rt, at)
return ()
Just s -> return ()
stop :: Server -> IO ()
stop server = Net.withSocketsDo $ do
maybeSocket <- readIORef $ socket server
case maybeSocket of
Nothing -> return ()
Just s -> do
clist <- takeAll $ clients server
mapM_ (disconnect' server) (toList clist)
(rt, at) <- takeMVar (threads server)
killThread rt
killThread at
Net.close s
writeIORef (socket server) Nothing
respond :: ClientConn -> String -> IO ()
respond client string = put (msgList client) string
broadcast :: Server -> String -> IO ()
broadcast server string = do
debugLn' (lock server) "Reading client list"
q <- readAll (clients server)
debugLn' (lock server) "Processing client list"
mapM_ ((flip put string) . msgList) q
debugLn' (lock server) "Message queued."
disconnect :: ClientConn -> IO ()
disconnect client = do
d <- readMVar (dead client)
if d then return () else do
swapMVar (dead client) True
clean (serv client)
clientList :: Server -> IO [ClientConn]
clientList = readAll . clients
type List a = MVar (Seq.Seq a)
type TimeStamp = MVar UTCTime
type CmdTable = HT.BasicHashTable String CmdHandler
type UserTable = HT.BasicHashTable String String
data Message = Message { cmd :: String,
client :: ClientConn } deriving Eq
newConn :: Integer -> Handle -> Net.HostName -> Net.PortNumber -> Server -> IO ClientConn
newConn id handle host pid server = do
queue <- emptyList
dead' <- newMVar False
tid <- newEmptyMVar
timestamp <- newEmptyMVar
table <- HT.new
lock <- Lock.new
let lookup = safeLookup lock table
modify = safeModify lock table
return $ ClientConn id lookup modify handle host pid queue dead' timestamp tid server
safeLookup :: Lock.Lock -> UserTable -> (String -> IO String)
safeLookup lock usertable = (\key -> do
Lock.acquire lock
val <- HT.lookup usertable key
Lock.release lock
return $ case val of
Nothing -> ""
Just x -> x)
safeModify :: Lock.Lock -> UserTable -> (String -> String -> IO ())
safeModify lock usertable = (\key val -> do
Lock.acquire lock
HT.insert usertable key val
Lock.release lock)
runServer :: Server -> IO ()
runServer server = Net.withSocketsDo $ do
maybeSocket <- readIORef $ socket server
case maybeSocket of
Nothing -> return ()
Just _ -> do
checkClean server
cmds <- takeAll (cmdList server)
if (cmds == [])
then delay (1000*100)
else do
debugLn' (lock server) "Processing Commands..."
mapM_ (processCommand server) cmds
debugLn' (lock server) "Done."
runServer server
processCommand :: Server -> Message -> IO ()
processCommand server msg = do
let commands = words (cmd msg)
if commands == []
then return ()
else do
maybeFunction <- HT.lookup (cmdTable server) (head commands)
case maybeFunction of
Nothing -> do
debugLn' (lock server) $ "Could not process command: " ++ (cmd msg)
put (response_queue msg) ("Invalid command: " ++ (cmd msg))
Just f -> f commands server (client msg)
where response_queue = msgList . client
checkClean :: Server -> IO ()
checkClean server = do
time <- getCurrentTime
last <- readMVar (lastclean server)
let passed = diffUTCTime time last
allowed = timeout server
if (passed > allowed)
then do
swapMVar (lastclean server) time
clean server
else return ()
clean :: Server -> IO ()
clean server = do
let allowed = timeout server
clist <- takeMVar (clients server)
(newCList, removed) <- filterM' (timedout server allowed) clist
putMVar (clients server) (Seq.fromList newCList)
mapM_ (disconnect' server) removed
filterM' :: Monad m => (a -> m Bool) -> Seq.Seq a -> m ([a],[a])
filterM' pred seq = do
ls <- filterM pred (toList seq)
ls' <- filterM not' (toList seq)
return (ls, ls')
where not' a = do
val <- pred a
return $ not val
timedout :: Server -> NominalDiffTime -> ClientConn -> IO Bool
timedout server allowed client = do
time <- getCurrentTime
last <- readMVar (timestamp client)
dead' <- readMVar (dead client)
let passed = diffUTCTime time last
return $ not $ (passed > allowed) || (dead' == True)
disconnect' :: Server -> ClientConn -> IO ()
disconnect' server client = do
(dHandler server) server client
flush server client
(wio,rio) <- readMVar $ tid client
killThread wio
killThread rio
swapMVar (dead client) True
return ()
flush :: Server -> ClientConn -> IO ()
flush server client = do
messages <- takeAll $ msgList client
mapM_ (hPutStrLn (chandle client)) messages
acceptCon :: Server -> Net.Socket -> IO ()
acceptCon server sock = do
(handle, host, pid) <- Net.accept sock
hSetBuffering handle NoBuffering
id <- takeMVar (nextID server)
putMVar (nextID server) (id+1)
conn <- newConn id handle host pid server
time <- getCurrentTime
putMVar (timestamp conn) time
put (clients server) conn
wio <- forkIO $ writeClient conn
rio <- forkIO $ readClient conn (cmdList server)
putMVar (tid conn) (wio,rio)
(cHandler server) server conn
acceptCon server sock
readClient :: ClientConn -> List Message -> IO ()
readClient client queue = do
either <- try $ hGetLine (chandle client) :: IO (Either IOException String)
case either of
Left e -> do
swapMVar (dead client) True
return ()
Right val -> do
time <- getCurrentTime
swapMVar (timestamp client) time
put queue (Message val client)
readClient client queue
writeClient :: ClientConn -> IO ()
writeClient client = do
queue <- takeAll (msgList client)
if queue == []
then do
delay (1000*100)
writeClient client
else do
debugLn' (lock (serv client)) "Client List non-empty. Writing to client."
either <- try $ mapM_ (hPutStrLn (chandle client)) queue :: IO (Either IOException ())
case either of
Left e -> do
debugLn' (lock (serv client)) $ "Could not read from handle: " ++ (show e)
swapMVar (dead client) True
return ()
Right _ -> writeClient client
putStrLn' :: Lock.Lock -> String -> IO ()
putStrLn' lock string = do
Lock.acquire lock
putStrLn string
Lock.release lock
hPutStrLn :: Handle -> String -> IO ()
hPutStrLn handle string = ByteS.hPutStrLn handle (ByteS.pack string)
hGetLine :: Handle -> IO String
hGetLine handle = do
line <- ByteS.hGetLine handle
return $ ByteS.unpack line
debug = False
debugLn' :: Lock.Lock -> String -> IO ()
debugLn' lock str = if debug then putStrLn' lock str else return ()
emptyList :: IO (List a)
emptyList = newMVar Seq.empty
takeAll :: List a -> IO [a]
takeAll queue = do
q <- swapMVar queue Seq.empty
return $ toList q
readAll :: List a -> IO [a]
readAll queue = do
q <- readMVar queue
return $ toList q
modifyMVar :: MVar a -> (a -> a) -> IO ()
modifyMVar mvar f = do
el <- takeMVar mvar
putMVar mvar (f el)
put :: List a -> a -> IO ()
put queue el = modifyMVar queue (Seq.|> el)