Added support for multiple parsers per raw line; documentation
parent
f43a18348d
commit
3d42577e62
|
@ -8,8 +8,10 @@ Stability : experimental
|
|||
Portability : POSIX
|
||||
-}
|
||||
|
||||
module Network.IRC (module IRC) where
|
||||
module Network.IRC
|
||||
( module Network.IRC.Types
|
||||
, module Network.IRC.Client
|
||||
) where
|
||||
|
||||
import Network.IRC.Types as IRC
|
||||
import Network.IRC.Client as IRC
|
||||
import Network.IRC.MessageBus as IRC
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Client
|
||||
|
|
|
@ -14,7 +14,7 @@ import qualified System.Log.Logger as HSL
|
|||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (threadDelay)
|
||||
import Control.Exception.Lifted (mask_, mask)
|
||||
import Control.Monad.State (get, put)
|
||||
import Control.Monad.State.Strict (get, put, evalStateT)
|
||||
import Data.Time (addUTCTime)
|
||||
import System.IO (hIsEOF)
|
||||
import System.Timeout (timeout)
|
||||
|
@ -45,33 +45,40 @@ sendCommandLoop commandChan bot@Bot { .. } = do
|
|||
_ -> sendCommandLoop commandChan bot
|
||||
|
||||
readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
|
||||
readMessageLoop = go []
|
||||
readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mempty
|
||||
where
|
||||
msgPartTimeout = 10
|
||||
|
||||
go !msgParts mvBotStatus inChan bot@Bot { .. } timeoutDelay = do
|
||||
loop = do
|
||||
msgParts <- get
|
||||
botStatus <- readMVar mvBotStatus
|
||||
case botStatus of
|
||||
Disconnected -> closeMessageChannel inChan
|
||||
Disconnected -> io $ closeMessageChannel inChan
|
||||
_ -> do
|
||||
msgParts' <- io $ do
|
||||
mLine <- try $ timeout timeoutDelay readLine
|
||||
msgParts' <- case mLine of
|
||||
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
|
||||
let (mmsg, msgParts') = parseLine botConfig time line msgParts
|
||||
whenJust mmsg $ sendMessage inChan . Msg
|
||||
let (msgs, msgParts') = parseLine botConfig time line msgParts
|
||||
forM_ msgs $ sendMessage inChan . Msg
|
||||
return msgParts'
|
||||
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts
|
||||
|
||||
limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
|
||||
let validMsgParts = concat
|
||||
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
|
||||
. groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
|
||||
go validMsgParts mvBotStatus inChan bot timeoutDelay
|
||||
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
|
||||
|
@ -83,9 +90,9 @@ readMessageLoop = go []
|
|||
return $ Line now line
|
||||
|
||||
messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
|
||||
messageProcessLoop = go 0
|
||||
messageProcessLoop inChan messageChan = loop 0
|
||||
where
|
||||
go !idleFor inChan messageChan = do
|
||||
loop !idleFor = do
|
||||
status <- get
|
||||
Bot { .. } <- ask
|
||||
let nick = botNick botConfig
|
||||
|
@ -109,10 +116,10 @@ messageProcessLoop = go 0
|
|||
|
||||
put nStatus
|
||||
case nStatus of
|
||||
Idle -> go (idleFor + oneSec) inChan messageChan
|
||||
Idle -> loop (idleFor + oneSec)
|
||||
Disconnected -> return ()
|
||||
NickNotAvailable -> return ()
|
||||
_ -> go 0 inChan messageChan
|
||||
_ -> loop 0
|
||||
|
||||
where
|
||||
handleMsg nick message mpass
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{-|
|
||||
Module : Network.IRC.Client
|
||||
Description : The IRC bot client used to create and run the bot.
|
||||
Description : The IRC bot client used to create and run a bot.
|
||||
Copyright : (c) Abhinav Sarkar, 2014
|
||||
License : Apache-2.0
|
||||
Maintainer : abhinav@abhinavsarkar.net
|
||||
|
|
|
@ -9,7 +9,7 @@ import qualified Data.Configurator as CF
|
|||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Base (MonadBase)
|
||||
import Control.Monad.State (StateT, MonadState, execStateT)
|
||||
import Control.Monad.State.Strict (StateT, MonadState, execStateT)
|
||||
import Data.Configurator.Types (Config)
|
||||
|
||||
import Network.IRC.Message.Types
|
||||
|
@ -22,8 +22,7 @@ import Network.IRC.Util
|
|||
type MessageParserId = Text
|
||||
|
||||
-- | A part of a mutlipart message.
|
||||
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
|
||||
, msgPartTarget :: !Text
|
||||
data MessagePart = MessagePart { msgPartTarget :: !Text
|
||||
, msgPartTime :: !UTCTime
|
||||
, msgPartLine :: !Text
|
||||
} deriving (Eq, Show)
|
||||
|
@ -43,7 +42,7 @@ data MessageParser = MessageParser
|
|||
|
||||
-- ** Command Formatting
|
||||
|
||||
-- | A command formatter which optinally formats commands to texts which are then send to the server.
|
||||
-- | A command formatter which optinally formats commands to texts which are then sent to the server.
|
||||
type CommandFormatter = BotConfig -> Message -> Maybe Text
|
||||
|
||||
-- ** Bot
|
||||
|
@ -68,9 +67,9 @@ data BotConfig = BotConfig
|
|||
-- | Info about the message handlers. A map of message handler names to a map of all commands supported
|
||||
-- by that message handler to the help text of that command.
|
||||
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
|
||||
-- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot.
|
||||
-- | A map of message handler names to 'MsgHandlerMaker's which are used to create message handlers for the bot.
|
||||
, msgHandlerMakers :: !(Map MsgHandlerName MsgHandlerMaker)
|
||||
-- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
|
||||
-- | A list of extra message parsers.
|
||||
, msgParsers :: ![MessageParser]
|
||||
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
|
||||
, cmdFormatters :: ![CommandFormatter]
|
||||
|
@ -87,7 +86,7 @@ instance Show BotConfig where
|
|||
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }"
|
||||
|
||||
-- | Creates a new bot config with essential fields leaving rest fields empty.
|
||||
-- | Creates a new bot config with essential fields leaving rest of the fields empty.
|
||||
newBotConfig :: Text -- ^ server
|
||||
-> Int -- ^ port
|
||||
-> Text -- ^ channel
|
||||
|
@ -158,11 +157,11 @@ instance MonadMsgHandler MsgHandlerT where
|
|||
-- | A message handler containing actions which are invoked by the bot.
|
||||
data MsgHandler = MsgHandler
|
||||
{
|
||||
-- | The action invoked when a message is received. It returns a list of commands in response
|
||||
-- to the message which the bot sends to the server.
|
||||
-- | The action invoked when a message is received. It returns a list of nessages in response
|
||||
-- which the bot sends to the server.
|
||||
onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Message])
|
||||
|
||||
-- | The action invoked to stop the message handler.
|
||||
-- | The action invoked when the message handler is stopped. Can use this for resource cleanup.
|
||||
, onStop :: !(forall m . MonadMsgHandler m => m ())
|
||||
|
||||
-- | The action invoked to get the map of the commands supported by the message handler and their help messages.
|
||||
|
@ -183,6 +182,7 @@ data MsgHandlerMaker = MsgHandlerMaker
|
|||
-- | The name of the message handler.
|
||||
msgHandlerName :: !MsgHandlerName
|
||||
-- | The action which is invoked to create a new message handler.
|
||||
-- Gets the bot config and the message channel used to receive messages.
|
||||
, msgHandlerMaker :: !(BotConfig -> MessageChannel Message -> IO MsgHandler)
|
||||
}
|
||||
|
||||
|
|
|
@ -32,14 +32,15 @@ data User
|
|||
, userServer :: !Text -- ^ The user's server.
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
-- | An IRC message sent from the server to the bot.
|
||||
-- | An message sent from the server to the bot or from the bot to the server
|
||||
-- or from a handler to another handler.
|
||||
data Message = Message
|
||||
{ msgTime :: !UTCTime -- ^ The time when the message was received.
|
||||
, msgLine :: !Text -- ^ The raw message line.
|
||||
{ msgTime :: !UTCTime -- ^ The time when the message was received/sent.
|
||||
, msgLine :: !Text -- ^ The raw message.
|
||||
, message :: MessageW -- ^ The details of the parsed message.
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- | The typeclass for different types of IRC messages.
|
||||
-- | The typeclass for different types of messages.
|
||||
class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
|
||||
toMessage :: msg -> MessageW
|
||||
toMessage = MessageW
|
||||
|
@ -47,7 +48,7 @@ class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
|
|||
fromMessage :: MessageW -> Maybe msg
|
||||
fromMessage (MessageW msg) = cast msg
|
||||
|
||||
-- | A wrapper over all types of IRC messages.
|
||||
-- | A wrapper over all types of messages.
|
||||
data MessageW = forall m . MessageC m => MessageW m deriving (Typeable)
|
||||
|
||||
instance Show MessageW where
|
||||
|
@ -58,7 +59,10 @@ instance Eq MessageW where
|
|||
Just m1' -> m1' == m2
|
||||
_ -> False
|
||||
|
||||
newMessage :: (MessageC msg, MonadIO m) => msg -> m Message
|
||||
-- | Creates a new message with current time and empty raw message.
|
||||
newMessage :: (MessageC msg, MonadIO m)
|
||||
=> msg -- ^ Message details
|
||||
-> m Message
|
||||
newMessage msg = do
|
||||
t <- liftIO getCurrentTime
|
||||
return $ Message t "" (toMessage msg)
|
||||
|
|
|
@ -32,6 +32,7 @@ newtype MessageBus a = MessageBus (TChan a)
|
|||
newMessageBus :: IO (MessageBus a)
|
||||
newMessageBus = MessageBus <$> newBroadcastTChanIO
|
||||
|
||||
-- | A channel through which messages are sent and received.
|
||||
data MessageChannel a = MessageChannel Latch (TChan a) (TChan a)
|
||||
|
||||
newMessageChannel ::MessageBus a -> IO (MessageChannel a)
|
||||
|
@ -46,7 +47,10 @@ sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan
|
|||
receiveMessageSTM :: MessageChannel a -> STM a
|
||||
receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan
|
||||
|
||||
sendMessage :: MessageChannel a -> a -> IO ()
|
||||
-- | Sends a message through a message channel
|
||||
sendMessage :: MessageChannel a -- ^ The channel
|
||||
-> a -- ^ The message to send
|
||||
-> IO ()
|
||||
sendMessage chan = atomically . sendMessageSTM chan
|
||||
|
||||
receiveMessage :: MessageChannel a -> IO a
|
||||
|
|
|
@ -1,7 +1,4 @@
|
|||
module Network.IRC.Protocol
|
||||
( MessagePart (..)
|
||||
, parseLine
|
||||
, formatCommand) where
|
||||
module Network.IRC.Protocol (parseLine, formatCommand) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Foldable (msum)
|
||||
|
@ -10,14 +7,15 @@ import Data.Text (strip)
|
|||
|
||||
import Network.IRC.Types
|
||||
|
||||
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart])
|
||||
parseLine :: BotConfig -> UTCTime -> Text -> Map MessageParserId [MessagePart]
|
||||
-> ([Message], Map MessageParserId [MessagePart])
|
||||
parseLine botConfig@BotConfig { .. } time line msgParts =
|
||||
fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } ->
|
||||
let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
|
||||
mconcat . flip map parsers $ \MessageParser { .. } ->
|
||||
let parserMsgParts = concat . maybeToList $ lookup msgParserId msgParts
|
||||
in case msgParser botConfig time line parserMsgParts of
|
||||
Reject -> Nothing
|
||||
Partial msgParts' -> Just (Nothing, msgParts' ++ otherParserMsgParts)
|
||||
Done message' msgParts' -> Just (Just message', msgParts' ++ otherParserMsgParts)
|
||||
Reject -> ([], (singletonMap msgParserId parserMsgParts))
|
||||
Partial msgParts' -> ([], (singletonMap msgParserId msgParts'))
|
||||
Done message msgParts' -> ([message], (singletonMap msgParserId msgParts'))
|
||||
where
|
||||
parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser]
|
||||
|
||||
|
@ -40,8 +38,9 @@ parseMsgLine line = (splits, command, source, target, message)
|
|||
lineParser :: MessageParser
|
||||
lineParser = MessageParser "line" go
|
||||
where
|
||||
go BotConfig { .. } time line _ =
|
||||
case command of
|
||||
go BotConfig { .. } time line _
|
||||
| "PING :" `isPrefixOf` line = Reject
|
||||
| otherwise = case command of
|
||||
"PONG" -> done $ toMessage $ PongMsg message
|
||||
"JOIN" -> done $ toMessage $ JoinMsg user
|
||||
"QUIT" -> done $ toMessage $ QuitMsg user quitMessage
|
||||
|
@ -71,16 +70,20 @@ lineParser = MessageParser "line" go
|
|||
defaultParser :: MessageParser
|
||||
defaultParser = MessageParser "default" go
|
||||
where
|
||||
go _ time line _ = flip Done [] . Message time line $
|
||||
toMessage $ OtherMsg source command target message
|
||||
go _ time line _
|
||||
| "PING :" `isPrefixOf` line = Reject
|
||||
| otherwise =
|
||||
flip Done [] . Message time line $ toMessage $ OtherMsg source command target message
|
||||
where
|
||||
(_, command, source, target, message) = parseMsgLine line
|
||||
|
||||
namesParser :: MessageParser
|
||||
namesParser = MessageParser "names" go
|
||||
where
|
||||
go BotConfig { .. } time line msgParts = case command of
|
||||
"353" -> Partial $ MessagePart "names" target time line : msgParts
|
||||
go BotConfig { .. } time line msgParts
|
||||
| "PING :" `isPrefixOf` line = Reject
|
||||
| otherwise = case command of
|
||||
"353" -> Partial $ MessagePart target time line : msgParts
|
||||
"366" -> let
|
||||
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
|
||||
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
|
||||
|
|
|
@ -15,6 +15,7 @@ module Network.IRC.Types
|
|||
, User (..)
|
||||
, MessageC (..)
|
||||
, Message (..)
|
||||
, MessageW
|
||||
, newMessage
|
||||
, IdleMsg (..)
|
||||
, NickInUseMsg (..)
|
||||
|
@ -59,7 +60,11 @@ module Network.IRC.Types
|
|||
, MsgHandler (..)
|
||||
, newMsgHandler
|
||||
, MsgHandlerMaker (..)
|
||||
-- * Message Channel
|
||||
, MessageChannel
|
||||
, sendMessage
|
||||
) where
|
||||
|
||||
import Network.IRC.Message.Types
|
||||
import Network.IRC.Internal.Types
|
||||
import Network.IRC.MessageBus
|
||||
|
|
|
@ -70,13 +70,13 @@ library
|
|||
unix >=2.7 && <2.8
|
||||
|
||||
exposed-modules: Network.IRC,
|
||||
Network.IRC.MessageBus,
|
||||
Network.IRC.Types,
|
||||
Network.IRC.Client,
|
||||
Network.IRC.Util
|
||||
|
||||
other-modules: Network.IRC.Internal.Types,
|
||||
Network.IRC.Message.Types,
|
||||
Network.IRC.MessageBus,
|
||||
Network.IRC.Protocol,
|
||||
Network.IRC.Bot,
|
||||
Network.IRC.Handlers.Core
|
||||
|
|
|
@ -8,7 +8,7 @@ import qualified Data.UUID.V4 as U
|
|||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Reader (asks)
|
||||
import Control.Monad.State (get, put)
|
||||
import Control.Monad.State.Strict (get, put)
|
||||
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
|
||||
openLocalState, createArchive)
|
||||
import Data.Acid.Local (createCheckpointAndClose)
|
||||
|
|
|
@ -9,7 +9,7 @@ import qualified Data.UUID as U
|
|||
import qualified Data.UUID.V4 as U
|
||||
|
||||
import ClassyPrelude hiding (swap)
|
||||
import Control.Monad.State (get, put)
|
||||
import Control.Monad.State.Strict (get, put)
|
||||
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
|
||||
openLocalState, createArchive)
|
||||
import Data.Acid.Local (createCheckpointAndClose)
|
||||
|
|
|
@ -7,7 +7,7 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where
|
|||
import qualified Data.IxSet as IS
|
||||
|
||||
import ClassyPrelude hiding (swap)
|
||||
import Control.Monad.State (get, put)
|
||||
import Control.Monad.State.Strict (get, put)
|
||||
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
|
||||
openLocalState, createArchive)
|
||||
import Data.Acid.Local (createCheckpointAndClose)
|
||||
|
|
Loading…
Reference in New Issue