module Holumbus.Network.DoWithServer
(
Client (..)
, ServerAction
, LineConverter
, doWithServer
)
where
import System.Log.Logger
import System.IO
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad (liftM)
import Network
import Holumbus.Common.Utils ( handleAll )
localLogger :: String
localLogger = "Holumbus.Network.DoWithServer"
data Client a = Client (TChan a) Handle HostName PortNumber
instance Show (Client a) where
show (Client _ _ host port) = "Client " ++ host ++ ":"++show port
instance Eq (Client a) where
(==) (Client _ _ host1 port1) (Client _ _ host2 port2) = host1 == host2 && port1 == port2
(/=) c1 c2 = not (c1 == c2)
instance Ord (Client a) where
compare (Client _ _ host1 port1) (Client _ _ host2 port2) = compare (host1,port1) (host2,port2)
type ServerAction a = a -> Client a -> [Client a] -> IO [Client a]
type LineConverter a = String -> a
doWithServer :: (Show a) => Int -> ServerAction a -> LineConverter a -> String -> IO ()
doWithServer port action converter prompt =
withSocketsDo $ do
servSock <- listenOn . PortNumber . fromIntegral $ port
handleAll (\_ -> sClose servSock) $ do
acceptChan <- atomically newTChan
_ <- forkIO $ acceptLoop servSock acceptChan converter prompt
mainLoop servSock acceptChan [] action prompt
acceptLoop :: Socket -> TChan (Client a) -> LineConverter a -> String -> IO ()
acceptLoop servSock chan convert prompt = do
(handle, host, port) <- accept servSock
hPrompt handle prompt
ch <- atomically newTChan
_ <- forkIO $ clientLoop (Client ch handle host port) convert
atomically $ writeTChan chan (Client ch handle host port)
acceptLoop servSock chan convert prompt
clientLoop :: Client a -> LineConverter a -> IO ()
clientLoop client@(Client chan handle _ _) convert =
handleAll (\_ -> do { infoM localLogger $ "Client disconnected: "++show client; hClose handle; return () }) $ do
listenLoop (liftM convert $ hGetLine handle) chan
listenLoop :: IO a -> TChan a -> IO ()
listenLoop act chan =
sequence_ (repeat (act >>= atomically . writeTChan chan))
mainLoop :: (Show a) => Socket -> TChan (Client a) -> [(Client a)] -> ServerAction a -> String-> IO ()
mainLoop servSock acceptChan clients f prompt= do
r <- atomically $ (Left `fmap` readTChan acceptChan)
`orElse`
(Right `fmap` tselect clients)
case r of
Left sender -> do
infoM localLogger $ "new client" ++ show sender
mainLoop servSock acceptChan (sender:clients) f prompt
Right (line, sender) -> do
debugM localLogger $ (show sender) ++ " [ " ++ show line ++ " ]"
clients' <- f line sender clients
debugM localLogger $ "Num of Clients: " ++ show (length clients')
mainLoop servSock acceptChan (clients') f prompt
hPrompt :: Handle -> String -> IO ()
hPrompt h p = do
openhandle <- hIsOpen h
if openhandle then do
hPutStr h p
hFlush h
else return ()
tselect :: [(Client a)] -> STM (a, Client a)
tselect = foldl orElse retry . map (\client@(Client ch _ _ _) -> (\line -> (line,client)) `fmap` readTChan ch)