Refactoring, reformatting and logging.

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

@@ -13,7 +13,7 @@ import qualified System.Log.Logger as HSL
 import ClassyPrelude
 import Control.Concurrent.Lifted  (threadDelay)
 import Control.Exception.Lifted   (evaluate)
-import Control.Monad.State.Strict (get, put, evalStateT)
+import Control.Monad.State.Strict (get, put)
 import Data.Time                  (addUTCTime)
 import System.IO                  (hIsEOF)
 import System.Timeout             (timeout)
@@ -56,18 +56,17 @@ parseLine botConfig@BotConfig { .. } time line msgParts =
 sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
 sendCommandLoop commandChan bot@Bot { .. } = do
   msg@(Message _ _ cmd) <- receiveMessage commandChan
-  (exs, lines_) <- formatCommand botConfig msg
+  (exs, lines_)         <- formatCommand botConfig msg
 
   forM_ exs $ \(ex :: SomeException) ->
     errorM ("Error while formatting command: " ++ show cmd ++ "\nError: " ++ show ex)
 
-  unless (null lines_) $
+  forM_ lines_ $ \line -> do
     handle (\(e :: SomeException) -> do
               errorM ("Error while writing to connection: " ++ show e)
-              closeMessageChannel commandChan) $
-      forM_ lines_ $ \line -> do
-        TF.hprint botSocket "{}\r\n" $ TF.Only line
-        infoM . unpack $ "> " ++ line
+              closeMessageChannel commandChan) $ do
+      TF.hprint botSocket "{}\r\n" $ TF.Only line
+      infoM . unpack $ "> " ++ line
 
   commandChanClosed <- isClosedMessageChannel commandChan
   unless commandChanClosed $
@@ -76,12 +75,11 @@ sendCommandLoop commandChan bot@Bot { .. } = do
       _            -> sendCommandLoop commandChan bot
 
 readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
-readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mempty
+readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = loop mempty
   where
     msgPartTimeout = 10
 
-    loop = do
-      msgParts  <- get
+    loop msgParts = do
       botStatus <- readMVar mvBotStatus
       case botStatus of
         Disconnected -> io $ closeMessageChannel inChan
@@ -104,25 +102,26 @@ readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mem
               Right (Just EOS)              -> sendMessage inChan EOD >> return msgParts
 
           limit <- io $ map (addUTCTime (- msgPartTimeout)) getCurrentTime
-          put $ validMsgParts limit msgParts'
-          loop
-      where
-        validMsgParts limit =
-          foldl' (\m (k, v) -> insertWith (++) k [v] m) mempty
-          . concat
-          . filter ((> limit) . msgPartTime . snd . headEx . sortBy (flip $ comparing (msgPartTime . snd)))
-          . groupAllOn (fst &&& msgPartTarget . snd)
-          . asList . concatMap (uncurry (map . (,))) . mapToList
-
-        readLine = do
-          eof <- hIsEOF botSocket
-          if eof
-            then return EOS
-            else mask $ \unmask -> do
-              line <- map initEx . unmask $ hGetLine botSocket
-              infoM . unpack $ "< " ++ line
-              now <- getCurrentTime
-              return $ Line now line
+          loop $ validMsgParts limit msgParts'
+
+    validMsgParts limit =
+      foldl' (\m (k, v) -> insertWith (++) k [v] m) mempty
+      . concat
+      . filter ((> limit) . msgPartTime . snd . headEx . sortBy (flip $ comparing (msgPartTime . snd)))
+      . groupAllOn (fst &&& msgPartTarget . snd)
+      . asList
+      . concatMap (uncurry (map . (,)))
+      . mapToList
+
+    readLine = do
+      eof <- hIsEOF botSocket
+      if eof
+        then return EOS
+        else mask $ \unmask -> do
+          line <- map initEx . unmask $ hGetLine botSocket
+          infoM . unpack $ "< " ++ line
+          now <- getCurrentTime
+          return $ Line now line
 
 messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
 messageProcessLoop inChan messageChan = loop 0
@@ -139,14 +138,13 @@ messageProcessLoop inChan messageChan = loop 0
           then infoM "Timeout" >> return Disconnected
           else do
             when (status == Kicked) $
-              threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
+              threadDelay (5 * oneSec) >> (sendMessage messageChan =<< newMessage JoinCmd)
 
             mIn <- receiveMessage inChan
             case mIn of
               Timeout                  -> do
