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 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.Types
import Network.IRC.Client as IRC import Network.IRC.Client
import Network.IRC.MessageBus as IRC

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

@ -12,13 +12,13 @@ import qualified Data.Text.Format as TF
import qualified System.Log.Logger as HSL import qualified System.Log.Logger as HSL
import ClassyPrelude import ClassyPrelude
import Control.Concurrent.Lifted (threadDelay) import Control.Concurrent.Lifted (threadDelay)
import Control.Exception.Lifted (mask_, mask) 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 Data.Time (addUTCTime)
import System.IO (hIsEOF) import System.IO (hIsEOF)
import System.Timeout (timeout) import System.Timeout (timeout)
import System.Log.Logger.TH (deriveLoggers) import System.Log.Logger.TH (deriveLoggers)
import Network.IRC.MessageBus import Network.IRC.MessageBus
import Network.IRC.Internal.Types import Network.IRC.Internal.Types
@ -45,33 +45,40 @@ sendCommandLoop commandChan bot@Bot { .. } = do
_ -> sendCommandLoop commandChan bot _ -> sendCommandLoop commandChan bot
readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO () readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
readMessageLoop = go [] readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mempty
where where
msgPartTimeout = 10 msgPartTimeout = 10
go !msgParts mvBotStatus inChan bot@Bot { .. } timeoutDelay = do loop = do
msgParts <- get
botStatus <- readMVar mvBotStatus botStatus <- readMVar mvBotStatus
case botStatus of case botStatus of
Disconnected -> closeMessageChannel inChan Disconnected -> io $ closeMessageChannel inChan
_ -> do _ -> do
mLine <- try $ timeout timeoutDelay readLine msgParts' <- io $ do
msgParts' <- case mLine of mLine <- try $ timeout timeoutDelay readLine
Left (e :: SomeException) -> do case mLine of
errorM $ "Error while reading from connection: " ++ show e Left (e :: SomeException) -> do
sendMessage inChan EOD >> return msgParts errorM $ "Error while reading from connection: " ++ show e
Right Nothing -> sendMessage inChan Timeout >> return msgParts sendMessage inChan EOD >> return msgParts
Right (Just (Line time line)) -> do Right Nothing -> sendMessage inChan Timeout >> return msgParts
let (mmsg, msgParts') = parseLine botConfig time line msgParts Right (Just (Line time line)) -> do
whenJust mmsg $ sendMessage inChan . Msg let (msgs, msgParts') = parseLine botConfig time line msgParts
return msgParts' forM_ msgs $ sendMessage inChan . Msg
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts return msgParts'
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts
limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime limit <- io $ map (addUTCTime (- msgPartTimeout)) getCurrentTime
let validMsgParts = concat put $ validMsgParts limit msgParts'
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime)) loop
. groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
go validMsgParts mvBotStatus inChan bot timeoutDelay
where 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 readLine = do
eof <- hIsEOF botSocket eof <- hIsEOF botSocket
if eof if eof
@ -83,9 +90,9 @@ readMessageLoop = go []
return $ Line now line return $ Line now line
messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC () messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
messageProcessLoop = go 0 messageProcessLoop inChan messageChan = loop 0
where where
go !idleFor inChan messageChan = do loop !idleFor = do
status <- get status <- get
Bot { .. } <- ask Bot { .. } <- ask
let nick = botNick botConfig let nick = botNick botConfig
@ -109,10 +116,10 @@ messageProcessLoop = go 0
put nStatus put nStatus
case nStatus of case nStatus of
Idle -> go (idleFor + oneSec) inChan messageChan Idle -> loop (idleFor + oneSec)
Disconnected -> return () Disconnected -> return ()
NickNotAvailable -> return () NickNotAvailable -> return ()
_ -> go 0 inChan messageChan _ -> loop 0
where where
handleMsg nick message mpass handleMsg nick message mpass

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

