abhin4v/link
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Moves client channels to TChan

Browse Source
This commit is contained in:
Abhinav Sarkar 2015-09-10 13:20:55 +05:30
parent 4941ab9bd5
commit 130b556c56
5 changed files with 62 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
link.cabal
View File

@ -25,7 +25,8 @@ library
build-depends: base >= 4.7 && < 5,
network >= 2.6 && < 2.7,
containers >= 0.5 && < 0.6,
time >= 1.4 && < 1.6
time >= 1.4 && < 1.6,
stm >= 2.4 && < 2.5
default-language: Haskell2010
executable link-exe

76
src/Link/Client.hs
View File

@ -1,12 +1,13 @@
module Link.Client where
import Control.Concurrent hiding (forkFinally)
import Control.Exception hiding (handle)
import Control.Monad (void)
import Data.Time (getCurrentTime, diffUTCTime)
import System.IO (hGetLine)
import System.Timeout (timeout)
import Text.Printf (printf)
import Control.Concurrent.STM (STM, writeTChan, readTChan, atomically, orElse)
import Control.Concurrent hiding (forkFinally)
import Control.Exception hiding (handle)
import Control.Monad (void, forever)
import Data.Time (getCurrentTime, diffUTCTime)
import System.IO (hGetLine)
import System.Timeout (timeout)
import Text.Printf (printf)
import qualified Data.Map.Strict as Map
@ -19,38 +20,34 @@ 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)) killThread $ \_ ->
bracket (forkFinally (fmap Right iob) (putMVar m)) killThread $ \_ -> do
r <- readMVar m
case r of
Left e -> throwIO e
Right a -> return a
sendMessage :: Client -> Message -> STM ()
sendMessage Client {..} = writeTChan clientChan
sendMessage :: Client -> Message -> IO ()
sendMessage Client {..} = writeChan clientChan
sendMessageIO :: Client -> Message -> IO ()
sendMessageIO client = atomically . sendMessage client
sendResponse :: Client -> Message -> IO ()
sendResponse Client {..} = printToHandle clientHandle . formatMessage
runClient :: Server -> Client -> IO ()
runClient Server {..} client@Client {..} = do
clientAlive <- newMVar True
pingThread <- forkIO $ ping clientAlive
run clientAlive `finally` killThread pingThread
clientAlive <- newMVar True
pingThread <- forkIO $ ping clientAlive `finally` killClient clientAlive
commandThread <- forkIO $ readCommands `finally` killClient clientAlive
run clientAlive `finally` (killThread pingThread >> killThread commandThread)
where
pingDelay = 120
pingDelayMicros = pingDelay * 1000 * 1000
killClient clientAlive = void $ swapMVar clientAlive False
ping clientAlive = do
sendMessage client Ping
sendMessageIO client Ping
threadDelay pingDelayMicros
now <- getCurrentTime
pongTime <- readMVar clientPongTime
if diffUTCTime now pongTime > fromIntegral pingDelay
then void $ swapMVar clientAlive False
then killClient clientAlive
else ping clientAlive
run clientAlive = do
@ -58,32 +55,29 @@ runClient Server {..} client@Client {..} = do
if not alive
then printf "Closing connection: %s\n" (userName clientUser)
else do
r <- try . timeout pingDelayMicros $ race readCommand readMessage
r <- try . timeout pingDelayMicros . atomically . readTChan $ clientChan
case r of
Left (e :: SomeException) -> printf "Exception: %s\n" (show e)
Right g -> case g of
Nothing -> run clientAlive
Just cm -> do
case cm of
Left mcommand -> case mcommand of
Nothing -> printf "Could not parse command\n"
Just command -> handleCommand command clientAlive
Right message -> sendResponse client message
run clientAlive
Right g -> do
case g of
Nothing -> return ()
Just message -> handleMessage message clientAlive
run clientAlive
readCommand = do
readCommands = forever $ do
command <- hGetLine clientHandle
printf "<%s>: %s\n" (userName clientUser) command
return $ parseCommand command
case parseCommand command of
Nothing -> printf "Could not parse command: %s\n" command
Just c -> sendMessageIO client c
readMessage = readChan clientChan
handleCommand (Msg user msg) _ =
handleMessage (Msg user msg) _ =
withMVar serverUsers $ \clientMap ->
case Map.lookup user clientMap of
Nothing -> sendResponse client $ NoSuchUser (userName user)
Just client' -> sendMessage client' $ Msg clientUser msg
handleCommand Pong _ = do
Just client' -> sendMessageIO client' $ MsgReply clientUser msg
handleMessage Pong _ = do
now <- getCurrentTime
void $ swapMVar clientPongTime now
handleCommand Quit clientAlive = void $ swapMVar clientAlive False
handleMessage Quit clientAlive = killClient clientAlive
handleMessage message _ = sendResponse client message