-                idleMsg <- newMessage IdleMsg
-                sendMessage messageChan idleMsg
-                sendWhoisMessage nick origNick
+                sendMessage messageChan =<< newMessage IdleMsg
+                sendWhoisMessage nick origNick idleFor
                 return Idle
               EOD                      -> infoM "Connection closed" >> return Disconnected
               Msg (msg@Message { .. }) -> do
@@ -162,25 +160,24 @@ messageProcessLoop inChan messageChan = loop 0
         NickAvailable    -> return ()
         _                -> loop 0
 
-      where
-        sendWhoisMessage nick origNick =
-          when (nick /= origNick && idleFor /= 0 && idleFor `mod` (10 * oneSec) == 0) $
-            (newMessage . WhoisCmd . nickToText $ origNick) >>= sendMessage messageChan
-
-        handleMsg nick origNick message mpass
-          | Just (JoinMsg user)     <- fromMessage message, userNick user == nick =
-              infoM "Joined" >> return Joined
-          | Just (KickMsg { .. })   <- fromMessage message, kickedNick == nick    =
-              infoM "Kicked" >> return Kicked
-          | Just NickInUseMsg       <- fromMessage message                        =
-              infoM "Nick already in use" >> return NickNotAvailable
-          | Just (ModeMsg { .. })   <- fromMessage message, modeUser == Self      = do
-              whenJust mpass $ \pass -> do
-                msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass
-                sendMessage messageChan msg
-              newMessage JoinCmd >>= sendMessage messageChan
-              return Connected
-          | Just (WhoisNoSuchNick n) <- fromMessage message, n == origNick        =
-              infoM "Original nick available" >> return NickAvailable
-          | otherwise                                                             =
-              return Connected
+    sendWhoisMessage nick origNick idleFor =
+      when (nick /= origNick && idleFor /= 0 && idleFor `mod` (10 * oneSec) == 0) $
+        sendMessage messageChan =<< (newMessage . WhoisCmd . nickToText $ origNick)
+
+    handleMsg nick origNick message mpass
+      | Just (JoinMsg user)     <- fromMessage message, userNick user == nick =
+          infoM "Joined" >> return Joined
+      | Just (KickMsg { .. })   <- fromMessage message, kickedNick == nick    =
+          infoM "Kicked" >> return Kicked
+      | Just NickInUseMsg       <- fromMessage message                        =
+          infoM "Nick already in use" >> return NickNotAvailable
+      | Just (ModeMsg { .. })   <- fromMessage message, modeUser == Self      = do
+          whenJust mpass $ \pass -> do
+            msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass
+            sendMessage messageChan msg
+            sendMessage messageChan =<< newMessage JoinCmd
+          return Connected
+      | Just (WhoisNoSuchNickMsg n) <- fromMessage message, n == origNick     =
+          infoM "Original nick available" >> return NickAvailable
+      | otherwise                                                             =
+          return Connected

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

@@ -38,7 +38,7 @@ $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
 
 data ConnectionResource = ConnectionResource
   { bot                :: !Bot
-  , botStatus          :: !(MVar BotStatus)
+  , botStatus          :: !(MVar BotStatus) -- TODO: is this really needed
   , inChannel          :: !(MessageChannel In)
   , mainMsgChannel     :: !(MessageChannel Message)
   , handlerMsgChannels :: !(Map MsgHandlerName (MessageChannel Message))
@@ -59,21 +59,27 @@ connect botConfig@BotConfig { .. } = do
   mainMsgChannel   <- newMessageChannel messageBus
 
   msgHandlersChans <- loadMsgHandlers messageBus
-  msgHandlerInfo'  <- foldM (\m (hn, (h, _)) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
-                        mempty (mapToList msgHandlersChans)
+  msgHandlerInfo'  <- flip (`foldM` mempty) (mapToList msgHandlersChans)
+                      $ \handlerInfo (handlerName, (handler, _)) -> do
+                          handlerHelp <- getHelp handler botConfig
+                          return $ insertMap handlerName handlerHelp handlerInfo
 
   let botConfig'         = botConfig { msgHandlerInfo = msgHandlerInfo'}
   let msgHandlerChannels = map snd msgHandlersChans
   let msgHandlers        = map fst msgHandlersChans
 
