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

Even more refactoring

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-05-25 01:09:31 +05:30
parent 200cc93e1b
commit 816d14109a
11 changed files with 99 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Network/IRC/Bot.hs
View File

@ -12,7 +12,7 @@ module Network.IRC.Bot
, eventProcessLoop )
where
import qualified Data.Text.Format as TF
import qualified Data.Text.Format as TF
import qualified System.Log.Logger as HSL
import ClassyPrelude
@ -97,10 +97,11 @@ messageProcessLoop lineChan commandChan !idleFor = do
mLine <- readLine lineChan
case mLine of
Timeout -> getCurrentTime >>= dispatchHandlers bot . IdleMsg >> return Idle
Timeout ->
getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg) >> return Idle
EOF -> infoM "Connection closed" >> return Disconnected
Line message -> do
nStatus <- case message of
Line (message@Message { .. }) -> do
nStatus <- case msgDetails of
JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined
KickMsg { .. } | kickedNick == nick -> infoM "Kicked" >> return Kicked
NickInUseMsg { .. } ->

35
Network/IRC/Handlers.hs
View File

@ -35,31 +35,32 @@ mkMsgHandler 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
, NickTracker.mkMsgHandler ] $ \handlers handler ->
case handlers of
Just _ -> return handlers
Nothing -> handler botConfig eventChan name
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
pingPong state PingMsg { .. } = do
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
io $ atomicWriteIORef state msgTime
return . Just $ PongCmd msg
pingPong state PongMsg { .. } = do
pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
io $ atomicWriteIORef state msgTime
return Nothing
pingPong state IdleMsg { .. } | even (convert msgTime :: Int) = do
BotConfig { .. } <- ask
let limit = fromIntegral $ botTimeout `div` 2
io $ do
lastComm <- readIORef state
if addUTCTime limit lastComm < msgTime
then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
else return Nothing
pingPong state Message { msgDetails = IdleMsg { .. }, .. }
| even (convert msgTime :: Int) = do
BotConfig { .. } <- ask
let limit = fromIntegral $ botTimeout `div` 2
io $ do
lastComm <- readIORef state
if addUTCTime limit lastComm < msgTime
then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
else return Nothing
pingPong _ _ = return Nothing
greeter :: MonadMsgHandler m => Message -> m (Maybe Command)
greeter ChannelMsg { .. } =
greeter Message { msgDetails = ChannelMsg { .. }, .. } =
return . map (ChannelMsgReply . (++ userNick user) . (++ " ")) . find (== clean msg) $ greetings
where
greetings = [ "hi", "hello", "hey", "sup", "bye"
@ -67,7 +68,7 @@ greeter ChannelMsg { .. } =
greeter _ = return Nothing
welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
welcomer JoinMsg { .. } = do
welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
BotConfig { .. } <- ask
if userNick user /= botNick
then return . Just . ChannelMsgReply $ "welcome back " ++ userNick user
@ -76,7 +77,7 @@ welcomer JoinMsg { .. } = do
welcomer _ = return Nothing
help :: MonadMsgHandler m => Message -> m (Maybe Command)
help ChannelMsg { .. }
help Message { msgDetails = ChannelMsg { .. }, .. }
| "!help" == clean msg = do
BotConfig { .. } <- ask
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo

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

@ -5,7 +5,7 @@
module Network.IRC.Handlers.Auth (mkMsgHandler) where
import qualified Data.UUID as U
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude
@ -46,7 +46,7 @@ issueToken acid user = do
-- handler
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m (Maybe Command)
authMessage state PrivMsg { .. }
authMessage state Message { msgDetails = PrivMsg { .. }, .. }
| "token" `isPrefixOf` msg = map (Just . PrivMsgReply user) . io $
readIORef state >>= flip issueToken (userNick user)
authMessage _ _ = return Nothing
@ -70,7 +70,7 @@ authEvent state event = case fromEvent event of
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler BotConfig { .. } _ "auth" = do
state <- io (openLocalState emptyAuth >>= newIORef)
state <- io $ openLocalState emptyAuth >>= newIORef
return . Just $ newMsgHandler { onMessage = authMessage state
, onEvent = authEvent state
, onStop = stopAuth state

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

@ -5,12 +5,12 @@
module Network.IRC.Handlers.Auth.Types where
import ClassyPrelude
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Network.IRC.Types hiding (user)
type Token = Text
type Token = Text
newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeable)
emptyAuth :: Auth

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

@ -2,8 +2,8 @@
module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where
import qualified Data.Configurator as C
import qualified Data.Text.Format as TF
import qualified Data.Configurator as C
import qualified Data.Text.Format as TF
import qualified Data.Text.Format.Params as TF
import ClassyPrelude hiding ((</>), (<.>), FilePath, log)
@ -73,7 +73,7 @@ withLogFile action state = do
return Nothing
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
messageLogger message = case message of
messageLogger Message { .. } = case msgDetails of
ChannelMsg { .. } -> log "<{}> {}" [userNick user, msg]
ActionMsg { .. } -> log "<{}> {} {}" [userNick user, userNick user, msg]
KickMsg { .. } -> log "** {} KICKED {} :{}" [userNick user, kickedNick, msg]
@ -85,6 +85,6 @@ messageLogger message = case message of
_ -> const $ return Nothing
where
log format args = withLogFile $ \logFile ->
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args)
fmtTime = pack . formatTime defaultTimeLocale "%F %T"