@ -1,6 +1,6 @@
{-| {-|
Module : Network.IRC.Client 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 Copyright : (c) Abhinav Sarkar, 2014
License : Apache-2.0 License : Apache-2.0
Maintainer : abhinav@abhinavsarkar.net Maintainer : abhinav@abhinavsarkar.net

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

@ -8,9 +8,9 @@ module Network.IRC.Internal.Types where
import qualified Data.Configurator as CF import qualified Data.Configurator as CF
import ClassyPrelude import ClassyPrelude
import Control.Monad.Base (MonadBase) 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 Data.Configurator.Types (Config)
import Network.IRC.Message.Types import Network.IRC.Message.Types
import Network.IRC.MessageBus import Network.IRC.MessageBus
@ -22,8 +22,7 @@ import Network.IRC.Util
type MessageParserId = Text type MessageParserId = Text
-- | A part of a mutlipart message. -- | A part of a mutlipart message.
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId data MessagePart = MessagePart { msgPartTarget :: !Text
, msgPartTarget :: !Text
, msgPartTime :: !UTCTime , msgPartTime :: !UTCTime
, msgPartLine :: !Text , msgPartLine :: !Text
} deriving (Eq, Show) } deriving (Eq, Show)
@ -43,7 +42,7 @@ data MessageParser = MessageParser
-- ** Command Formatting -- ** 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 type CommandFormatter = BotConfig -> Message -> Maybe Text
-- ** Bot -- ** 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 -- | 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. -- by that message handler to the help text of that command.
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) , 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) , 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] , msgParsers :: ![MessageParser]
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones. -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
, cmdFormatters :: ![CommandFormatter] , cmdFormatters :: ![CommandFormatter]
@ -87,7 +86,7 @@ instance Show BotConfig where
"timeout = " ++ show botTimeout ++ "\n" ++ "timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }" "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 newBotConfig :: Text -- ^ server
-> Int -- ^ port -> Int -- ^ port
-> Text -- ^ channel -> Text -- ^ channel
@ -158,11 +157,11 @@ instance MonadMsgHandler MsgHandlerT where
-- | A message handler containing actions which are invoked by the bot. -- | A message handler containing actions which are invoked by the bot.
data MsgHandler = MsgHandler data MsgHandler = MsgHandler
{ {
-- | The action invoked when a message is received. It returns a list of commands in response -- | The action invoked when a message is received. It returns a list of nessages in response
-- to the message which the bot sends to the server. -- which the bot sends to the server.
onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Message]) 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 ()) , 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. -- | 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. -- | The name of the message handler.
msgHandlerName :: !MsgHandlerName msgHandlerName :: !MsgHandlerName
-- | The action which is invoked to create a new message handler. -- | 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) , 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. , userServer :: !Text -- ^ The user's server.
} deriving (Show, Eq, Ord) } 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 data Message = Message
{ msgTime :: !UTCTime -- ^ The time when the message was received. { msgTime :: !UTCTime -- ^ The time when the message was received/sent.
, msgLine :: !Text -- ^ The raw message line. , msgLine :: !Text -- ^ The raw message.
, message :: MessageW -- ^ The details of the parsed message. , message :: MessageW -- ^ The details of the parsed message.
} deriving (Show, Eq) } 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 class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
toMessage :: msg -> MessageW toMessage :: msg -> MessageW
toMessage = 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 -> Maybe msg
fromMessage (MessageW msg) = cast 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) data MessageW = forall m . MessageC m => MessageW m deriving (Typeable)
instance Show MessageW where instance Show MessageW where
@ -58,7 +59,10 @@ instance Eq MessageW where
Just m1' -> m1' == m2 Just m1' -> m1' == m2
_ -> False _ -> 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 newMessage msg = do
t <- liftIO getCurrentTime t <- liftIO getCurrentTime
return $ Message t "" (toMessage msg) 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 :: IO (MessageBus a)
newMessageBus = MessageBus <$> newBroadcastTChanIO newMessageBus = MessageBus <$> newBroadcastTChanIO
-- | A channel through which messages are sent and received.
data MessageChannel a = MessageChannel Latch (TChan a) (TChan a) data MessageChannel a = MessageChannel Latch (TChan a) (TChan a)
newMessageChannel ::MessageBus a -> IO (MessageChannel a) newMessageChannel ::MessageBus a -> IO (MessageChannel a)
@ -46,7 +47,10 @@ sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan
receiveMessageSTM :: MessageChannel a -> STM a receiveMessageSTM :: MessageChannel a -> STM a
receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan 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 sendMessage chan = atomically . sendMessageSTM chan
receiveMessage :: MessageChannel a -> IO a receiveMessage :: MessageChannel a -> IO a

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

