Fixed wrong message channel order while disconnecting

hask-irc-core/Network/IRC/Bot.hs

@@ -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

hask-irc-core/Network/IRC/Client.hs

@@ -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)
 

hask-irc-core/Network/IRC/Util.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 module Network.IRC.Util where
 
-import qualified Data.Text.Format        as TF
+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