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

View File

@ -29,7 +29,7 @@ import Network.IRC.Util
$(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
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 commandChan bot@Bot { .. } = do

View File

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

View File

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.IRC.Util where
@ -8,6 +9,7 @@ import qualified Data.Text.Format as TF
import ClassyPrelude
import Control.Monad.Base (MonadBase)
import Data.Convertible (convert)
import Data.Maybe (fromJust)
import Data.Text (strip)
import Data.Time (diffUTCTime)
@ -20,6 +22,18 @@ mapKeys = map fst . mapToList
mapValues :: IsMap map => map -> [MapValue map]
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 m f = maybe (return ()) f m