Minor refactoring

This commit is contained in:
Abhinav Sarkar 2015-09-10 15:55:54 +05:30
parent affa18de55
commit d749c5d06a
5 changed files with 13 additions and 19 deletions

View File

@ -19,7 +19,6 @@ library
Link.Types, Link.Types,
Link.Protocol, Link.Protocol,
Link.Client Link.Client
other-modules: Link.Util
default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections, NamedFieldPuns BangPatterns, TupleSections, NamedFieldPuns
build-depends: base >= 4.7 && < 5, build-depends: base >= 4.7 && < 5,

View File

@ -5,16 +5,15 @@ import Control.Concurrent hiding (forkFinally)
import Control.Exception hiding (handle) import Control.Exception hiding (handle)
import Control.Monad (void, forever, when, unless, forM_) import Control.Monad (void, forever, when, unless, forM_)
import Data.Time (getCurrentTime, diffUTCTime) import Data.Time (getCurrentTime, diffUTCTime)
import System.IO (hGetLine) import System.IO (hGetLine, Handle)
import System.Timeout (timeout) import System.Timeout (timeout)
import Text.Printf (printf) import Text.Printf (printf, hPrintf)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Link.Protocol import Link.Protocol
import Link.Types import Link.Types
import Link.Util
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally action fun = forkFinally action fun =
@ -30,6 +29,9 @@ sendMessageIO client = atomically . sendMessage client
tellMessage :: Channel -> Message -> STM () tellMessage :: Channel -> Message -> STM ()
tellMessage Channel {..} = writeTChan channelChan tellMessage Channel {..} = writeTChan channelChan
printToHandle :: Handle -> String -> IO ()
printToHandle handle = hPrintf handle "%s\n"
sendResponse :: Client -> Message -> IO () sendResponse :: Client -> Message -> IO ()
sendResponse Client {..} = printToHandle clientHandle . formatMessage sendResponse Client {..} = printToHandle clientHandle . formatMessage
@ -53,7 +55,7 @@ runClient Server {..} client@Client {..} = do
ping clientAlive = do ping clientAlive = do
sendMessageIO client Ping sendMessageIO client Ping
threadDelay pingDelayMicros threadDelay pingDelayMicros
now <- getCurrentTime now <- getCurrentTime
pongTime <- readMVar clientPongTime pongTime <- readMVar clientPongTime
if diffUTCTime now pongTime > fromIntegral pingDelay if diffUTCTime now pongTime > fromIntegral pingDelay
then killClient clientAlive then killClient clientAlive
@ -102,7 +104,7 @@ runClient Server {..} client@Client {..} = do
Just (channel@Channel {channelUsers}) -> do Just (channel@Channel {channelUsers}) -> do
modifyTVar' channelUsers $ Set.insert clientUser modifyTVar' channelUsers $ Set.insert clientUser
return channel return channel
Nothing -> do Nothing -> do
channel <- newChannel channelName $ Set.singleton clientUser channel <- newChannel channelName $ Set.singleton clientUser
modifyTVar' serverChannels $ Map.insert channelName channel modifyTVar' serverChannels $ Map.insert channelName channel
return channel return channel
@ -120,11 +122,11 @@ runClient Server {..} client@Client {..} = do
modifyTVar' serverChannels $ Map.delete channelName modifyTVar' serverChannels $ Map.delete channelName
modifyTVar' clientChannelChans $ Map.delete channelName modifyTVar' clientChannelChans $ Map.delete channelName
tellMessage channel $ Leaved channelName clientUser tellMessage channel $ Leaved channelName clientUser
Nothing -> return () Nothing -> return ()
handleMessage (Names channelName) _ = atomically $ do handleMessage (Names channelName) _ = atomically $ do
channelMap <- readTVar serverChannels channelMap <- readTVar serverChannels
users <- case Map.lookup channelName channelMap of users <- case Map.lookup channelName channelMap of
Just (Channel {channelUsers}) -> readTVar channelUsers Just (Channel {channelUsers}) -> readTVar channelUsers
Nothing -> return Set.empty Nothing -> return Set.empty
sendMessage client $ NamesReply channelName users sendMessage client $ NamesReply channelName users

View File

@ -19,13 +19,14 @@ parseCommand command = case words command of
formatMessage :: Message -> String formatMessage :: Message -> String
formatMessage (MsgReply user msg) = printf "MSG %s %s" (userName user) msg formatMessage (MsgReply user msg) = printf "MSG %s %s" (userName user) msg
formatMessage (TellReply channelName user msg) =
printf "TELL %s %s %s" channelName (userName user) msg
formatMessage (NameInUse name) = printf "NAMEINUSE %s" name formatMessage (NameInUse name) = printf "NAMEINUSE %s" name
formatMessage (Connected name) = printf "CONNECTED %s" name formatMessage (Connected name) = printf "CONNECTED %s" name
formatMessage Ping = "PING" formatMessage Ping = "PING"
formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name
formatMessage (Joined channelName user) = printf "JOINED %s %s" channelName (userName user) formatMessage (Joined channelName user) = printf "JOINED %s %s" channelName (userName user)
formatMessage (Leaved channelName user) = printf "LEFT %s %s" channelName (userName user) formatMessage (Leaved channelName user) = printf "LEFT %s %s" channelName (userName user)
formatMessage (NamesReply channelName users) = formatMessage (TellReply channelName user msg) =
printf "TELL %s %s %s" channelName (userName user) msg
formatMessage (NamesReply channelName users) =
printf "NAMES %s %s" channelName . unwords . map userName . Set.toList $ users printf "NAMES %s %s" channelName . unwords . map userName . Set.toList $ users
formatMessage msg = error $ printf "Cannot format message: %s" (show msg)

View File

@ -13,7 +13,6 @@ import qualified Data.Map.Strict as Map
import Link.Client import Link.Client
import Link.Protocol import Link.Protocol
import Link.Types import Link.Types
import Link.Util
runServer :: Int -> IO () runServer :: Int -> IO ()
runServer port = withSocketsDo $ do runServer port = withSocketsDo $ do

View File

@ -1,7 +0,0 @@
module Link.Util where
import System.IO (Handle)
import Text.Printf (hPrintf)
printToHandle :: Handle -> String -> IO ()
printToHandle handle = hPrintf handle "%s\n"