abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Refactoring, reformatting and logging.

master
Abhinav Sarkar 2015-06-26 10:45:02 +05:30
parent 9dd5c33384
commit ab26dd9f6a
7 changed files with 97 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
hask-irc-core/Network/IRC/Bot.hs
View File

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

44
hask-irc-core/Network/IRC/Client.hs
View File

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

4
hask-irc-core/Network/IRC/Configuration.hs
View File

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

2
hask-irc-core/Network/IRC/Internal/Types.hs
View File

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

19
hask-irc-core/Network/IRC/Message/Types.hs
View File

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

14
hask-irc-core/Network/IRC/Protocol.hs
View File

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

2
hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
View File

@ -30,7 +30,7 @@ getLogFilePath :: BotConfig -> IO FilePath
getLogFilePath BotConfig { .. } = do getLogFilePath BotConfig { .. } = do
let logFileDir = CF.require "messagelogger.logdir" config :: Text let logFileDir = CF.require "messagelogger.logdir" config :: Text
createDirectoryIfMissing True (unpack logFileDir) 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 :: FilePath -> IO Handle
openLogFile logFilePath = do openLogFile logFilePath = do