111 lines
3.4 KiB
Haskell
111 lines
3.4 KiB
Haskell
module Skat.AI.Server where
|
|
|
|
import qualified Network.Socket as Net
|
|
import qualified System.IO as Sys
|
|
import Control.Concurrent
|
|
import Control.Concurrent.Chan
|
|
import Control.Monad (forever)
|
|
import Control.Monad.Reader
|
|
import Data.List.Split
|
|
|
|
data Buffering = NoBuffering
|
|
| LengthBuffering
|
|
| DelimiterBuffering String
|
|
deriving (Show)
|
|
|
|
data ServerEnv = ServerEnv
|
|
{ buffering :: Buffering -- ^ Buffermode
|
|
, socket :: Net.Socket -- ^ the socket used to communicate
|
|
, global :: Chan String
|
|
, onReceive :: OnReceive
|
|
}
|
|
|
|
instance Show ServerEnv where
|
|
show env = "A Server"
|
|
|
|
type Server = ReaderT ServerEnv IO
|
|
|
|
type OnReceive = Sys.Handle -> Net.SockAddr -> String -> Server ()
|
|
|
|
broadcast :: String -> Server ()
|
|
broadcast msg = do
|
|
bufmode <- asks buffering
|
|
chan <- asks global
|
|
case bufmode of
|
|
DelimiterBuffering delim -> liftIO $ writeChan chan $ msg ++ delim
|
|
_ -> liftIO $ writeChan chan msg
|
|
|
|
send :: Sys.Handle -> String -> Server ()
|
|
send connhdl msg = do
|
|
bufmode <- asks buffering
|
|
case bufmode of
|
|
DelimiterBuffering delim -> liftIO $ Sys.hPutStr connhdl $ msg ++ delim
|
|
_ -> liftIO $ Sys.hPutStr connhdl msg
|
|
|
|
|
|
-- | Initialize a new server with the given port number and buffering mode
|
|
initServer :: Net.PortNumber -> Buffering -> OnReceive -> IO ServerEnv
|
|
initServer port buffermode handler = do
|
|
sock <- Net.socket Net.AF_INET Net.Stream 0
|
|
Net.setSocketOption sock Net.ReuseAddr 1
|
|
addr <- Net.addrAddress <$> resolve
|
|
Net.bind sock addr
|
|
Net.listen sock 5
|
|
chan <- newChan
|
|
forkIO $ forever $ do
|
|
msg <- readChan chan -- clearing the main channel
|
|
return ()
|
|
return (ServerEnv buffermode sock chan handler)
|
|
where resolve = do
|
|
let hints = Net.defaultHints { Net.addrSocketType = Net.Stream }
|
|
addrs <- Net.getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port)
|
|
return $ head addrs
|
|
|
|
close :: ServerEnv -> IO ()
|
|
close = Net.close . socket
|
|
|
|
-- | Looping over requests and establish connection
|
|
procRequests :: Server ()
|
|
procRequests = do
|
|
sock <- asks socket
|
|
(conn, clientaddr) <- liftIO $ Net.accept sock
|
|
env <- ask
|
|
liftIO $ forkIO $ runReaderT (procMessages conn clientaddr) env
|
|
procRequests
|
|
|
|
-- | Handle one client
|
|
procMessages :: Net.Socket -> Net.SockAddr -> Server ()
|
|
procMessages conn clientaddr = do
|
|
connhdl <- liftIO $ Net.socketToHandle conn Sys.ReadWriteMode
|
|
liftIO $ Sys.hSetBuffering connhdl Sys.NoBuffering
|
|
globalChan <- asks global
|
|
|
|
commChan <- liftIO $ dupChan globalChan
|
|
|
|
reader <- liftIO $ forkIO $ forever $ do
|
|
msg <- readChan commChan
|
|
Sys.hPutStrLn connhdl msg
|
|
|
|
handler <- asks onReceive
|
|
messages <- liftIO $ Sys.hGetContents connhdl
|
|
buffermode <- asks buffering
|
|
case buffermode of
|
|
DelimiterBuffering delimiter ->
|
|
mapM_ (handler connhdl clientaddr) (splitOn delimiter messages)
|
|
LengthBuffering -> liftIO $ putStrLn (take 4 messages)
|
|
_ -> return ()
|
|
|
|
-- clean up
|
|
liftIO $ do killThread reader
|
|
Sys.hClose connhdl
|
|
|
|
sampleHandler :: OnReceive
|
|
sampleHandler connhdl addr query = do
|
|
liftIO $ putStrLn $ "new query " ++ query
|
|
send connhdl $ "> " ++ query
|
|
|
|
main :: IO ()
|
|
main = do
|
|
env <- initServer 4242 LengthBuffering sampleHandler
|
|
runReaderT procRequests env
|