10
src/Link/Protocol.hs
View File

@ -12,8 +12,8 @@ parseCommand command = case words command of
_ -> Nothing
formatMessage :: Message -> String
formatMessage (Msg user msg) = printf "MSG %s %s" (userName user) msg
formatMessage (NameInUse name) = printf "NAMEINUSE %s" name
formatMessage (Connected name) = printf "CONNECTED %s" name
formatMessage Ping = "PING"
formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name
formatMessage (MsgReply user msg) = printf "MSG %s %s" (userName user) msg
formatMessage (NameInUse name) = printf "NAMEINUSE %s" name
formatMessage (Connected name) = printf "CONNECTED %s" name
formatMessage Ping = "PING"
formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name

19
src/Link/Server.hs
View File

@ -1,13 +1,14 @@
module Link.Server where
import Control.Concurrent
import Control.Exception hiding (handle)
import Control.Monad (forever)
import Data.Time (getCurrentTime)
import Network (withSocketsDo, listenOn, accept, PortID(..))
import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..),
universalNewlineMode, hGetLine, Handle, stdout)
import Text.Printf (printf)
import Control.Concurrent.STM (newTChanIO)
import Control.Exception hiding (handle)
import Control.Monad (forever)
import Data.Time (getCurrentTime)
import Network (withSocketsDo, listenOn, accept, PortID(..))
import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..),
universalNewlineMode, hGetLine, Handle, stdout)
import Text.Printf (printf)
import qualified Data.Map.Strict as Map
@ -19,8 +20,10 @@ import Link.Util
runServer :: Int -> IO ()
runServer port = withSocketsDo $ do
hSetBuffering stdout LineBuffering
serverUsers <- newMVar Map.empty
let server = Server serverUsers
sock <- listenOn . PortNumber . fromIntegral $ port
printf "Listening on port %d\n" port
forever $ do
@ -55,7 +58,7 @@ checkAddClient Server {..} user@User {..} handle =
if Map.member user clientMap
then return (clientMap, Nothing)
else do
clientChan <- newChan
clientChan <- newTChanIO
now <- getCurrentTime
clientPongTime <- newMVar now
let client = Client user handle clientChan clientPongTime

14
src/Link/Types.hs
View File

@ -1,12 +1,15 @@
module Link.Types where
import Control.Concurrent (MVar, Chan)
import Data.Time (UTCTime)
import System.IO (Handle)
import Control.Concurrent (MVar)
import Control.Concurrent.STM (TVar, TChan)
import Data.Time (UTCTime)
import System.IO (Handle)
import qualified Data.Map as Map
import qualified Data.Set as Set
type UserName = String
type RoomName = String
data User = User { userName :: !UserName }
deriving (Show, Eq, Ord)
@ -14,7 +17,7 @@ data User = User { userName :: !UserName }
data Client = Client {
clientUser :: !User
, clientHandle :: !Handle
, clientChan :: !(Chan Message)
, clientChan :: !(TChan Message)
, clientPongTime :: MVar UTCTime
}
@ -25,8 +28,9 @@ data Server = Server {
data Message = NameInUse UserName
| Connected UserName
| Ping
| MsgReply User String
| NoSuchUser UserName
| Pong
| Msg User String
| NoSuchUser UserName
| Quit
deriving (Show, Eq)