Refactoring, reformatting and logging.
This commit is contained in:
parent
9dd5c33384
commit
ab26dd9f6a
@ -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
|
||||
|
||||
@ -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…
Reference in New Issue
Block a user