12
Network/IRC/Handlers/NickTracker.hs
View File

@ -5,8 +5,8 @@
module Network.IRC.Handlers.NickTracker (mkMsgHandler) where
import qualified Data.IxSet as IS
import qualified Data.UUID as U
import qualified Data.IxSet as IS
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude
@ -40,7 +40,7 @@ saveNickTrack nt = do
$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
nickTrackerMsg :: MonadMsgHandler m => IORef (AcidState NickTracking) -> Message -> m (Maybe Command)
nickTrackerMsg state message = case message of
nickTrackerMsg state Message { .. } = case msgDetails of
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands msg
ActionMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
JoinMsg { .. } -> updateNickTrack state user "" msgTime >> return Nothing
@ -66,9 +66,7 @@ updateNickTrack state user message msgTime = io $ do
(message', lastMessageOn', cn) <- case (message, mnt) of
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
_ -> do
cn <- newCanonicalNick
return (message, msgTime, cn)
_ -> newCanonicalNick >>= \cn -> return (message, msgTime, cn)
update acid . SaveNickTrack $
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
@ -138,7 +136,7 @@ stopNickTracker state = io $ do
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler BotConfig { .. } _ "nicktracker" = do
state <- io (openLocalState emptyNickTracking >>= newIORef)
state <- io $ openLocalState emptyNickTracking >>= newIORef
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
, onStop = stopNickTracker state
, onHelp = return helpMsgs }

17
Network/IRC/Handlers/NickTracker/Types.hs
View File

