diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index 2ad735c..5d88638 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/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 + loop $ validMsgParts limit msgParts' - 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 + 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 + 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 - newMessage JoinCmd >>= sendMessage messageChan - return Connected - | Just (WhoisNoSuchNick n) <- fromMessage message, n == origNick = - infoM "Original nick available" >> return NickAvailable - | otherwise = - return Connected + 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 diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index 1b3c384..41e0b06 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Configuration.hs b/hask-irc-core/Network/IRC/Configuration.hs index 66d54e0..b8330dc 100644 --- a/hask-irc-core/Network/IRC/Configuration.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Internal/Types.hs b/hask-irc-core/Network/IRC/Internal/Types.hs index b143d69..98e1c93 100644 --- a/hask-irc-core/Network/IRC/Internal/Types.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Message/Types.hs b/hask-irc-core/Network/IRC/Message/Types.hs index aa5abfe..661daa1 100644 --- a/hask-irc-core/Network/IRC/Message/Types.hs +++ b/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. diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 83f1d74..6a2d873 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/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] diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index 9abe386..04ada5d 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/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