-  return $ ConnectionResource
-            (Bot botConfig' socket msgHandlers) mvBotStatus inChannel mainMsgChannel msgHandlerChannels
+  return ConnectionResource { bot                = (Bot botConfig' socket msgHandlers)
+                            , botStatus          = mvBotStatus
+                            , inChannel          = inChannel
+                            , mainMsgChannel     = mainMsgChannel
+                            , handlerMsgChannels = msgHandlerChannels
+                            }
   where
     connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
-                           `catch` (\(e :: SomeException) -> do
-                                      errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
-                                      threadDelay (5 * oneSec)
-                                      connectToWithRetry)
+                         `catch` (\(e :: SomeException) -> do
+                                    errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
+                                    threadDelay (5 * oneSec)
+                                    connectToWithRetry)
 
     mkMsgHandler name messageBus =
       case lookup name msgHandlerMakers of
@@ -119,7 +125,7 @@ runBotIntenal botConfig' = withSocketsDo $ do
   where
     botConfigWithCore = botConfig' {
       msgHandlerInfo =
-        foldl' (\m name -> insertMap name mempty m) mempty
+        foldl' (flip (`insertMap` mempty)) mempty
           (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers)
     , msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
     }
@@ -137,15 +143,15 @@ runBotIntenal botConfig' = withSocketsDo $ do
         Just UserInterrupt -> debugM "User interrupt"          >> return Interrupted
         _                  -> debugM ("Exception! " ++ show e) >> return Errored
 
+    -- TODO: handle handler errors?
     runHandler :: BotConfig -> (MsgHandlerName, (MsgHandler, MessageChannel Message)) -> IO ()
-    runHandler botConfig (msgHandlerName, (handler, msgChannel)) = receiveMessage msgChannel >>= go
+    runHandler botConfig (msgHandlerName, (handler, msgChannel)) = go =<< receiveMessage msgChannel
       where
         go msg@Message { .. }
           | Just QuitCmd <- fromMessage message = do
               debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
               stopMsgHandler handler botConfig
               closeMessageChannel msgChannel
-              return ()
           | otherwise = do
               resps <- handleMessage handler botConfig msg
               forM_ resps $ sendMessage msgChannel
@@ -161,10 +167,12 @@ runBotIntenal botConfig' = withSocketsDo $ do
           sendMessage mainMsgChannel =<< newMessage UserCmd
 
           fork $ sendCommandLoop mainMsgChannel bot
+                 `catch` (\(e :: SomeException) -> errorM $ "Error in sendCommandLoop: " ++ show e)
           fork $ readMessageLoop botStatus inChannel bot oneSec
+                 `catch` (\(e :: SomeException) -> errorM $ "Error in readMessageLoop: " ++ show e)
           forM_ (mapToList . asMap $ mergeMaps msgHandlers handlerMsgChannels) $
             void . fork . runHandler botConfig
-          runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel)
+          runIRC bot Connected $ messageProcessLoop inChannel mainMsgChannel
 
 -- | Creates and runs an IRC bot for given the config. This IO action runs forever.
 runBot :: BotConfig -- ^ The bot config used to create the bot.
@@ -172,14 +180,16 @@ runBot :: BotConfig -- ^ The bot config used to create the bot.
 runBot botConfig = do
   -- setup signal handling
   mainThreadId <- myThreadId
-  installHandler sigINT  (Catch $ throwTo mainThreadId UserInterrupt) Nothing
-  installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
+  let interruptMainThread = throwTo mainThreadId UserInterrupt
+  installHandler sigINT  (Catch interruptMainThread) Nothing
+  installHandler sigTERM (Catch interruptMainThread) Nothing
 
   -- setup logging
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
-  stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
-                     setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
+  stderrHandler <- streamHandler stderr DEBUG >>= \logHandler ->
+                     return . setFormatter logHandler $
+                       tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
   updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
 
   -- run

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

@@ -14,7 +14,7 @@ module Network.IRC.Configuration
 import qualified ClassyPrelude as P
 
 import ClassyPrelude hiding (lookup)
-import Data.Maybe (fromJust)
+import Data.Maybe           (fromJust)
 
 type Name = Text
 
@@ -64,7 +64,7 @@ data Value = String Text
            | List [Value]
            deriving (Eq, Show)
 
-newtype Configuration = Configuration { configMap :: (Map Name Value) } deriving (Show)
+newtype Configuration = Configuration { configMap :: Map Name Value } deriving (Show)
 
 fromMap :: Map Name Value -> Configuration
 fromMap = Configuration

hask-irc-core/Network/IRC/Internal/Types.hs

