diff --git a/Network/IRC/Bot.hs b/Network/IRC/Bot.hs index 8d26dc2..f8a13fa 100644 --- a/Network/IRC/Bot.hs +++ b/Network/IRC/Bot.hs @@ -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 { .. } -> diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index 1b61c6f..a1fe922 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -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 diff --git a/Network/IRC/Handlers/Auth.hs b/Network/IRC/Handlers/Auth.hs index 23fd11c..a68e1f3 100644 --- a/Network/IRC/Handlers/Auth.hs +++ b/Network/IRC/Handlers/Auth.hs @@ -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 diff --git a/Network/IRC/Handlers/Auth/Types.hs b/Network/IRC/Handlers/Auth/Types.hs index e7cb23a..c961101 100644 --- a/Network/IRC/Handlers/Auth/Types.hs +++ b/Network/IRC/Handlers/Auth/Types.hs @@ -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 diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 33e4b8f..8224d74 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/Network/IRC/Handlers/MessageLogger.hs @@ -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" diff --git a/Network/IRC/Handlers/NickTracker.hs b/Network/IRC/Handlers/NickTracker.hs index fcb96a3..489f527 100644 --- a/Network/IRC/Handlers/NickTracker.hs +++ b/Network/IRC/Handlers/NickTracker.hs @@ -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 } diff --git a/Network/IRC/Handlers/NickTracker/Types.hs b/Network/IRC/Handlers/NickTracker/Types.hs index 8bc3a66..6f92898 100644 --- a/Network/IRC/Handlers/NickTracker/Types.hs +++ b/Network/IRC/Handlers/NickTracker/Types.hs @@ -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 diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index 5d6755a..a4a1a78 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -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 diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index 576baa0..8c087bb 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -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 diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index ead53e6..8344d8d 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -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 diff --git a/hask-irc.cabal b/hask-irc.cabal index fe90d39..ac5ad0f 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -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,