From 74be6dd162eae7102c6c2b46985284baddf2bad2 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sun, 11 May 2014 14:01:09 +0530 Subject: [PATCH] Changed msg handler design to make them stateful, added core IRC msg handlers --- .gitignore | 1 + Main.hs | 4 +- Network/IRC/Client.hs | 106 ++++++++++++++++--------- Network/IRC/Handlers.hs | 41 ++++++---- Network/IRC/Handlers/Core.hs | 55 +++++++++++++ Network/IRC/Handlers/SongSearch.hs | 21 +++-- Network/IRC/Protocol.hs | 23 +++--- Network/IRC/Types.hs | 120 +++++++++++++++++++++-------- config.cfg.template | 2 +- hask-irc.cabal | 8 +- 10 files changed, 270 insertions(+), 111 deletions(-) create mode 100644 Network/IRC/Handlers/Core.hs diff --git a/.gitignore b/.gitignore index 4d2b220..1b26fa7 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ cabal.sandbox.config dist config.cfg *sublime* +logs diff --git a/Main.hs b/Main.hs index d25c331..8ff872f 100644 --- a/Main.hs +++ b/Main.hs @@ -41,8 +41,8 @@ loadBotConfig configFile = do channel <- CF.require cfg "channel" botNick <- CF.require cfg "nick" timeout <- CF.require cfg "timeout" - handlers <- CF.require cfg "handlers" - return $ BotConfig server port channel botNick timeout handlers cfg + msghandlers <- CF.require cfg "msghandlers" + return $ BotConfig server port channel botNick timeout msghandlers cfg case eBotConfig of Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index f696632..4160300 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -5,10 +5,11 @@ module Network.IRC.Client (run) where import qualified Data.Text.Format as TF import qualified Data.Text.Format.Params as TF -import ClassyPrelude hiding (log) +import ClassyPrelude import Control.Concurrent -import Control.Monad.Reader hiding (forM_) -import Control.Monad.State hiding (forM_) +import Control.Monad.Reader hiding (forM_, foldM) +import Control.Monad.State hiding (forM_, foldM) +import Data.Maybe (fromJust) import Network import System.IO (hSetBuffering, BufferMode(..)) import System.Timeout @@ -20,14 +21,17 @@ import Network.IRC.Types oneSec :: Int oneSec = 1000000 -log :: Text -> IO () -log msg = getCurrentTime >>= \t -> TF.print "[{}] ** {}\n" $ TF.buildParams (t, msg) +debug :: Text -> IO () +debug msg = do + time <- getCurrentTime + TF.print "[{}] {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, msg) sendCommand :: Bot -> Command -> IO () sendCommand Bot { .. } reply = do + time <- getCurrentTime let line = lineFromCommand botConfig reply TF.hprint socket "{}\r\n" $ TF.Only line - TF.print "> {}\n" $ TF.Only line + TF.print "[{}} > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) listen :: IRC () listen = do @@ -44,64 +48,92 @@ listen = do Nothing -> return Disconnected Just line -> do now <- getCurrentTime - TF.print "[{}] {}\n" $ TF.buildParams (now, line) + debug $ "< " ++ line let message = msgFromLine botConfig now line case message of - JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined - KickMsg { .. } | kicked == nick -> log "Kicked" >> return Kicked - _ -> do - forkIO $ case message of - Ping { .. } -> sendCommand bot $ Pong msg - ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd - msg -> forM_ (handlers botConfig) $ \handlerName -> forkIO $ do - let mHandler = getHandler handlerName - case mHandler of - Nothing -> log $ "No handler found with name: " ++ handlerName - Just handler -> do - mCmd <- runHandler handler botConfig msg - case mCmd of - Nothing -> return () - Just cmd -> sendCommand bot cmd - return status + JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined + KickMsg { .. } | kicked == nick -> debug "Kicked" >> return Kicked + ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status + _ -> return status + + forM_ (msgHandlers botConfig) $ \msgHandlerName -> forkIO $ do + let mMsgHandler = getMsgHandler msgHandlerName + case mMsgHandler of + Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName + Just msgHandler -> do + let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates + mCmd <- runMsgHandler msgHandler botConfig msgHandlerState message + case mCmd of + Nothing -> return () + Just cmd -> sendCommand bot cmd + return status put nStatus when (nStatus /= Disconnected) listen connect :: BotConfig -> IO Bot connect botConfig@BotConfig { .. } = do - log "Connecting ..." + debug "Connecting ..." socket <- connectToWithRetry hSetBuffering socket LineBuffering - hSetBuffering stdout LineBuffering - log "Connected" - return $ Bot botConfig socket + msgHandlerStates <- loadMsgHandlers botConfig + debug "Connected" + return $ Bot botConfig socket msgHandlerStates where - connectToWithRetry = connectTo server (PortNumber (fromIntegral port)) + connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port)) `catch` (\(e :: SomeException) -> do - log ("Error while connecting: " ++ pack (show e) ++ ". Waiting.") + debug ("Error while connecting: " ++ pack (show e) ++ ". Waiting.") threadDelay (5 * oneSec) connectToWithRetry) +loadMsgHandlers :: BotConfig -> IO MsgHandlerStates +loadMsgHandlers botConfig@BotConfig { .. } = + flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do + debug $ "Loading msg handler: " ++ msgHandlerName + let mMsgHandler = getMsgHandler msgHandlerName + case mMsgHandler of + Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap + Just msgHandler -> do + msgHandlerState <- initMsgHandler msgHandler botConfig + return $ insertMap msgHandlerName msgHandlerState hMap + +unloadMsgHandlers :: Bot -> IO () +unloadMsgHandlers Bot { .. } = + forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do + debug $ "Unloading msg handler: " ++ msgHandlerName + let mMsgHandler = getMsgHandler msgHandlerName + case mMsgHandler of + Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) + Just msgHandler -> exitMsgHandler msgHandler botConfig msgHandlerState + + disconnect :: Bot -> IO () -disconnect bot = do - log "Disconnecting ..." - hClose . socket $ bot - log "Disconnected" +disconnect bot@Bot { .. } = do + debug "Disconnecting ..." + unloadMsgHandlers bot + hClose socket + debug "Disconnected" + +addCoreMsgHandlers :: BotConfig -> BotConfig +addCoreMsgHandlers botConfig = + botConfig { msgHandlers = hashNub $ msgHandlers botConfig ++ coreMsgHandlerNames } run :: BotConfig -> IO () -run botConfig = withSocketsDo $ do - log "Running with config:" +run botConfig' = withSocketsDo $ do + hSetBuffering stdout LineBuffering + debug "Running with config:" print botConfig status <- run_ case status of - Disconnected -> log "Connection timed out" >> run botConfig + Disconnected -> debug "Connection timed out" >> run botConfig Errored -> return () _ -> error "Unsupported status" where + botConfig = addCoreMsgHandlers botConfig' run_ = bracket (connect botConfig) disconnect $ \bot -> go bot `catch` \(e :: SomeException) -> do - log $ "Exception! " ++ pack (show e) + debug $ "Exception! " ++ pack (show e) return Errored go bot = do diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index a40f777..1f4d0c3 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -1,33 +1,44 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings, NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-} -module Network.IRC.Handlers (getHandler) where +module Network.IRC.Handlers (coreMsgHandlerNames, getMsgHandler) where + +import qualified Network.IRC.Handlers.Core as C +import qualified Network.IRC.Handlers.SongSearch as SS import ClassyPrelude +import Control.Monad.Reader import Data.Text (strip) -import Network.IRC.Handlers.SongSearch import Network.IRC.Types clean :: Text -> Text clean = toLower . strip -getHandler :: HandlerName -> Maybe Handler -getHandler "greeter" = Just $ Handler greeter -getHandler "welcomer" = Just $ Handler welcomer -getHandler "songsearch" = Just $ Handler songSearch -getHandler _ = Nothing +coreMsgHandlerNames :: [Text] +coreMsgHandlerNames = ["pingpong", "messagelogger"] -greeter :: Monad m => BotConfig -> Message -> m (Maybe Command) -greeter _ ChannelMsg { .. } = case find (== clean msg) greetings of +getMsgHandler :: MsgHandlerName -> Maybe MsgHandler +getMsgHandler "greeter" = Just $ newMsgHandler { msgHandlerRun = greeter } +getMsgHandler "welcomer" = Just $ newMsgHandler { msgHandlerRun = welcomer } +getMsgHandler name = listToMaybe $ mapMaybe (\f -> f name) + [C.getMsgHandler, SS.getMsgHandler] + + +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 where greetings = ["hi", "hello", "hey", "sup", "bye" , "good morning", "good evening", "good night" , "ohayo", "oyasumi"] -greeter _ _ = return Nothing +greeter _ = return Nothing -welcomer :: Monad m => BotConfig -> Message -> m (Maybe Command) -welcomer BotConfig { .. } JoinMsg { .. } - | userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user -welcomer _ _ = return Nothing +welcomer :: MonadMsgHandler m => Message -> m (Maybe Command) +welcomer JoinMsg { .. } = do + BotConfig { .. } <- ask + if userNick user /= botNick + then return . Just . ChannelMsgReply $ "welcome back " ++ userNick user + else return Nothing + +welcomer _ = return Nothing diff --git a/Network/IRC/Handlers/Core.hs b/Network/IRC/Handlers/Core.hs new file mode 100644 index 0000000..2613853 --- /dev/null +++ b/Network/IRC/Handlers/Core.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-} + +module Network.IRC.Handlers.Core (getMsgHandler) where + +import qualified Data.Configurator as C +import qualified Data.Text.Format as TF +import qualified Data.Text.Format.Params as TF + +import ClassyPrelude hiding (try, (), (<.>)) +import Control.Monad.Reader +import Control.Monad.State +import Data.Dynamic +import System.Directory +import System.FilePath +import System.IO + +import Network.IRC.Types + +getMsgHandler :: MsgHandlerName -> Maybe MsgHandler +getMsgHandler "pingpong" = Just $ newMsgHandler { msgHandlerRun = pingPong } +getMsgHandler "messagelogger" = Just $ newMsgHandler { msgHandlerInit = initMessageLogger + , msgHandlerRun = messageLogger + , msgHandlerExit = exitMessageLogger } +getMsgHandler _ = Nothing + +pingPong :: MonadMsgHandler m => Message -> m (Maybe Command) +pingPong Ping { .. } = return . Just $ Pong msg +pingPong _ = return Nothing + +initMessageLogger :: MonadMsgHandler m => m () +initMessageLogger = do + BotConfig { .. } <- ask + logFileHandle <- liftIO $ do + logFileDir <- C.require config "messagelogger.logdir" + createDirectoryIfMissing True logFileDir + let logFilePath = logFileDir unpack botNick <.> "log" + logFileHandle <- openFile logFilePath AppendMode + hSetBuffering logFileHandle LineBuffering + return logFileHandle + put $ toDyn logFileHandle + +exitMessageLogger :: MonadMsgHandler m => m () +exitMessageLogger = do + mHandle <- map fromDynamic get + case mHandle of + Nothing -> return () + Just logFileHandle -> liftIO $ hClose logFileHandle + +messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command) +messageLogger ChannelMsg { .. } = do + logFileHandle <- map (`fromDyn` error "No log file set") get + let time = formatTime defaultTimeLocale "%F %T" msgTime + liftIO $ TF.hprint logFileHandle "[{}] {}: {}\n" $ TF.buildParams (time, userNick user, msg) + return Nothing +messageLogger _ = return Nothing diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index c1f33a9..0aae887 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude, FlexibleContexts #-} -module Network.IRC.Handlers.SongSearch (songSearch) where +module Network.IRC.Handlers.SongSearch (getMsgHandler) where import qualified Data.Configurator as CF import ClassyPrelude hiding (try) import Control.Exception +import Control.Monad.Reader import Data.Aeson import Data.Aeson.Types (emptyArray) import Data.Text (strip) @@ -14,6 +15,10 @@ import Network.HTTP.Base import Network.IRC.Types +getMsgHandler :: MsgHandlerName -> Maybe MsgHandler +getMsgHandler "songsearch" = Just $ newMsgHandler { msgHandlerRun = songSearch } +getMsgHandler _ = Nothing + data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } deriving (Show, Eq) @@ -22,9 +27,11 @@ instance FromJSON Song where parseJSON a | a == emptyArray = return NoSong parseJSON _ = mempty -songSearch :: MonadIO m => BotConfig -> Message -> m (Maybe Command) -songSearch BotConfig { .. } ChannelMsg { .. } - | "!m " `isPrefixOf` msg = liftIO $ do +songSearch :: MonadMsgHandler m => Message -> m (Maybe Command) +songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg + then do + BotConfig { .. } <- ask + liftIO $ do let query = strip . drop 3 $ msg mApiKey <- CF.lookup config "songsearch.tinysong_apikey" map (Just . ChannelMsgReply) $ case mApiKey of @@ -40,5 +47,5 @@ songSearch BotConfig { .. } ChannelMsg { .. } Right song -> case song of Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url NoSong -> "No song found for: " ++ query - | otherwise = return Nothing -songSearch _ _ = return Nothing + else return Nothing +songSearch _ = return Nothing diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index eb5b185..d678fd1 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -10,20 +10,20 @@ import Network.IRC.Types msgFromLine :: BotConfig -> UTCTime -> Text -> Message msgFromLine (BotConfig { .. }) time line - | "PING :" `isPrefixOf` line = Ping time . drop 6 $ line + | "PING :" `isPrefixOf` line = Ping time (drop 6 line) line | otherwise = case command of - "JOIN" -> JoinMsg time user - "QUIT" -> QuitMsg time user message - "PART" -> PartMsg time user message - "KICK" -> KickMsg time user kicked kickReason + "JOIN" -> JoinMsg time user line + "QUIT" -> QuitMsg time user message line + "PART" -> PartMsg time user message line + "KICK" -> KickMsg time user kicked kickReason line "MODE" -> if source == botNick - then ModeMsg time Self target message [] - else ModeMsg time user target mode modeArgs - "NICK" -> NickMsg time user (drop 1 target) + then ModeMsg time Self target message [] line + else ModeMsg time user target mode modeArgs line + "NICK" -> NickMsg time user (drop 1 target) line "PRIVMSG" -> if target == channel - then ChannelMsg time user message - else PrivMsg time user message - _ -> OtherMsg time source command target message + then ChannelMsg time user message line + else PrivMsg time user message line + _ -> OtherMsg time source command target message line where isSpc = (== ' ') isNotSpc = not . isSpc @@ -46,4 +46,3 @@ lineFromCommand (BotConfig { .. }) reply = case reply of JoinCmd -> "JOIN " ++ channel ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg - diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 219d33f..5e4df74 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -1,53 +1,60 @@ {-# LANGUAGE RecordWildCards, RankNTypes, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-} -module Network.IRC.Types where +module Network.IRC.Types + (Channel, Nick, MsgHandlerName, + User (..), Message (..), Command (..), + BotConfig (..), BotStatus (..), Bot (..), + IRC, runIRC, + MonadMsgHandler, runMsgHandler, initMsgHandler, exitMsgHandler, + MsgHandlerState, MsgHandlerStates, MsgHandler (..), newMsgHandler) +where import ClassyPrelude import Control.Monad.Reader import Control.Monad.State import Data.Configurator.Types +import Data.Dynamic -type Channel = Text -type Nick = Text -type HandlerName = Text +type Channel = Text +type Nick = Text +type MsgHandlerName = Text -newtype Handler = Handler { - runHandler :: forall m . (MonadIO m) => BotConfig -> Message -> m (Maybe Command) -} - -data User = Self | User { userNick :: Nick, userServer :: Text } +data User = Self | User { userNick :: !Nick, userServer :: !Text } deriving (Show, Eq) data Message = - ChannelMsg { time :: UTCTime, user :: User, msg :: Text } - | PrivMsg { time :: UTCTime, user :: User, msg :: Text } - | Ping { time :: UTCTime, msg :: Text } - | JoinMsg { time :: UTCTime, user :: User } - | ModeMsg { time :: UTCTime, user :: User, target :: Text , mode :: Text, modeArgs :: [Text] } - | NickMsg { time :: UTCTime, user :: User, nick :: Text } - | QuitMsg { time :: UTCTime, user :: User, msg :: Text } - | PartMsg { time :: UTCTime, user :: User, msg :: Text } - | KickMsg { time :: UTCTime, user :: User, kicked :: Text , msg :: Text } - | OtherMsg { time :: UTCTime, source :: Text, command :: Text , target :: Text, msg :: Text } + ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | PrivMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | Ping { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text } + | JoinMsg { msgTime :: !UTCTime, user :: !User, msgLine :: !Text } + | ModeMsg { msgTime :: !UTCTime, user :: !User, target :: !Text, mode :: !Text + , modeArgs :: ![Text], msgLine :: !Text } + | NickMsg { msgTime :: !UTCTime, user :: !User, nick :: !Text, msgLine :: !Text } + | QuitMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | PartMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + | KickMsg { msgTime :: !UTCTime, user :: !User, kicked :: !Text, msg :: !Text + , msgLine :: !Text } + | OtherMsg { msgTime :: !UTCTime, source :: !Text, command :: !Text, target :: !Text + , msg :: !Text, msgLine :: !Text } deriving (Show, Eq) data Command = - Pong { rmsg :: Text } - | ChannelMsgReply { rmsg :: Text } - | PrivMsgReply { ruser :: User, rmsg :: Text } + Pong { rmsg :: !Text } + | ChannelMsgReply { rmsg :: !Text } + | PrivMsgReply { ruser :: !User, rmsg :: !Text } | NickCmd | UserCmd | JoinCmd deriving (Show, Eq) -data BotConfig = BotConfig { server :: String - , port :: Int - , channel :: Text - , botNick :: Text - , botTimeout :: Int - , handlers :: [HandlerName] - , config :: Config } +data BotConfig = BotConfig { server :: !Text + , port :: !Int + , channel :: !Text + , botNick :: !Text + , botTimeout :: !Int + , msgHandlers :: ![MsgHandlerName] + , config :: !Config } instance Show BotConfig where show BotConfig { .. } = "server = " ++ show server ++ "\n" ++ @@ -55,15 +62,62 @@ instance Show BotConfig where "channel = " ++ show channel ++ "\n" ++ "nick = " ++ show botNick ++ "\n" ++ "timeout = " ++ show botTimeout ++ "\n" ++ - "handlers = " ++ show handlers ++ "\n" + "handlers = " ++ show msgHandlers -data Bot = Bot { botConfig :: BotConfig, socket :: Handle } deriving (Show) +type MsgHandlerStates = Map MsgHandlerName MsgHandlerState + +data Bot = Bot { botConfig :: !BotConfig + , socket :: !Handle + , msgHandlerStates :: !MsgHandlerStates} data BotStatus = Connected | Disconnected | Joined | Kicked | Errored deriving (Show, Eq) newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } - deriving (Functor, Monad, MonadIO, MonadReader Bot, MonadState BotStatus) + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader Bot + , MonadState BotStatus) runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC + +type MsgHandlerState = Dynamic + +newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a } + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadState MsgHandlerState + , MonadReader BotConfig) + +class ( MonadIO m, Applicative m + , MonadState MsgHandlerState m, MonadReader BotConfig m) => MonadMsgHandler m where + msgHandler :: MsgHandlerT a -> m a + +instance MonadMsgHandler MsgHandlerT where + msgHandler = id + +runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command) +runMsgHandler MsgHandler { .. } botConfig msgHandlerState = + flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler . msgHandlerRun + +initMsgHandler :: MsgHandler -> BotConfig -> IO MsgHandlerState +initMsgHandler MsgHandler { .. } botConfig = + flip runReaderT botConfig . flip execStateT (toDyn ()) . _runMsgHandler $ msgHandlerInit + +exitMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> IO () +exitMsgHandler MsgHandler { .. } botConfig msgHandlerState = + flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler $ msgHandlerExit + +data MsgHandler = MsgHandler { msgHandlerInit :: !(forall m . MonadMsgHandler m => m ()) + , msgHandlerRun :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)) + , msgHandlerExit :: !(forall m . MonadMsgHandler m => m ()) } + +newMsgHandler :: MsgHandler +newMsgHandler = MsgHandler { msgHandlerInit = return () + , msgHandlerRun = const $ return Nothing + , msgHandlerExit = return () } diff --git a/config.cfg.template b/config.cfg.template index 5ad71a3..5bc2131 100644 --- a/config.cfg.template +++ b/config.cfg.template @@ -2,7 +2,7 @@ server = "irc.freenode.net" port = 6667 channel = "#testtesttest" nick = "haskman" -handlers = ["greeter", "welcomer", "songsearch"] +msghandlers = ["greeter", "welcomer", "songsearch"] songsearch { tinysong_apikey = "xxxyyyzzz" diff --git a/hask-irc.cabal b/hask-irc.cabal index b35717c..2bb1b7f 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -52,14 +52,14 @@ library build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0, curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3, - classy-prelude ==0.9.1, text-format >= 0.3.1 + classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2 exposed-modules: Network.IRC.Types, Network.IRC.Protocol, Network.IRC.Handlers, Network.IRC.Client default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields + ghc-options: -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields -fno-warn-orphans executable hask-irc @@ -76,7 +76,7 @@ executable hask-irc build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0, curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3, - classy-prelude ==0.9.1, text-format >= 0.3.1 + classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2 -- Directories containing source files. -- hs-source-dirs: @@ -84,5 +84,5 @@ executable hask-irc -- Base language which the package is written in. default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields + ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans