Minor refactoring
This commit is contained in:
parent
affa18de55
commit
d749c5d06a
@ -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,
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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"
|
|
Loading…
Reference in New Issue
Block a user