@ -1,7 +1,4 @@
module Network.IRC.Protocol module Network.IRC.Protocol (parseLine, formatCommand) where
( MessagePart (..)
, parseLine
, formatCommand) where
import ClassyPrelude import ClassyPrelude
import Data.Foldable (msum) import Data.Foldable (msum)
@ -10,14 +7,15 @@ import Data.Text (strip)
import Network.IRC.Types 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 = parseLine botConfig@BotConfig { .. } time line msgParts =
fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } -> mconcat . flip map parsers $ \MessageParser { .. } ->
let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts let parserMsgParts = concat . maybeToList $ lookup msgParserId msgParts
in case msgParser botConfig time line parserMsgParts of in case msgParser botConfig time line parserMsgParts of
Reject -> Nothing Reject -> ([], (singletonMap msgParserId parserMsgParts))
Partial msgParts' -> Just (Nothing, msgParts' ++ otherParserMsgParts) Partial msgParts' -> ([], (singletonMap msgParserId msgParts'))
Done message' msgParts' -> Just (Just message', msgParts' ++ otherParserMsgParts) Done message msgParts' -> ([message], (singletonMap msgParserId msgParts'))
where where
parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser] parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser]
@ -40,22 +38,23 @@ parseMsgLine line = (splits, command, source, target, message)
lineParser :: MessageParser lineParser :: MessageParser
lineParser = MessageParser "line" go lineParser = MessageParser "line" go
where where
go BotConfig { .. } time line _ = go BotConfig { .. } time line _
case command of | "PING :" `isPrefixOf` line = Reject
"PONG" -> done $ toMessage $ PongMsg message | otherwise = case command of
"JOIN" -> done $ toMessage $ JoinMsg user "PONG" -> done $ toMessage $ PongMsg message
"QUIT" -> done $ toMessage $ QuitMsg user quitMessage "JOIN" -> done $ toMessage $ JoinMsg user
"PART" -> done $ toMessage $ PartMsg user message "QUIT" -> done $ toMessage $ QuitMsg user quitMessage
"KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason "PART" -> done $ toMessage $ PartMsg user message
"MODE" -> done $ toMessage $ if Nick target == botNick "KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
then ModeMsg Self target message [] "MODE" -> done $ toMessage $ if Nick target == botNick
else ModeMsg user target mode modeArgs then ModeMsg Self target message []
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target) else ModeMsg user target mode modeArgs
"433" -> done $ toMessage NickInUseMsg "NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
"PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message "433" -> done $ toMessage NickInUseMsg
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message) "PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
| otherwise -> done $ toMessage $ ChannelMsg user message | isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
_ -> Reject | otherwise -> done $ toMessage $ ChannelMsg user message
_ -> Reject
where where
done = flip Done [] . Message time line done = flip Done [] . Message time line
@ -71,22 +70,26 @@ lineParser = MessageParser "line" go
defaultParser :: MessageParser defaultParser :: MessageParser
defaultParser = MessageParser "default" go defaultParser = MessageParser "default" go
where where
go _ time line _ = flip Done [] . Message time line $ go _ time line _
toMessage $ OtherMsg source command target message | "PING :" `isPrefixOf` line = Reject
| otherwise =
flip Done [] . Message time line $ toMessage $ OtherMsg source command target message
where where
(_, command, source, target, message) = parseMsgLine line (_, command, source, target, message) = parseMsgLine line
namesParser :: MessageParser namesParser :: MessageParser
namesParser = MessageParser "names" go namesParser = MessageParser "names" go
where where
go BotConfig { .. } time line msgParts = case command of go BotConfig { .. } time line msgParts
"353" -> Partial $ MessagePart "names" target time line : msgParts | "PING :" `isPrefixOf` line = Reject
"366" -> let | otherwise = case command of
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts "353" -> Partial $ MessagePart target time line : msgParts
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line]) "366" -> let
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts (nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
_ -> Reject $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
_ -> Reject
where where
(_ : command : target : _) = words line (_ : command : target : _) = words line
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack

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

@ -15,6 +15,7 @@ module Network.IRC.Types
, User (..) , User (..)
, MessageC (..) , MessageC (..)
, Message (..) , Message (..)
, MessageW
, newMessage , newMessage
, IdleMsg (..) , IdleMsg (..)
, NickInUseMsg (..) , NickInUseMsg (..)
@ -59,7 +60,11 @@ module Network.IRC.Types
, MsgHandler (..) , MsgHandler (..)
, newMsgHandler , newMsgHandler
, MsgHandlerMaker (..) , MsgHandlerMaker (..)
-- * Message Channel
, MessageChannel
, sendMessage
) where ) where
import Network.IRC.Message.Types import Network.IRC.Message.Types
import Network.IRC.Internal.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 unix >=2.7 && <2.8
exposed-modules: Network.IRC, exposed-modules: Network.IRC,
Network.IRC.MessageBus,
Network.IRC.Types, Network.IRC.Types,
Network.IRC.Client, Network.IRC.Client,
Network.IRC.Util Network.IRC.Util
other-modules: Network.IRC.Internal.Types, other-modules: Network.IRC.Internal.Types,
Network.IRC.Message.Types, Network.IRC.Message.Types,
Network.IRC.MessageBus,
Network.IRC.Protocol, Network.IRC.Protocol,
Network.IRC.Bot, Network.IRC.Bot,
Network.IRC.Handlers.Core Network.IRC.Handlers.Core

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

@ -7,11 +7,11 @@ import qualified Data.UUID as U
import qualified Data.UUID.V4 as U import qualified Data.UUID.V4 as U
import ClassyPrelude import ClassyPrelude
import Control.Monad.Reader (asks) 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, import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive) openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose) import Data.Acid.Local (createCheckpointAndClose)
import Network.IRC import Network.IRC
import Network.IRC.Handlers.Auth.Types import Network.IRC.Handlers.Auth.Types

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

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

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

@ -6,13 +6,13 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where
import qualified Data.IxSet as IS import qualified Data.IxSet as IS
import ClassyPrelude hiding (swap) 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, import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive) openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose) import Data.Acid.Local (createCheckpointAndClose)
import Data.IxSet ((@=)) import Data.IxSet ((@=))
import Data.Text (split, strip) import Data.Text (split, strip)
import Network.IRC import Network.IRC
import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Handlers.NickTracker.Types