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

Added nick tracking handler

master
Abhinav Sarkar 2014-05-23 02:45:45 +05:30
parent 96a61f3b32
commit 02d1b7ab98
11 changed files with 205 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Network/IRC/Bot.hs
View File

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

30
Network/IRC/Handlers.hs
View File

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

3
Network/IRC/Handlers/Auth.hs
View File

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

4
Network/IRC/Handlers/Auth/Types.hs
View File

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

5
Network/IRC/Handlers/MessageLogger.hs
View File

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

125
Network/IRC/Handlers/NickTracker.hs Normal file
View File

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

40
Network/IRC/Handlers/NickTracker/Types.hs Normal file
View File

@ -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
Network/IRC/Protocol.hs
View File

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

2
Network/IRC/Types.hs
View File

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

7
Network/IRC/Util.hs
View File

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

8
hask-irc.cabal
View File

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