@@ -74,7 +74,7 @@ data BotConfig = BotConfig
   -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
   , cmdFormatters    :: ![CommandFormatter]
   -- | All the bot configuration so that message handlers can lookup their own specific configs.
-  , config           :: !(CF.Configuration)
+  , config           :: !CF.Configuration
   }
 
 instance Show BotConfig where

hask-irc-core/Network/IRC/Message/Types.hs

@@ -129,16 +129,15 @@ data ModeMsg       = ModeMsg { modeUser   :: !User
 instance MessageC ModeMsg
 
 -- | A message received as a response to a 'WhoisCmd'.
-data WhoisReplyMsg = WhoisNoSuchNick { whoisNick :: !Nick }
-                   | WhoisReplyMsg {
-                       whoisNick        :: !Nick
-                     , whoisUser        :: !Text
-                     , whoisHost        :: !Text
-                     , whoisRealName    :: !Text
-                     , whoisChannels    :: ![Text]
-                     , whoisServer      :: !Text
-                     , whoisServerInfo  :: !Text
-                     } deriving (Typeable, Show, Eq, Ord)
+data WhoisReplyMsg = WhoisNoSuchNickMsg { whoisNick :: !Nick }
+                   | WhoisNickInfoMsg { whoisNick        :: !Nick
+                                      , whoisUser        :: !Text
+                                      , whoisHost        :: !Text
+                                      , whoisRealName    :: !Text
+                                      , whoisChannels    :: ![Text]
+                                      , whoisServer      :: !Text
+                                      , whoisServerInfo  :: !Text
+                                      } deriving (Typeable, Show, Eq, Ord)
 instance MessageC WhoisReplyMsg
 
 -- | All other messages which are not parsed as any of the above message types.

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

@@ -14,7 +14,8 @@ pingParser :: MessageParser
 pingParser = MessageParser "ping" go
   where
     go _ time line _
-      | "PING :" `isPrefixOf` line = ParseDone (Message time line . toMessage . PingMsg . drop 6 $ line) []
+      | "PING :" `isPrefixOf` line =
+          flip ParseDone [] . Message time line . toMessage . PingMsg . drop 6 $ line
       | otherwise                  = ParseReject
 
 parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
@@ -65,7 +66,7 @@ defaultParser = MessageParser "default" go
     go _ time line _
       | "PING :" `isPrefixOf` line = ParseReject
       | otherwise                  =
-          flip ParseDone [] . Message time line $ toMessage $ OtherMsg source command target message
+          flip ParseDone [] . Message time line . toMessage . OtherMsg source command target $ message
       where
         (_, command, source, target, message) = parseMsgLine line
 
@@ -105,11 +106,10 @@ whoisParser = MessageParser "whois" go
 
     parse :: [MessagePart] -> WhoisReplyMsg
     parse myMsgParts =
-      let partMap = asMap $ foldl' (\m MessagePart { .. } ->
-                                      insertMap (words msgPartLine !! 1) msgPartLine m)
-                                   mempty myMsgParts
+      let partMap = asMap $ flip (`foldl'` mempty) myMsgParts $ \m MessagePart { .. } ->
+                              insertMap (words msgPartLine !! 1) msgPartLine m
       in case lookup "401" partMap of
-           Just line -> WhoisNoSuchNick . Nick $ words line !! 3
+           Just line -> WhoisNoSuchNickMsg . Nick $ words line !! 3
            Nothing   -> let
                splits311   = words . fromJust . lookup "311" $ partMap
                nick        = Nick (splits311 !! 3)
@@ -124,7 +124,7 @@ whoisParser = MessageParser "whois" go
                splits312   = words . fromJust . lookup "312" $ partMap
                server      = splits312 !! 4
                serverInfo  = drop 1 . unwords . drop 5 $ splits312
-             in WhoisReplyMsg nick user host realName channels server serverInfo
+             in WhoisNickInfoMsg nick user host realName channels server serverInfo
 
 defaultParsers :: [MessageParser]
 defaultParsers = [pingParser, namesParser, whoisParser, lineParser, defaultParser]

hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs

@@ -30,7 +30,7 @@ getLogFilePath :: BotConfig -> IO FilePath
 getLogFilePath BotConfig { .. } = do
   let logFileDir = CF.require "messagelogger.logdir" config :: Text
   createDirectoryIfMissing True (unpack logFileDir)
-  return $ (unpack logFileDir) </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
+  return $ unpack logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
 
 openLogFile :: FilePath -> IO Handle
 openLogFile logFilePath = do