Added nick tracking handler
parent
96a61f3b32
commit
02d1b7ab98
|
@ -55,11 +55,9 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
|||
let mline = lineFromCommand botConfig cmd
|
||||
handle (\(e :: SomeException) ->
|
||||
errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
|
||||
case mline of
|
||||
Nothing -> return ()
|
||||
Just line -> do
|
||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
||||
infoM . unpack $ "> " ++ line
|
||||
whenJust mline $ \line -> do
|
||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
||||
infoM . unpack $ "> " ++ line
|
||||
case cmd of
|
||||
QuitCmd -> latchIt latch
|
||||
_ -> sendCommandLoop (commandChan, latch) bot
|
||||
|
@ -132,7 +130,7 @@ messageProcessLoop lineChan commandChan !idleFor = do
|
|||
handle (\(e :: SomeException) ->
|
||||
errorM $ "Exception while processing message: " ++ show e) $ do
|
||||
mCmd <- handleMessage msgHandler botConfig message
|
||||
maybe (return ()) (sendCommand commandChan) mCmd
|
||||
whenJust mCmd (sendCommand commandChan)
|
||||
|
||||
eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||
|
|
|
@ -8,20 +8,17 @@ module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
|
|||
import qualified Network.IRC.Handlers.MessageLogger as Logger
|
||||
import qualified Network.IRC.Handlers.SongSearch as SongSearch
|
||||
import qualified Network.IRC.Handlers.Auth as Auth
|
||||
import qualified Network.IRC.Handlers.NickTracker as NickTracker
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (Chan)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Convertible (convert)
|
||||
import Data.Text (strip)
|
||||
import Data.Time (addUTCTime)
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
clean :: Text -> Text
|
||||
clean = toLower . strip
|
||||
|
||||
coreMsgHandlerNames :: [Text]
|
||||
coreMsgHandlerNames = ["pingpong", "messagelogger", "help"]
|
||||
|
||||
|
@ -32,15 +29,19 @@ mkMsgHandler _ _ "pingpong" = do
|
|||
state <- getCurrentTime >>= newIORef
|
||||
return . Just $ newMsgHandler { onMessage = pingPong state }
|
||||
mkMsgHandler _ _ "help" =
|
||||
return . Just $ newMsgHandler { onMessage = help, onHelp = return $ singletonMap "!help" helpMsg}
|
||||
return . Just $ newMsgHandler { onMessage = help,
|
||||
onHelp = return $ singletonMap "!help" helpMsg }
|
||||
where
|
||||
helpMsg = "Get help. !help or !help <command>"
|
||||
|
||||
mkMsgHandler botConfig eventChan name =
|
||||
flip (`foldM` Nothing) [Logger.mkMsgHandler, SongSearch.mkMsgHandler, Auth.mkMsgHandler] $ \acc h ->
|
||||
case acc of
|
||||
Just _ -> return acc
|
||||
Nothing -> h botConfig eventChan name
|
||||
flip (`foldM` Nothing) [ Logger.mkMsgHandler
|
||||
, SongSearch.mkMsgHandler
|
||||
, Auth.mkMsgHandler
|
||||
, NickTracker.mkMsgHandler ]
|
||||
$ \acc h -> case acc of
|
||||
Just _ -> return acc
|
||||
Nothing -> h botConfig eventChan name
|
||||
|
||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
|
||||
pingPong state PingMsg { .. } = do
|
||||
|
@ -60,13 +61,11 @@ pingPong state IdleMsg { .. } | even (convert msgTime :: Int) = do
|
|||
pingPong _ _ = return Nothing
|
||||
|
||||
greeter :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
greeter ChannelMsg { .. } = case find (== clean msg) greetings of
|
||||
Nothing -> return Nothing
|
||||
Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user
|
||||
greeter ChannelMsg { .. } =
|
||||
return . map (ChannelMsgReply . (++ " ") . (++ userNick user)) . find (== clean msg) $ greetings
|
||||
where
|
||||
greetings = ["hi", "hello", "hey", "sup", "bye"
|
||||
, "good morning", "good evening", "good night"
|
||||
, "ohayo", "oyasumi"]
|
||||
greetings = [ "hi", "hello", "hey", "sup", "bye"
|
||||
, "good morning", "good evening", "good night" ]
|
||||
greeter _ = return Nothing
|
||||
|
||||
welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
|
@ -91,4 +90,3 @@ help ChannelMsg { .. }
|
|||
return . Just . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp
|
||||
|
||||
help _ = return Nothing
|
||||
|
||||
|
|
|
@ -18,15 +18,12 @@ import Control.Monad.State (get, put)
|
|||
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
|
||||
openLocalState, createArchive)
|
||||
import Data.Acid.Local (createCheckpointAndClose)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
|
||||
import Network.IRC.Handlers.Auth.Types
|
||||
import Network.IRC.Types
|
||||
|
||||
-- database
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Auth)
|
||||
|
||||
getToken :: Nick -> Query Auth (Maybe Token)
|
||||
getToken user = lookup user <$> asks auth
|
||||
|
||||
|
|
|
@ -1,10 +1,12 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Network.IRC.Handlers.Auth.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Data (Data)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
|
||||
import Network.IRC.Types hiding (user)
|
||||
|
||||
|
@ -14,6 +16,8 @@ newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeabl
|
|||
emptyAuth :: Auth
|
||||
emptyAuth = Auth mempty
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Auth)
|
||||
|
||||
data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
|
||||
|
||||
instance Event AuthEvent
|
||||
|
|
|
@ -20,6 +20,7 @@ import System.FilePath (FilePath, (</>), (<.>))
|
|||
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
type LoggerState = Maybe (Handle, Day)
|
||||
|
||||
|
@ -51,7 +52,7 @@ initMessageLogger botConfig state = do
|
|||
atomicWriteIORef state $ Just (logFileHandle, utctDay time)
|
||||
|
||||
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
|
||||
exitMessageLogger state = liftIO $ readIORef state >>= maybe (return ()) (hClose . fst)
|
||||
exitMessageLogger state = liftIO $ readIORef state >>= flip whenJust (hClose . fst)
|
||||
|
||||
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
|
||||
withLogFile action state = do
|
||||
|
@ -83,7 +84,7 @@ messageLogger message = case message of
|
|||
JoinMsg { .. } -> log "** {} JOINED" [userNick user]
|
||||
PartMsg { .. } -> log "** {} PARTED :{}" [userNick user, msg]
|
||||
QuitMsg { .. } -> log "** {} QUIT :{}" [userNick user, msg]
|
||||
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [userNick user, nick]
|
||||
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [userNick user, newNick]
|
||||
NamesMsg { .. } -> log "** USERS {}" [unwords nicks]
|
||||
_ -> const $ return Nothing
|
||||
where
|
||||
|
|
|
@ -0,0 +1,125 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Network.IRC.Handlers.NickTracker (mkMsgHandler) where
|
||||
|
||||
import qualified Data.IxSet as IS
|
||||
import qualified Data.UUID as U
|
||||
import qualified Data.UUID.V4 as U
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (Chan)
|
||||
import Control.Monad.Reader (ask)
|
||||
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 (getOne, (@=))
|
||||
|
||||
import Network.IRC.Handlers.NickTracker.Types
|
||||
import Network.IRC.Types hiding (Nick)
|
||||
import Network.IRC.Util
|
||||
|
||||
getByNick :: Nick -> Query NickTracking (Maybe NickTrack)
|
||||
getByNick nick = do
|
||||
NickTracking { .. } <- ask
|
||||
return . getOne $ nickTracking @= nick
|
||||
|
||||
getByCanonicalNick :: CanonicalNick -> Query NickTracking [NickTrack]
|
||||
getByCanonicalNick canonicalNick = do
|
||||
NickTracking { .. } <- ask
|
||||
return . IS.toList $ nickTracking @= canonicalNick
|
||||
|
||||
--getLastSeenOn :: CanonicalNick -> Query NickTracking LastSeenOn
|
||||
--getLastSeenOn = liftM (minimumEx . map lastSeenOn) . getByCanonicalNick
|
||||
|
||||
saveNickTrack :: NickTrack -> Update NickTracking ()
|
||||
saveNickTrack nt = do
|
||||
NickTracking { .. } <- get
|
||||
put . NickTracking $ IS.updateIx (nick nt) nt nickTracking
|
||||
|
||||
$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
|
||||
|
||||
nickTrackerMsg :: MonadMsgHandler m => IORef (AcidState NickTracking) -> Message -> m (Maybe Command)
|
||||
nickTrackerMsg state = go
|
||||
where
|
||||
go ChannelMsg { .. } = updateNickTrack user msg msgTime True >> handleCommands msg
|
||||
go ActionMsg { .. } = updateNickTrack user msg msgTime True >> return Nothing
|
||||
go JoinMsg { .. } = updateNickTrack user "" msgTime False >> return Nothing
|
||||
go PartMsg { .. } = updateNickTrack user msg msgTime False >> return Nothing
|
||||
go QuitMsg { .. } = updateNickTrack user msg msgTime False >> return Nothing
|
||||
go NickMsg { .. } = handleNickChange user newNick msgTime >> return Nothing
|
||||
go _ = return Nothing
|
||||
|
||||
updateNickTrack user message msgTime isChat = liftIO $ do
|
||||
acid <- readIORef state
|
||||
let nck = userNick user
|
||||
mnt <- query acid . GetByNick $ Nick nck
|
||||
(message', cn) <- case (message, mnt) of
|
||||
("", Just (NickTrack { .. })) -> return (lastMessage, canonicalNick)
|
||||
(_, Just (NickTrack { .. })) -> return (message, canonicalNick)
|
||||
_ -> do
|
||||
cn <- map (CanonicalNick . pack . U.toString) U.nextRandom
|
||||
return (message, cn)
|
||||
let lastMessageOn' = case (isChat, mnt) of
|
||||
(True, _) -> msgTime
|
||||
(False, Just (NickTrack { .. })) -> lastMessageOn
|
||||
(False, Nothing) -> msgTime
|
||||
|
||||
update acid . SaveNickTrack $
|
||||
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
|
||||
|
||||
handleNickChange user newNick msgTime = liftIO $ do
|
||||
acid <- readIORef state
|
||||
let prevNick = userNick user
|
||||
mpnt <- query acid . GetByNick $ Nick prevNick
|
||||
mnt <- query acid . GetByNick $ Nick newNick
|
||||
mInfo <- case (mpnt, mnt) of
|
||||
(Nothing, _) -> do
|
||||
cn <- map (CanonicalNick . pack . U.toString) U.nextRandom
|
||||
return $ Just ("", cn, msgTime)
|
||||
(Just nt, Nothing) -> return $ Just (lastMessage nt, canonicalNick nt, lastMessageOn nt)
|
||||
_ -> return Nothing
|
||||
whenJust mInfo $ \(message, cn, lastMessageOn') ->
|
||||
update acid . SaveNickTrack $
|
||||
NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
|
||||
|
||||
handleCommands message =
|
||||
if "!nick" `isPrefixOf` message
|
||||
then handleNickCommand state message
|
||||
else return Nothing
|
||||
|
||||
handleNickCommand :: MonadMsgHandler m => IORef(AcidState NickTracking) -> Text -> m (Maybe Command)
|
||||
handleNickCommand state msg = liftIO $ do
|
||||
acid <- readIORef state
|
||||
let nck = clean . unwords . drop 1 . words $ msg
|
||||
mcn <- liftM (map canonicalNick) . query acid . GetByNick $ Nick nck
|
||||
resp <- case mcn of
|
||||
Nothing -> return $ "Unknown nick: " ++ nck
|
||||
Just cn -> liftIO $ do
|
||||
nicks <- liftM (map ((\(Nick n) -> n) . nick)) . query acid . GetByCanonicalNick $ cn
|
||||
if length nicks == 1
|
||||
then return $ nck ++ " has only one nick"
|
||||
else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
|
||||
return . Just . ChannelMsgReply $ resp
|
||||
|
||||
stopNickTracker :: MonadMsgHandler m => IORef (AcidState NickTracking) -> m ()
|
||||
stopNickTracker state = liftIO $ do
|
||||
acid <- readIORef state
|
||||
createArchive acid
|
||||
createCheckpointAndClose acid
|
||||
|
||||
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||
mkMsgHandler BotConfig { .. } _ "nicktracker" = do
|
||||
state <- liftIO (openLocalState emptyNickTracking >>= newIORef)
|
||||
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
|
||||
, onStop = stopNickTracker state
|
||||
, onHelp = return $ singletonMap "!nick" helpMsg }
|
||||
where
|
||||
helpMsg = "Shows the user's other nicks. !nick <user nick>"
|
||||
mkMsgHandler _ _ _ = return Nothing
|
|
@ -0,0 +1,40 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Network.IRC.Handlers.NickTracker.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Data (Data)
|
||||
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
|
||||
newtype Nick = Nick Text deriving (Eq, Ord, Show, Data, Typeable)
|
||||
newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
|
||||
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
data NickTrack = NickTrack {
|
||||
nick :: Nick,
|
||||
canonicalNick :: CanonicalNick,
|
||||
lastSeenOn :: LastSeenOn,
|
||||
lastMessageOn :: UTCTime,
|
||||
lastMessage :: Text
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
instance Indexable NickTrack where
|
||||
empty = ixSet [ ixFun $ (: []) . nick
|
||||
, ixFun $ (: []) . canonicalNick
|
||||
, ixFun $ (: []) . lastSeenOn ]
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Nick)
|
||||
$(deriveSafeCopy 0 'base ''CanonicalNick)
|
||||
$(deriveSafeCopy 0 'base ''LastSeenOn)
|
||||
$(deriveSafeCopy 0 'base ''NickTrack)
|
||||
|
||||
newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack }
|
||||
deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''NickTracking)
|
||||
|
||||
emptyNickTracking :: NickTracking
|
||||
emptyNickTracking = NickTracking empty
|
|
@ -6,7 +6,7 @@ module Network.IRC.Protocol (msgFromLine, lineFromCommand) where
|
|||
|
||||
import ClassyPrelude
|
||||
import Data.List ((!!))
|
||||
import Data.Text (split)
|
||||
import Data.Text (split, strip)
|
||||
|
||||
import Network.IRC.Types
|
||||
|
||||
|
@ -36,8 +36,8 @@ msgFromLine (BotConfig { .. }) time line
|
|||
source = drop 1 . takeWhile isNotSpc $ line
|
||||
target = splits !! 2
|
||||
command = splits !! 1
|
||||
message = drop 1 . unwords . drop 3 $ splits
|
||||
quitMessage = drop 1 . unwords . drop 2 $ splits
|
||||
message = strip . drop 1 . unwords . drop 3 $ splits
|
||||
quitMessage = strip . drop 1 . unwords . drop 2 $ splits
|
||||
user = uncurry User . break (== '!') $ source
|
||||
mode = splits !! 3
|
||||
modeArgs = drop 4 splits
|
||||
|
|
|
@ -58,7 +58,7 @@ data Message =
|
|||
| JoinMsg { msgTime :: !UTCTime, user :: !User, msgLine :: !Text }
|
||||
| QuitMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
|
||||
| PartMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
|
||||
| NickMsg { msgTime :: !UTCTime, user :: !User, nick :: !Nick, msgLine :: !Text }
|
||||
| NickMsg { msgTime :: !UTCTime, user :: !User, newNick :: !Nick, msgLine :: !Text }
|
||||
| NickInUseMsg { msgTime :: !UTCTime, msgLine :: !Text }
|
||||
| KickMsg { msgTime :: !UTCTime, user :: !User, kickedNick :: !Nick, msg :: !Text
|
||||
, msgLine :: !Text }
|
||||
|
|
|
@ -9,6 +9,7 @@ module Network.IRC.Util where
|
|||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (Chan)
|
||||
import Data.Text (strip)
|
||||
|
||||
oneSec :: Int
|
||||
oneSec = 1000000
|
||||
|
@ -28,3 +29,9 @@ mapKeys = map fst . mapToList
|
|||
|
||||
mapValues :: IsMap map => map -> [MapValue map]
|
||||
mapValues = map snd . mapToList
|
||||
|
||||
whenJust :: Monad m => Maybe t -> (t -> m ()) -> m ()
|
||||
whenJust m f = maybe (return ()) f m
|
||||
|
||||
clean :: Text -> Text
|
||||
clean = toLower . strip
|
||||
|
|
|
@ -55,14 +55,14 @@ library
|
|||
text >=0.11 && <0.12,
|
||||
mtl >=2.1 && <2.2,
|
||||
network >=2.3 && <2.5,
|
||||
configurator >= 0.2,
|
||||
configurator >=0.2,
|
||||
time >=1.4.0,
|
||||
curl-aeson ==0.0.3,
|
||||
aeson >=0.6.0.0,
|
||||
HTTP >=4000,
|
||||
transformers >=0.3,
|
||||
classy-prelude ==0.9.1,
|
||||
text-format >= 0.3.1,
|
||||
text-format >=0.3.1,
|
||||
filepath >=1.3,
|
||||
directory >=1.2,
|
||||
lifted-base >=0.2,
|
||||
|
@ -98,14 +98,14 @@ executable hask-irc
|
|||
text >=0.11 && <0.12,
|
||||
mtl >=2.1 && <2.2,
|
||||
network >=2.3 && <2.5,
|
||||
configurator >= 0.2,
|
||||
configurator >=0.2,
|
||||
time >=1.4.0,
|
||||
curl-aeson ==0.0.3,
|
||||
aeson >=0.6.0.0,
|
||||
HTTP >=4000,
|
||||
transformers >=0.3,
|
||||
classy-prelude ==0.9.1,
|
||||
text-format >= 0.3.1,
|
||||
text-format >=0.3.1,
|
||||
filepath >=1.3,
|
||||
directory >=1.2,
|
||||
lifted-base >=0.2,
|
||||
|
|
Loading…
Reference in New Issue