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

Added support for multiple parsers per raw line; documentation

Browse Source
master
Abhinav Sarkar 8 years ago
parent f43a18348d
commit 3d42577e62
12 changed files with 139 additions and 114 deletions
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Show Stats Download Patch File Download Diff File
  1. 10
      hask-irc-core/Network/IRC.hs
  2. 69
      hask-irc-core/Network/IRC/Bot.hs
  3. 2
      hask-irc-core/Network/IRC/Client.hs
  4. 24
      hask-irc-core/Network/IRC/Internal/Types.hs
  5. 16
      hask-irc-core/Network/IRC/Message/Types.hs
  6. 6
      hask-irc-core/Network/IRC/MessageBus.hs
  7. 75
      hask-irc-core/Network/IRC/Protocol.hs
  8. 5
      hask-irc-core/Network/IRC/Types.hs
  9. 2
      hask-irc-core/hask-irc-core.cabal
  10. 10
      hask-irc-handlers/Network/IRC/Handlers/Auth.hs
  11. 20
      hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs
  12. 14
      hask-irc-handlers/Network/IRC/Handlers/Tell.hs

10
hask-irc-core/Network/IRC.hs
Unescape 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

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

@ -12,13 +12,13 @@ import qualified Data.Text.Format as TF
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 Data.Time (addUTCTime)
import System.IO (hIsEOF)
import System.Timeout (timeout)
import System.Log.Logger.TH (deriveLoggers)
import Control.Concurrent.Lifted (threadDelay)
import Control.Exception.Lifted (mask_, mask)
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)
import Network.IRC.MessageBus
import Network.IRC.Internal.Types
@ -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
mLine <- try $ timeout timeoutDelay readLine
msgParts' <- 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
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
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
let (msgs, msgParts') = parseLine botConfig time line msgParts
forM_ msgs $ sendMessage inChan . Msg
return msgParts'
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
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
Unescape 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

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

@ -8,9 +8,9 @@ module Network.IRC.Internal.Types where
import qualified Data.Configurator as CF
import ClassyPrelude
import Control.Monad.Base (MonadBase)
import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
import Control.Monad.Base (MonadBase)
import Control.Monad.State.Strict (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
import Network.IRC.Message.Types
import Network.IRC.MessageBus
@ -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
Unescape 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
Unescape 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

75
hask-irc-core/Network/IRC/Protocol.hs
Unescape 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,22 +38,23 @@ parseMsgLine line = (splits, command, source, target, message)
lineParser :: MessageParser
lineParser = MessageParser "line" go
where
go BotConfig { .. } time line _ =
case command of
"PONG" -> done $ toMessage $ PongMsg message
"JOIN" -> done $ toMessage $ JoinMsg user
"QUIT" -> done $ toMessage $ QuitMsg user quitMessage
"PART" -> done $ toMessage $ PartMsg user message
"KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
"MODE" -> done $ toMessage $ if Nick target == botNick
then ModeMsg Self target message []
else ModeMsg user target mode modeArgs
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
"433" -> done $ toMessage NickInUseMsg
"PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> done $ toMessage $ ChannelMsg user message
_ -> Reject
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
"PART" -> done $ toMessage $ PartMsg user message
"KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
"MODE" -> done $ toMessage $ if Nick target == botNick
then ModeMsg Self target message []
else ModeMsg user target mode modeArgs
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
"433" -> done $ toMessage NickInUseMsg
"PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> done $ toMessage $ ChannelMsg user message
_ -> Reject
where
done = flip Done [] . Message time line
@ -71,22 +70,26 @@ 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
"366" -> let
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
_ -> Reject
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])
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
_ -> Reject
where
(_ : command : target : _) = words line
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack

5
hask-irc-core/Network/IRC/Types.hs
Unescape 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
Unescape 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

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

@ -7,11 +7,11 @@ import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude
import Control.Monad.Reader (asks)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Control.Monad.Reader (asks)
import Control.Monad.State.Strict (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Network.IRC
import Network.IRC.Handlers.Auth.Types

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

@ -8,14 +8,14 @@ import qualified Data.IxSet as IS
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude hiding (swap)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Data.Convertible (convert)
import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime)
import ClassyPrelude hiding (swap)
import Control.Monad.State.Strict (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Data.Convertible (convert)
import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime)
import Network.IRC
import Network.IRC.Handlers.NickTracker.Internal.Types
@ -113,13 +113,13 @@ handleNickChange state prevNick newNick msgTime = io $ do
mpnt <- getByNick acid prevNick
mnt <- getByNick acid newNick
mInfo <- case (mpnt, mnt) of
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
(Just pnt, Nothing) ->
return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
(Just pnt, Just nt) | canonicalNick pnt == canonicalNick nt -> do
let nt' = maximumByEx (comparing lastMessageOn) [pnt, nt]
return $ Just (lastMessage nt', canonicalNick nt', lastMessageOn nt')
_ -> return Nothing
_ -> return Nothing
whenJust mInfo $ \(message, cn, lastMessageOn') ->
saveNickTrack acid $ NickTrack newNick cn msgTime lastMessageOn' message

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

@ -6,13 +6,13 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where
import qualified Data.IxSet as IS
import ClassyPrelude hiding (swap)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Data.IxSet ((@=))
import Data.Text (split, strip)
import ClassyPrelude hiding (swap)
import Control.Monad.State.Strict (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Data.IxSet ((@=))
import Data.Text (split, strip)
import Network.IRC
import Network.IRC.Handlers.NickTracker.Types

Write Preview
Loading…
Cancel
Save