Spilts server into more modules.
parent
fbac64d78a
commit
5e5baeab06
|
@ -0,0 +1,59 @@
|
|||
module Link.Client where
|
||||
|
||||
import Control.Exception hiding (handle)
|
||||
import Control.Concurrent hiding (forkFinally)
|
||||
import Control.Monad (forever)
|
||||
import System.IO (hGetLine)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Link.Protocol
|
||||
import Link.Types
|
||||
import Link.Util
|
||||
|
||||
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
|
||||
forkFinally action fun =
|
||||
mask $ \restore ->
|
||||
forkIO (do r <- try (restore action); fun r)
|
||||
|
||||
race :: IO a -> IO b -> IO (Either a b)
|
||||
race ioa iob = do
|
||||
m <- newEmptyMVar
|
||||
bracket (forkFinally (fmap Left ioa) (putMVar m)) cancel $ \_ ->
|
||||
bracket (forkFinally (fmap Right iob) (putMVar m)) cancel $ \_ -> do
|
||||
r <- readMVar m
|
||||
case r of
|
||||
Left e -> throwIO e
|
||||
Right a -> return a
|
||||
where
|
||||
cancel t = throwTo t ThreadKilled
|
||||
|
||||
sendMessage :: Message -> Client -> IO ()
|
||||
sendMessage message Client {..} = writeChan clientChan message
|
||||
|
||||
runClient :: Server -> Client -> IO ()
|
||||
runClient Server {..} Client {..} = forever $ do
|
||||
r <- try $ race readCommand readMessage
|
||||
case r of
|
||||
Left (e :: SomeException) -> printf "Exception: %s\n" (show e)
|
||||
Right cm -> case cm of
|
||||
Left mcommand -> case mcommand of
|
||||
Nothing -> printf "Could not parse command\n"
|
||||
Just command -> handleCommand command
|
||||
Right message -> handleMessage message
|
||||
where
|
||||
readCommand = do
|
||||
command <- hGetLine clientHandle
|
||||
printf "<%s>: %s\n" (userName clientUser) command
|
||||
return $ parseCommand command
|
||||
|
||||
readMessage = readChan clientChan
|
||||
|
||||
handleCommand (PrivMsg user msg) =
|
||||
withMVar serverUsers $ \clientMap ->
|
||||
case Map.lookup user clientMap of
|
||||
Nothing -> printf "No such user: %s\n" (userName user)
|
||||
Just client -> sendMessage (PrivMsg clientUser msg) client
|
||||
|
||||
handleMessage = printToHandle clientHandle . formatMessage
|
|
@ -1,18 +1,19 @@
|
|||
module Link.Server where
|
||||
|
||||
import Control.Exception (finally, bracket, throwIO, try, SomeException,
|
||||
AsyncException(ThreadKilled))
|
||||
import Control.Concurrent
|
||||
import Control.Exception hiding (handle)
|
||||
import Control.Concurrent hiding (forkFinally)
|
||||
import Control.Monad (forever)
|
||||
import Network (withSocketsDo, listenOn, accept, PortID(..))
|
||||
import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..),
|
||||
universalNewlineMode, hGetLine, Handle, stdout)
|
||||
import Text.Printf (printf, hPrintf)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Link.Client
|
||||
import Link.Protocol
|
||||
import Link.Types
|
||||
import Link.Util
|
||||
|
||||
runServer :: Int -> IO ()
|
||||
runServer port = withSocketsDo $ do
|
||||
|
@ -24,10 +25,7 @@ runServer port = withSocketsDo $ do
|
|||
forever $ do
|
||||
(handle, host, port') <- accept sock
|
||||
printf "Accepted connection from %s: %s\n" host (show port')
|
||||
forkFinally (connectClient server handle) (\_ -> hClose handle)
|
||||
|
||||
printToHandle :: Handle -> String -> IO ()
|
||||
printToHandle handle str = hPrintf handle "%s\n" str
|
||||
forkIO (connectClient server handle) `finally` (hClose handle)
|
||||
|
||||
connectClient :: Server -> Handle -> IO ()
|
||||
connectClient server handle = do
|
||||
|
@ -61,47 +59,6 @@ checkAddClient Server {..} user@User {..} handle =
|
|||
printf "New user connected: %s\n" userName
|
||||
return (Map.insert user client clientMap, Just client)
|
||||
|
||||
race :: IO a -> IO b -> IO (Either a b)
|
||||
race ioa iob = do
|
||||
m <- newEmptyMVar
|
||||
bracket (forkFinally (fmap Left ioa) (putMVar m)) cancel $ \_ ->
|
||||
bracket (forkFinally (fmap Right iob) (putMVar m)) cancel $ \_ -> do
|
||||
r <- readMVar m
|
||||
case r of
|
||||
Left e -> throwIO e
|
||||
Right a -> return a
|
||||
where
|
||||
cancel t = throwTo t ThreadKilled
|
||||
|
||||
sendMessage :: Message -> Client -> IO ()
|
||||
sendMessage message Client {..} = writeChan clientChan message
|
||||
|
||||
runClient :: Server -> Client -> IO ()
|
||||
runClient Server {..} Client {..} = forever $ do
|
||||
r <- try $ race readCommand readMessage
|
||||
case r of
|
||||
Left (e :: SomeException) -> printf "Exception: %s\n" (show e)
|
||||
Right cm -> case cm of
|
||||
Left mcommand -> case mcommand of
|
||||
Nothing -> printf "Could not parse command\n"
|
||||
Just command -> handleCommand command
|
||||
Right message -> handleMessage message
|
||||
where
|
||||
readCommand = do
|
||||
command <- hGetLine clientHandle
|
||||
printf "<%s>: %s\n" (userName clientUser) command
|
||||
return $ parseCommand command
|
||||
|
||||
readMessage = readChan clientChan
|
||||
|
||||
handleCommand (PrivMsg user msg) =
|
||||
withMVar serverUsers $ \clientMap ->
|
||||
case Map.lookup user clientMap of
|
||||
Nothing -> printf "No such user: %s\n" (userName user)
|
||||
Just client -> sendMessage (PrivMsg clientUser msg) client
|
||||
|
||||
handleMessage = printToHandle clientHandle . formatMessage
|
||||
|
||||
removeClient :: Server -> User -> IO ()
|
||||
removeClient Server {..} user =
|
||||
modifyMVar_ serverUsers $ \clientMap ->
|
||||
|
|
|
@ -0,0 +1,7 @@
|
|||
module Link.Util where
|
||||
|
||||
import System.IO (Handle)
|
||||
import Text.Printf (hPrintf)
|
||||
|
||||
printToHandle :: Handle -> String -> IO ()
|
||||
printToHandle handle str = hPrintf handle "%s\n" str
|
Loading…
Reference in New Issue