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

Even more refactoring

master
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

7
Network/IRC/Bot.hs
View File

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

21
Network/IRC/Handlers.hs
View File

@ -35,19 +35,20 @@ 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
pingPong state Message { msgDetails = IdleMsg { .. }, .. }
| even (convert msgTime :: Int) = do
BotConfig { .. } <- ask
let limit = fromIntegral $ botTimeout `div` 2
io $ do
@ -59,7 +60,7 @@ pingPong state IdleMsg { .. } | even (convert msgTime :: Int) = do
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

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

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

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

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

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

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

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

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

39
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 =

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,