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

Added support for multiple parsers per raw line; documentation

master
Abhinav Sarkar 2014-10-13 11:21:08 +05:30
parent f43a18348d
commit 3d42577e62
12 changed files with 138 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
hask-irc-core/Network/IRC.hs
View File

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

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

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

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

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

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

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

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

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

6
hask-irc-core/Network/IRC/MessageBus.hs
View File

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

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

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

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

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

2
hask-irc-core/hask-irc-core.cabal
View File

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

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

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

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

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

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

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