abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixed wrong message channel order while disconnecting

master
Abhinav Sarkar 2014-10-05 15:58:20 +05:30
parent 7aea1a9fe8
commit f43a18348d
3 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hask-irc-core/Network/IRC/Bot.hs
View File

@ -29,7 +29,7 @@ import Network.IRC.Util
$(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR]) $(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq) data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq)
data In = Timeout | EOD | Msg Message deriving (Show, Eq) data In = Timeout | EOD | Msg !Message deriving (Show, Eq)
sendCommandLoop :: MessageChannel Message -> Bot -> IO () sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
sendCommandLoop commandChan bot@Bot { .. } = do sendCommandLoop commandChan bot@Bot { .. } = do

19
hask-irc-core/Network/IRC/Client.hs
View File

@ -37,11 +37,11 @@ import Network.IRC.Util
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR]) $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
data ConnectionResource = ConnectionResource data ConnectionResource = ConnectionResource
{ bot :: Bot { bot :: !Bot
, botStatus :: MVar BotStatus , botStatus :: !(MVar BotStatus)
, inChannel :: MessageChannel In , inChannel :: !(MessageChannel In)
, mainMsgChannel :: MessageChannel Message , mainMsgChannel :: !(MessageChannel Message)
, handlerMsgChannels :: [MessageChannel Message] , handlerMsgChannels :: !(Map MsgHandlerName (MessageChannel Message))
} }
connect :: BotConfig -> IO ConnectionResource connect :: BotConfig -> IO ConnectionResource
@ -63,7 +63,7 @@ connect botConfig@BotConfig { .. } = do
mempty (mapToList msgHandlersChans) mempty (mapToList msgHandlersChans)
let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'} let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'}
let msgHandlerChannels = map snd (mapValues msgHandlersChans) let msgHandlerChannels = map snd msgHandlersChans
let msgHandlers = map fst msgHandlersChans let msgHandlers = map fst msgHandlersChans
return $ ConnectionResource return $ ConnectionResource
@ -132,7 +132,8 @@ runBotIntenal botConfig' = withSocketsDo $ do
Just UserInterrupt -> debugM "User interrupt" >> return Interrupted Just UserInterrupt -> debugM "User interrupt" >> return Interrupted
_ -> debugM ("Exception! " ++ show e) >> return Errored _ -> debugM ("Exception! " ++ show e) >> return Errored
runHandler botConfig ((msgHandlerName, handler), msgChannel) = receiveMessage msgChannel >>= go runHandler :: BotConfig -> (MsgHandlerName, (MsgHandler, MessageChannel Message)) -> IO ()
runHandler botConfig (msgHandlerName, (handler, msgChannel)) = receiveMessage msgChannel >>= go
where where
go msg@Message { .. } go msg@Message { .. }
| Just QuitCmd <- fromMessage message = do | Just QuitCmd <- fromMessage message = do
@ -143,7 +144,7 @@ runBotIntenal botConfig' = withSocketsDo $ do
| otherwise = do | otherwise = do
resps <- handleMessage handler botConfig msg resps <- handleMessage handler botConfig msg
forM_ resps $ sendMessage msgChannel forM_ resps $ sendMessage msgChannel
runHandler botConfig ((msgHandlerName, handler), msgChannel) runHandler botConfig (msgHandlerName, (handler, msgChannel))
run = bracket (connect botConfigWithCore) disconnect $ run = bracket (connect botConfigWithCore) disconnect $
\ConnectionResource { .. } -> \ConnectionResource { .. } ->
@ -156,7 +157,7 @@ runBotIntenal botConfig' = withSocketsDo $ do
fork $ sendCommandLoop mainMsgChannel bot fork $ sendCommandLoop mainMsgChannel bot
fork $ readMessageLoop botStatus inChannel bot oneSec fork $ readMessageLoop botStatus inChannel bot oneSec
forM_ (zip (mapToList msgHandlers) handlerMsgChannels) $ forM_ (mapToList . asMap $ mergeMaps msgHandlers handlerMsgChannels) $
void . fork . runHandler botConfig void . fork . runHandler botConfig
runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel) runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel)

16
hask-irc-core/Network/IRC/Util.hs
View File

@ -1,13 +1,15 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.IRC.Util where module Network.IRC.Util where
import qualified Data.Text.Format as TF import qualified Data.Text.Format as TF
import ClassyPrelude import ClassyPrelude
import Control.Monad.Base (MonadBase) import Control.Monad.Base (MonadBase)
import Data.Convertible (convert) import Data.Convertible (convert)
import Data.Maybe (fromJust)
import Data.Text (strip) import Data.Text (strip)
import Data.Time (diffUTCTime) import Data.Time (diffUTCTime)
@ -20,6 +22,18 @@ mapKeys = map fst . mapToList
mapValues :: IsMap map => map -> [MapValue map] mapValues :: IsMap map => map -> [MapValue map]
mapValues = map snd . mapToList mapValues = map snd . mapToList
mergeMaps :: forall map map1 map2.
(IsMap map1, IsMap map2, IsMap map,
MapValue map ~ (MapValue map1, MapValue map2),
ContainerKey map1 ~ ContainerKey map,
ContainerKey map2 ~ ContainerKey map) =>
map1 -> map2 -> map
mergeMaps map1 map2 =
flip (`foldl'` mempty) (mapKeys map1) $ \acc key ->
if key `member` map2
then insertMap key (fromJust $ lookup key map1, fromJust $ lookup key map2) acc
else acc
whenJust :: Monad m => Maybe t -> (t -> m ()) -> m () whenJust :: Monad m => Maybe t -> (t -> m ()) -> m ()
whenJust m f = maybe (return ()) f m whenJust m f = maybe (return ()) f m