2015-06-21 18:18:59 +05:30
|
|
|
{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
|
2014-05-22 01:08:36 +05:30
|
|
|
|
|
|
|
module Network.IRC.Bot
|
2014-10-04 21:22:24 +05:30
|
|
|
( In
|
2014-05-22 01:08:36 +05:30
|
|
|
, sendCommandLoop
|
2014-10-04 21:22:24 +05:30
|
|
|
, readMessageLoop
|
|
|
|
, messageProcessLoop )
|
2014-05-22 01:08:36 +05:30
|
|
|
where
|
2014-05-21 12:17:00 +05:30
|
|
|
|
2014-05-25 01:09:31 +05:30
|
|
|
import qualified Data.Text.Format as TF
|
2014-05-22 01:08:36 +05:30
|
|
|
import qualified System.Log.Logger as HSL
|
2014-05-21 12:17:00 +05:30
|
|
|
|
|
|
|
import ClassyPrelude
|
2014-10-13 11:21:08 +05:30
|
|
|
import Control.Concurrent.Lifted (threadDelay)
|
2015-06-21 18:18:59 +05:30
|
|
|
import Control.Exception.Lifted (evaluate)
|
2014-10-13 11:21:08 +05:30
|
|
|
import Control.Monad.State.Strict (get, put, evalStateT)
|
|
|
|
import Data.Time (addUTCTime)
|
|
|
|
import System.IO (hIsEOF)
|
|
|
|
import System.Timeout (timeout)
|
|
|
|
import System.Log.Logger.TH (deriveLoggers)
|
2014-05-21 12:17:00 +05:30
|
|
|
|
2015-06-25 02:48:49 +05:30
|
|
|
import qualified Network.IRC.Configuration as CF
|
2014-10-04 21:22:24 +05:30
|
|
|
import Network.IRC.MessageBus
|
2014-06-06 19:58:53 +05:30
|
|
|
import Network.IRC.Internal.Types
|
2014-05-21 12:17:00 +05:30
|
|
|
import Network.IRC.Protocol
|
2014-06-08 07:12:33 +05:30
|
|
|
import Network.IRC.Types
|
2014-05-21 12:17:00 +05:30
|
|
|
import Network.IRC.Util
|
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
$(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
|
2014-05-22 01:08:36 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq)
|
2014-10-05 15:58:20 +05:30
|
|
|
data In = Timeout | EOD | Msg !Message deriving (Show, Eq)
|
2014-05-21 12:17:00 +05:30
|
|
|
|
2015-06-21 18:18:59 +05:30
|
|
|
formatCommand :: (Exception e) => BotConfig -> Message -> IO ([e], [Text])
|
|
|
|
formatCommand botConfig@BotConfig { .. } message =
|
|
|
|
map (second catMaybes . partitionEithers)
|
|
|
|
. forM (defaultCommandFormatter : cmdFormatters) $ \formatter ->
|
|
|
|
try . evaluate $ formatter botConfig message
|
|
|
|
|
|
|
|
parseLine :: (Exception e)
|
|
|
|
=> BotConfig -> UTCTime -> Text -> Map MessageParserId [MessagePart]
|
|
|
|
-> IO ([e], [Message], Map MessageParserId [MessagePart])
|
|
|
|
parseLine botConfig@BotConfig { .. } time line msgParts =
|
|
|
|
map mconcat . forM parsers $ \MessageParser { .. } -> do
|
|
|
|
let parserMsgParts = concat . maybeToList $ lookup msgParserId msgParts
|
|
|
|
let parserMsgPartsMap = singletonMap msgParserId parserMsgParts
|
|
|
|
eresult <- try . evaluate $ msgParser botConfig time line parserMsgParts
|
|
|
|
return $ case eresult of
|
|
|
|
Left e -> ([e], [] , parserMsgPartsMap)
|
|
|
|
Right ParseReject -> ([] , [] , parserMsgPartsMap)
|
|
|
|
Right (ParsePartial msgParts') -> ([] , [] , singletonMap msgParserId msgParts')
|
|
|
|
Right (ParseDone message msgParts') -> ([] , [message], singletonMap msgParserId msgParts')
|
|
|
|
where
|
|
|
|
parsers = defaultParsers ++ msgParsers
|
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
|
|
|
|
sendCommandLoop commandChan bot@Bot { .. } = do
|
|
|
|
msg@(Message _ _ cmd) <- receiveMessage commandChan
|
2015-06-21 18:18:59 +05:30
|
|
|
(exs, lines_) <- formatCommand botConfig msg
|
|
|
|
|
|
|
|
forM_ exs $ \(ex :: SomeException) ->
|
|
|
|
errorM ("Error while formatting command: " ++ show cmd ++ "\nError: " ++ show ex)
|
|
|
|
|
2015-06-21 18:27:07 +05:30
|
|
|
unless (null lines_) $
|
2015-06-21 18:18:59 +05:30
|
|
|
handle (\(e :: SomeException) -> do
|
|
|
|
errorM ("Error while writing to connection: " ++ show e)
|
2015-06-21 18:27:07 +05:30
|
|
|
closeMessageChannel commandChan) $
|
2015-06-21 18:18:59 +05:30
|
|
|
forM_ lines_ $ \line -> do
|
|
|
|
TF.hprint botSocket "{}\r\n" $ TF.Only line
|
|
|
|
infoM . unpack $ "> " ++ line
|
|
|
|
|
|
|
|
commandChanClosed <- isClosedMessageChannel commandChan
|
2015-06-21 18:27:07 +05:30
|
|
|
unless commandChanClosed $
|
2014-10-04 21:22:24 +05:30
|
|
|
case fromMessage cmd of
|
|
|
|
Just QuitCmd -> closeMessageChannel commandChan
|
|
|
|
_ -> sendCommandLoop commandChan bot
|
2014-05-21 12:17:00 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
|
2014-10-13 11:21:08 +05:30
|
|
|
readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mempty
|
2014-05-25 05:30:49 +05:30
|
|
|
where
|
|
|
|
msgPartTimeout = 10
|
|
|
|
|
2014-10-13 11:21:08 +05:30
|
|
|
loop = do
|
|
|
|
msgParts <- get
|
2014-05-25 05:30:49 +05:30
|
|
|
botStatus <- readMVar mvBotStatus
|
|
|
|
case botStatus of
|
2014-10-13 11:21:08 +05:30
|
|
|
Disconnected -> io $ closeMessageChannel inChan
|
2014-05-25 05:30:49 +05:30
|
|
|
_ -> do
|
2014-10-13 11:21:08 +05:30
|
|
|
msgParts' <- io $ do
|
|
|
|
mLine <- try $ timeout timeoutDelay readLine
|
|
|
|
case mLine of
|
|
|
|
Left (e :: SomeException) -> do
|
|
|
|
errorM $ "Error while reading from connection: " ++ show e
|
|
|
|
sendMessage inChan EOD >> return msgParts
|
|
|
|
Right Nothing -> sendMessage inChan Timeout >> return msgParts
|
|
|
|
Right (Just (Line time line)) -> do
|
2015-06-21 18:18:59 +05:30
|
|
|
(exs, msgs, msgParts') <- parseLine botConfig time line msgParts
|
|
|
|
|
|
|
|
forM_ exs $ \(ex :: SomeException) ->
|
|
|
|
errorM ("Error while parsing line: " ++ unpack line ++ "\nError: " ++ show ex)
|
2014-10-13 11:21:08 +05:30
|
|
|
forM_ msgs $ sendMessage inChan . Msg
|
2015-06-21 18:18:59 +05:30
|
|
|
|
2014-10-13 11:21:08 +05:30
|
|
|
return msgParts'
|
|
|
|
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts
|
|
|
|
|
|
|
|
limit <- io $ map (addUTCTime (- msgPartTimeout)) getCurrentTime
|
|
|
|
put $ validMsgParts limit msgParts'
|
|
|
|
loop
|
2014-05-21 12:17:00 +05:30
|
|
|
where
|
2014-10-13 11:21:08 +05:30
|
|
|
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
|
|
|
|
|
2014-10-05 13:12:49 +05:30
|
|
|
readLine = do
|
2014-06-06 19:58:53 +05:30
|
|
|
eof <- hIsEOF botSocket
|
2014-05-21 12:17:00 +05:30
|
|
|
if eof
|
2014-10-04 21:22:24 +05:30
|
|
|
then return EOS
|
2014-06-01 23:14:19 +05:30
|
|
|
else mask $ \unmask -> do
|
2014-06-06 19:58:53 +05:30
|
|
|
line <- map initEx . unmask $ hGetLine botSocket
|
2014-05-22 01:08:36 +05:30
|
|
|
infoM . unpack $ "< " ++ line
|
2014-05-21 12:17:00 +05:30
|
|
|
now <- getCurrentTime
|
2014-05-25 05:30:49 +05:30
|
|
|
return $ Line now line
|
2014-05-21 12:17:00 +05:30
|
|
|
|
2014-10-04 21:22:24 +05:30
|
|
|
messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
|
2014-10-13 11:21:08 +05:30
|
|
|
messageProcessLoop inChan messageChan = loop 0
|
2014-05-21 12:17:00 +05:30
|
|
|
where
|
2014-10-13 11:21:08 +05:30
|
|
|
loop !idleFor = do
|
2015-06-21 15:14:32 +05:30
|
|
|
status <- get
|
|
|
|
Bot { .. } <- ask
|
|
|
|
let nick = botNick botConfig
|
|
|
|
let origNick = botOrigNick botConfig
|
2015-06-25 02:48:49 +05:30
|
|
|
let mpass = CF.lookup "password" (config botConfig)
|
2014-05-25 05:30:49 +05:30
|
|
|
|
|
|
|
nStatus <- io . mask_ $
|
|
|
|
if idleFor >= (oneSec * botTimeout botConfig)
|
|
|
|
then infoM "Timeout" >> return Disconnected
|
|
|
|
else do
|
|
|
|
when (status == Kicked) $
|
2014-10-04 21:22:24 +05:30
|
|
|
threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
|
2014-05-25 05:30:49 +05:30
|
|
|
|
2014-10-05 14:48:47 +05:30
|
|
|
mIn <- receiveMessage inChan
|
2014-10-04 21:22:24 +05:30
|
|
|
case mIn of
|
2015-06-25 02:48:49 +05:30
|
|
|
Timeout -> do
|
2015-06-21 15:14:32 +05:30
|
|
|
idleMsg <- newMessage IdleMsg
|
|
|
|
sendMessage messageChan idleMsg
|
|
|
|
sendWhoisMessage nick origNick
|
|
|
|
return Idle
|
2015-06-25 02:48:49 +05:30
|
|
|
EOD -> infoM "Connection closed" >> return Disconnected
|
2014-10-05 14:48:47 +05:30
|
|
|
Msg (msg@Message { .. }) -> do
|
2015-06-21 15:14:32 +05:30
|
|
|
nStatus <- handleMsg nick origNick message mpass
|
2014-10-04 21:22:24 +05:30
|
|
|
sendMessage messageChan msg
|
2014-05-25 05:30:49 +05:30
|
|
|
return nStatus
|
|
|
|
|
|
|
|
put nStatus
|
|
|
|
case nStatus of
|
2014-10-13 11:21:08 +05:30
|
|
|
Idle -> loop (idleFor + oneSec)
|
2014-05-25 05:30:49 +05:30
|
|
|
Disconnected -> return ()
|
|
|
|
NickNotAvailable -> return ()
|
2015-06-21 15:14:32 +05:30
|
|
|
NickAvailable -> return ()
|
2014-10-13 11:21:08 +05:30
|
|
|
_ -> loop 0
|
2014-05-25 05:30:49 +05:30
|
|
|
|
|
|
|
where
|
2015-06-21 15:14:32 +05:30
|
|
|
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 =
|
2014-06-08 04:26:50 +05:30
|
|
|
infoM "Joined" >> return Joined
|
2015-06-21 15:14:32 +05:30
|
|
|
| Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick =
|
2014-06-08 04:26:50 +05:30
|
|
|
infoM "Kicked" >> return Kicked
|
2015-06-21 15:14:32 +05:30
|
|
|
| Just NickInUseMsg <- fromMessage message =
|
2014-10-05 13:12:49 +05:30
|
|
|
infoM "Nick already in use" >> return NickNotAvailable
|
2015-06-21 15:14:32 +05:30
|
|
|
| Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self = do
|
2014-10-04 23:05:24 +05:30
|
|
|
whenJust mpass $ \pass -> do
|
|
|
|
msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass
|
|
|
|
sendMessage messageChan msg
|
|
|
|
newMessage JoinCmd >>= sendMessage messageChan
|
|
|
|
return Connected
|
2015-06-21 15:14:32 +05:30
|
|
|
| Just (WhoisNoSuchNick n) <- fromMessage message, n == origNick =
|
|
|
|
infoM "Original nick available" >> return NickAvailable
|
|
|
|
| otherwise =
|
2014-10-04 21:22:24 +05:30
|
|
|
return Connected
|