Refactoring, reformatting and logging.

master
Abhinav Sarkar 8 years ago
parent 9dd5c33384
commit ab26dd9f6a
  1. 107
      hask-irc-core/Network/IRC/Bot.hs
  2. 44
      hask-irc-core/Network/IRC/Client.hs
  3. 4
      hask-irc-core/Network/IRC/Configuration.hs
  4. 2
      hask-irc-core/Network/IRC/Internal/Types.hs
  5. 19
      hask-irc-core/Network/IRC/Message/Types.hs
  6. 14
      hask-irc-core/Network/IRC/Protocol.hs
  7. 2
      hask-irc-handlers/Network/IRC/Handlers/MessageLogger.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

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

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

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

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

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

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

Loading…
Cancel
Save