diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index af1d8ff..d531592 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/hask-irc-core/Network/IRC/Client.hs @@ -18,6 +18,7 @@ import System.Log.Logger.TH (deriveLoggers) import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch)) import Network.IRC.Bot +import qualified Network.IRC.Handlers.Core as Core import Network.IRC.Types import Network.IRC.Util @@ -56,7 +57,7 @@ connect botConfig@BotConfig { .. } = do flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler -> case finalHandler of Just _ -> return finalHandler - Nothing -> handler botConfig eventChan name + Nothing -> msgHandlerMaker handler botConfig eventChan name loadMsgHandlers eventChan = flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do @@ -99,7 +100,8 @@ runBotIntenal botConfig' = withSocketsDo $ do botConfig = botConfig' { msgHandlerInfo = foldl' (\m name -> insertMap name mempty m) mempty - (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames) + (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames), + msgHandlerMakers = ordNub $ Core.mkMsgHandler : msgHandlerMakers botConfig' } handleErrors :: SomeException -> IO BotStatus diff --git a/hask-irc-handlers/Network/IRC/Handlers/Core.hs b/hask-irc-core/Network/IRC/Handlers/Core.hs similarity index 82% rename from hask-irc-handlers/Network/IRC/Handlers/Core.hs rename to hask-irc-core/Network/IRC/Handlers/Core.hs index 343e20d..88c4c7a 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Core.hs +++ b/hask-irc-core/Network/IRC/Handlers/Core.hs @@ -9,15 +9,17 @@ import Network.IRC.Types import Network.IRC.Util mkMsgHandler :: MsgHandlerMaker -mkMsgHandler _ _ "pingpong" = do - state <- getCurrentTime >>= newIORef - return . Just $ newMsgHandler { onMessage = pingPong state } -mkMsgHandler _ _ "help" = - return . Just $ newMsgHandler { onMessage = help, - onHelp = return $ singletonMap "!help" helpMsg } +mkMsgHandler = MsgHandlerMaker "core" go where + go _ _ "pingpong" = do + state <- getCurrentTime >>= newIORef + return . Just $ newMsgHandler { onMessage = pingPong state } + go _ _ "help" = + return . Just $ newMsgHandler { onMessage = help, + onHelp = return $ singletonMap "!help" helpMsg } + go _ _ _ = return Nothing + helpMsg = "Get help. !help or !help " -mkMsgHandler _ _ _ = return Nothing pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command] pingPong state Message { msgDetails = PingMsg { .. }, .. } = do diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index eba688a..dc65d81 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/hask-irc-core/Network/IRC/Types.hs @@ -28,7 +28,7 @@ module Network.IRC.Types , handleEvent , stopMsgHandler , getHelp - , MsgHandlerMaker ) + , MsgHandlerMaker (..)) where import ClassyPrelude @@ -211,4 +211,12 @@ newMsgHandler = MsgHandler { onHelp = return mempty } -type MsgHandlerMaker = BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +data MsgHandlerMaker = MsgHandlerMaker { + msgHandlerName :: !MsgHandlerName, + msgHandlerMaker :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +} + +instance Eq MsgHandlerMaker where + m1 == m2 = msgHandlerName m1 == msgHandlerName m2 +instance Ord MsgHandlerMaker where + m1 `compare` m2 = msgHandlerName m1 `compare` msgHandlerName m2 diff --git a/hask-irc-core/hask-irc-core.cabal b/hask-irc-core/hask-irc-core.cabal index ac16dd0..fbdc84a 100644 --- a/hask-irc-core/hask-irc-core.cabal +++ b/hask-irc-core/hask-irc-core.cabal @@ -73,7 +73,9 @@ library Network.IRC.Protocol, Network.IRC.Util, Network.IRC.Bot, - Network.IRC.Client + Network.IRC.Client, + Network.IRC.Handlers.Core + default-language: Haskell2010 diff --git a/hask-irc-handlers/Network/IRC/Handlers.hs b/hask-irc-handlers/Network/IRC/Handlers.hs index 2feaf94..d2d8019 100644 --- a/hask-irc-handlers/Network/IRC/Handlers.hs +++ b/hask-irc-handlers/Network/IRC/Handlers.hs @@ -1,7 +1,6 @@ module Network.IRC.Handlers (allMsgHandlerMakers) where import qualified Network.IRC.Handlers.Auth as Auth -import qualified Network.IRC.Handlers.Core as Core import qualified Network.IRC.Handlers.Greet as Greet import qualified Network.IRC.Handlers.MessageLogger as Logger import qualified Network.IRC.Handlers.NickTracker as NickTracker @@ -13,7 +12,6 @@ import Network.IRC.Types allMsgHandlerMakers :: [MsgHandlerMaker] allMsgHandlerMakers = [ Auth.mkMsgHandler - , Core.mkMsgHandler , Greet.mkMsgHandler , Logger.mkMsgHandler , NickTracker.mkMsgHandler diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs index 6290201..1592067 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs @@ -66,12 +66,14 @@ authEvent state event = case fromEvent event of _ -> return RespNothing mkMsgHandler :: MsgHandlerMaker -mkMsgHandler BotConfig { .. } _ "auth" = do - state <- io $ openLocalState emptyAuth >>= newIORef - return . Just $ newMsgHandler { onMessage = authMessage state - , onEvent = authEvent state - , onStop = stopAuth state - , onHelp = return $ singletonMap "token" helpMsg } +mkMsgHandler = MsgHandlerMaker "auth" go where - helpMsg = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token" -mkMsgHandler _ _ _ = return Nothing + helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token" + + go BotConfig { .. } _ "auth" = do + state <- io $ openLocalState emptyAuth >>= newIORef + return . Just $ newMsgHandler { onMessage = authMessage state + , onEvent = authEvent state + , onStop = stopAuth state + , onHelp = return $ singletonMap "token" (helpMsg botNick) } + go _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs index 0194971..448a83a 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs @@ -7,9 +7,11 @@ import Network.IRC.Types import Network.IRC.Util mkMsgHandler :: MsgHandlerMaker -mkMsgHandler _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter } -mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer } -mkMsgHandler _ _ _ = return Nothing +mkMsgHandler = MsgHandlerMaker "greeter" go + where + go _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter } + go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer } + go _ _ _ = return Nothing greeter :: MonadMsgHandler m => Message -> m [Command] greeter Message { msgDetails = ChannelMsg { .. }, .. } = diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index 67c476d..9619e81 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs @@ -20,12 +20,14 @@ import Network.IRC.Util type LoggerState = Maybe (Handle, Day) mkMsgHandler :: MsgHandlerMaker -mkMsgHandler botConfig _ "messagelogger" = do - state <- io $ newIORef Nothing - initMessageLogger botConfig state - return . Just $ newMsgHandler { onMessage = flip messageLogger state - , onStop = exitMessageLogger state } -mkMsgHandler _ _ _ = return Nothing +mkMsgHandler = MsgHandlerMaker "messagelogger" go + where + go botConfig _ "messagelogger" = do + state <- io $ newIORef Nothing + initMessageLogger botConfig state + return . Just $ newMsgHandler { onMessage = flip messageLogger state + , onStop = exitMessageLogger state } + go _ _ _ = return Nothing getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs index 65a0253..0f9cd48 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs @@ -187,19 +187,21 @@ stopNickTracker state = io $ do createCheckpointAndClose acid mkMsgHandler :: MsgHandlerMaker -mkMsgHandler BotConfig { .. } _ "nicktracker" = do - state <- io $ do - now <- getCurrentTime - refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int) - acid <- openLocalState emptyNickTracking - newIORef (NickTrackingState acid refreshInterval mempty now) - return . Just $ newMsgHandler { onMessage = nickTrackerMsg state - , onEvent = nickTrackerEvent state - , onStop = stopNickTracker state - , onHelp = return helpMsgs } +mkMsgHandler = MsgHandlerMaker "nicktracker" go where helpMsgs = mapFromList [ ("!nicks", "Shows alternate nicks of the user. !nicks "), ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen "), ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ] -mkMsgHandler _ _ _ = return Nothing + + go BotConfig { .. } _ "nicktracker" = do + state <- io $ do + now <- getCurrentTime + refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int) + acid <- openLocalState emptyNickTracking + newIORef (NickTrackingState acid refreshInterval mempty now) + return . Just $ newMsgHandler { onMessage = nickTrackerMsg state + , onEvent = nickTrackerEvent state + , onStop = stopNickTracker state + , onHelp = return helpMsgs } + go _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs index 3b7775b..cb2163a 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs @@ -21,12 +21,14 @@ import Network.IRC.Types $(deriveLoggers "HSL" [HSL.ERROR]) mkMsgHandler :: MsgHandlerMaker -mkMsgHandler _ _ "songsearch" = - return . Just $ newMsgHandler { onMessage = songSearch, - onHelp = return $ singletonMap "!m" helpMsg } +mkMsgHandler = MsgHandlerMaker "songsearch" go where helpMsg = "Search for song. !m or !m - " -mkMsgHandler _ _ _ = return Nothing + + go _ _ "songsearch" = + return . Just $ newMsgHandler { onMessage = songSearch, + onHelp = return $ singletonMap "!m" helpMsg } + go _ _ _ = return Nothing data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } deriving (Show, Eq) diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs index 6065b68..337ce0c 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs @@ -126,15 +126,17 @@ stopTell state = io $ do createCheckpointAndClose acid mkMsgHandler :: MsgHandlerMaker -mkMsgHandler BotConfig { .. } eventChan "tells" = do - acid <- openLocalState emptyTells - state <- newIORef (TellState acid) - return . Just $ newMsgHandler { onMessage = tellMsg eventChan state - , onEvent = tellEvent eventChan state - , onStop = stopTell state - , onHelp = return helpMsgs } +mkMsgHandler = MsgHandlerMaker "tell" go where + go BotConfig { .. } eventChan "tell" = do + acid <- openLocalState emptyTells + state <- newIORef (TellState acid) + return . Just $ newMsgHandler { onMessage = tellMsg eventChan state + , onEvent = tellEvent eventChan state + , onStop = stopTell state + , onHelp = return helpMsgs } + go _ _ _ = return Nothing + helpMsgs = mapFromList [ ("!tell", "Publically passes a message to a user or a bunch of users. " ++ "!tell or !tell < ...> .") ] -mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/hask-irc-handlers.cabal b/hask-irc-handlers/hask-irc-handlers.cabal index 57714c4..f933682 100644 --- a/hask-irc-handlers/hask-irc-handlers.cabal +++ b/hask-irc-handlers/hask-irc-handlers.cabal @@ -78,7 +78,6 @@ library exposed-modules: Network.IRC.Handlers, Network.IRC.Handlers.Auth, Network.IRC.Handlers.Auth.Types, - Network.IRC.Handlers.Core, Network.IRC.Handlers.Greet, Network.IRC.Handlers.MessageLogger, Network.IRC.Handlers.NickTracker, diff --git a/hask-irc-runner/Main.hs b/hask-irc-runner/Main.hs index 7882c4b..126545e 100644 --- a/hask-irc-runner/Main.hs +++ b/hask-irc-runner/Main.hs @@ -1,21 +1,11 @@ -{-# LANGUAGE OverlappingInstances #-} - module Main where -import qualified Data.Configurator as CF - import ClassyPrelude hiding (getArgs) -import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..)) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import Network.IRC.Client -import Network.IRC.Handlers -import Network.IRC.Types - -instance Configured a => Configured [a] where - convert (List xs) = Just . mapMaybe convert $ xs - convert _ = Nothing +import Network.IRC.Config main :: IO () main = do @@ -30,26 +20,3 @@ main = do -- load config and start the bot let configFile = headEx args loadBotConfig configFile >>= runBot - -loadBotConfig :: String -> IO BotConfig -loadBotConfig configFile = do - eCfg <- try $ CF.load [CF.Required configFile] - case eCfg of - Left (ParseError _ _) -> error "Error while loading config" - Right cfg -> do - eBotConfig <- try $ do - handlers :: [Text] <- CF.require cfg "msghandlers" - let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers - BotConfig <$> - CF.require cfg "server" <*> - CF.require cfg "port" <*> - CF.require cfg "channel" <*> - (Nick <$> CF.require cfg "nick") <*> - CF.require cfg "timeout" <*> - pure handlerInfo <*> - pure allMsgHandlerMakers <*> - pure cfg - - case eBotConfig of - Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k - Right botConf -> return botConf diff --git a/hask-irc-runner/Network/IRC/Config.hs b/hask-irc-runner/Network/IRC/Config.hs new file mode 100644 index 0000000..d1512d5 --- /dev/null +++ b/hask-irc-runner/Network/IRC/Config.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverlappingInstances #-} + +module Network.IRC.Config (loadBotConfig) where + +import qualified Data.Configurator as CF + +import ClassyPrelude +import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..)) + +import Network.IRC.Handlers +import Network.IRC.Types + +instance Configured a => Configured [a] where + convert (List xs) = Just . mapMaybe convert $ xs + convert _ = Nothing + +loadBotConfig :: String -> IO BotConfig +loadBotConfig configFile = do + eCfg <- try $ CF.load [CF.Required configFile] + case eCfg of + Left (ParseError _ _) -> error "Error while loading config" + Right cfg -> do + eBotConfig <- try $ do + handlers :: [Text] <- CF.require cfg "msghandlers" + let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers + BotConfig <$> + CF.require cfg "server" <*> + CF.require cfg "port" <*> + CF.require cfg "channel" <*> + (Nick <$> CF.require cfg "nick") <*> + CF.require cfg "timeout" <*> + pure handlerInfo <*> + pure allMsgHandlerMakers <*> + pure cfg + + case eBotConfig of + Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k + Right botConf -> return botConf