@ -4,13 +4,13 @@
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)
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 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)
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
data NickTrack = NickTrack {
nick :: !Nick,
@ -25,14 +25,13 @@ instance Indexable NickTrack where
, ixFun $ (: []) . canonicalNick
, ixFun $ (: []) . lastSeenOn ]
newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack }
deriving (Eq, Ord, Show, Data, Typeable)
$(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

2
Network/IRC/Handlers/SongSearch.hs
View File

@ -42,7 +42,7 @@ instance FromJSON Song where
parseJSON _ = mempty
songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
songSearch ChannelMsg { .. }
songSearch Message { msgDetails = ChannelMsg { .. }, .. }
| "!m " `isPrefixOf` msg = do
BotConfig { .. } <- ask
liftIO $ do

39
Network/IRC/Protocol.hs
View File

@ -1,4 +1,4 @@
module Network.IRC.Protocol (msgFromLine, lineFromCommand) where
module Network.IRC.Protocol (MessageParser, msgFromLine, lineFromCommand) where
import ClassyPrelude
import Data.List ((!!))
@ -6,25 +6,27 @@ import Data.Text (split, strip)
import Network.IRC.Types
msgFromLine :: BotConfig -> UTCTime -> Text -> Message
type MessageParser = BotConfig -> UTCTime -> Text -> Message
msgFromLine :: MessageParser
msgFromLine (BotConfig { .. }) time line
| "PING :" `isPrefixOf` line = PingMsg time (drop 6 line) line
| "PING :" `isPrefixOf` line = Message time line $ PingMsg (drop 6 line)
| otherwise = case command of
"PONG" -> PongMsg time message line
"JOIN" -> JoinMsg time user line
"QUIT" -> QuitMsg time user quitMessage line
"PART" -> PartMsg time user message line
"KICK" -> KickMsg time user kicked kickReason line
"PONG" -> Message time line $ PongMsg message
"JOIN" -> Message time line $ JoinMsg user
"QUIT" -> Message time line $ QuitMsg user quitMessage
"PART" -> Message time line $ PartMsg user message
"KICK" -> Message time line $ KickMsg user kicked kickReason
"MODE" -> if source == botNick
then ModeMsg time Self target message [] line
else ModeMsg time user target mode modeArgs line
"NICK" -> NickMsg time user (drop 1 target) line
"353" -> NamesMsg time namesNicks
"433" -> NickInUseMsg time line
"PRIVMSG" | target /= channel -> PrivMsg time user message line
| isActionMsg -> ActionMsg time user (initDef . drop 8 $ message) line
| otherwise -> ChannelMsg time user message line
_ -> OtherMsg time source command target message line
then Message time line $ ModeMsg Self target message []
else Message time line $ ModeMsg user target mode modeArgs
"NICK" -> Message time line $ NickMsg user (drop 1 target)
"353" -> Message time line $ NamesMsg namesNicks
"433" -> Message time line NickInUseMsg
"PRIVMSG" | target /= channel -> Message time line $ PrivMsg user message
| isActionMsg -> Message time line $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> Message time line $ ChannelMsg user message
_ -> Message time line $ OtherMsg source command target message
where
isSpc = (== ' ')
isNotSpc = not . isSpc
@ -40,8 +42,7 @@ msgFromLine (BotConfig { .. }) time line
kicked = splits !! 3
kickReason = drop 1 . unwords . drop 4 $ splits
nickPrefixes :: String
nickPrefixes = "~&@%+"
nickPrefixes = "~&@%+" :: String
namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits
stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack

59
Network/IRC/Types.hs
View File

@ -10,6 +10,7 @@ module Network.IRC.Types
, MsgHandlerName
, User (..)
, Message (..)
, MessageDetails (..)
, Command (..)
, Event (..)
, SomeEvent
@ -45,25 +46,25 @@ type MsgHandlerName = Text
data User = Self | User { userNick :: !Nick, userServer :: !Text }
deriving (Show, Eq)
data Message =
IdleMsg { msgTime :: !UTCTime}
| PingMsg { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text }
| PongMsg { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text }
| ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
| PrivMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
| ActionMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
| 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, newNick :: !Nick, msgLine :: !Text }
| NickInUseMsg { msgTime :: !UTCTime, msgLine :: !Text }
| KickMsg { msgTime :: !UTCTime, user :: !User, kickedNick :: !Nick, msg :: !Text
, msgLine :: !Text }
| ModeMsg { msgTime :: !UTCTime, user :: !User, target :: !Text, mode :: !Text
, modeArgs :: ![Text], msgLine :: !Text }
| NamesMsg { msgTime :: !UTCTime, nicks :: ![Nick] }
| OtherMsg { msgTime :: !UTCTime, source :: !Text, command :: !Text, target :: !Text
, msg :: !Text, msgLine :: !Text }
data Message = Message { msgTime :: !UTCTime, msgLine :: !Text, msgDetails :: MessageDetails}
deriving (Show, Eq)
data MessageDetails =
IdleMsg
| NickInUseMsg
| PingMsg { msg :: !Text }
| PongMsg { msg :: !Text }
| NamesMsg { nicks :: ![Nick] }
| ChannelMsg { user :: !User, msg :: !Text }
| PrivMsg { user :: !User, msg :: !Text }
| ActionMsg { user :: !User, msg :: !Text }
| JoinMsg { user :: !User }
| QuitMsg { user :: !User, msg :: !Text }
| PartMsg { user :: !User, msg :: !Text }
| NickMsg { user :: !User, newNick :: !Nick }
| KickMsg { user :: !User, kickedNick :: !Nick, msg :: !Text }
| ModeMsg { user :: !User, msgTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
| OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
deriving (Show, Eq)
data Command =
@ -113,11 +114,11 @@ data BotConfig = BotConfig { server :: !Text
, config :: !Config }
instance Show BotConfig where
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
"port = " ++ show port ++ "\n" ++
"channel = " ++ show channel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
"port = " ++ show port ++ "\n" ++
"channel = " ++ show channel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo)
data Bot = Bot { botConfig :: !BotConfig
@ -148,11 +149,11 @@ runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC
-- Message handlers
newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadReader BotConfig )
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadReader BotConfig )
class (MonadIO m, Applicative m, MonadReader BotConfig m) => MonadMsgHandler m where
msgHandler :: MsgHandlerT a -> m a

4
hask-irc.cabal
View File

@ -50,7 +50,7 @@ cabal-version: >=1.10
library
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections
BangPatterns, TupleSections, NamedFieldPuns
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
@ -93,7 +93,7 @@ executable hask-irc
-- LANGUAGE extensions used by modules in this package.
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections
BangPatterns, TupleSections, NamedFieldPuns
-- Other library packages from which modules are imported.
build-depends: base >=4.5 && <4.8,