More refactoring to simplify dependencies between modules
parent
924e023e27
commit
5b28bdbe3e
|
@ -18,6 +18,7 @@ import System.Log.Logger.TH (deriveLoggers)
|
||||||
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
|
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
|
||||||
|
|
||||||
import Network.IRC.Bot
|
import Network.IRC.Bot
|
||||||
|
import qualified Network.IRC.Handlers.Core as Core
|
||||||
import Network.IRC.Types
|
import Network.IRC.Types
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
|
||||||
|
@ -56,7 +57,7 @@ connect botConfig@BotConfig { .. } = do
|
||||||
flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
|
flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
|
||||||
case finalHandler of
|
case finalHandler of
|
||||||
Just _ -> return finalHandler
|
Just _ -> return finalHandler
|
||||||
Nothing -> handler botConfig eventChan name
|
Nothing -> msgHandlerMaker handler botConfig eventChan name
|
||||||
|
|
||||||
loadMsgHandlers eventChan =
|
loadMsgHandlers eventChan =
|
||||||
flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
|
flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
|
||||||
|
@ -99,7 +100,8 @@ runBotIntenal botConfig' = withSocketsDo $ do
|
||||||
botConfig = botConfig' {
|
botConfig = botConfig' {
|
||||||
msgHandlerInfo =
|
msgHandlerInfo =
|
||||||
foldl' (\m name -> insertMap name mempty m) mempty
|
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
|
handleErrors :: SomeException -> IO BotStatus
|
||||||
|
|
|
@ -9,15 +9,17 @@ import Network.IRC.Types
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler _ _ "pingpong" = do
|
mkMsgHandler = MsgHandlerMaker "core" go
|
||||||
state <- getCurrentTime >>= newIORef
|
|
||||||
return . Just $ newMsgHandler { onMessage = pingPong state }
|
|
||||||
mkMsgHandler _ _ "help" =
|
|
||||||
return . Just $ newMsgHandler { onMessage = help,
|
|
||||||
onHelp = return $ singletonMap "!help" helpMsg }
|
|
||||||
where
|
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 <command>"
|
helpMsg = "Get help. !help or !help <command>"
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
|
||||||
|
|
||||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
|
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
|
||||||
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
|
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
|
|
@ -28,7 +28,7 @@ module Network.IRC.Types
|
||||||
, handleEvent
|
, handleEvent
|
||||||
, stopMsgHandler
|
, stopMsgHandler
|
||||||
, getHelp
|
, getHelp
|
||||||
, MsgHandlerMaker )
|
, MsgHandlerMaker (..))
|
||||||
where
|
where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
@ -211,4 +211,12 @@ newMsgHandler = MsgHandler {
|
||||||
onHelp = return mempty
|
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
|
||||||
|
|
|
@ -73,7 +73,9 @@ library
|
||||||
Network.IRC.Protocol,
|
Network.IRC.Protocol,
|
||||||
Network.IRC.Util,
|
Network.IRC.Util,
|
||||||
Network.IRC.Bot,
|
Network.IRC.Bot,
|
||||||
Network.IRC.Client
|
Network.IRC.Client,
|
||||||
|
Network.IRC.Handlers.Core
|
||||||
|
|
||||||
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
module Network.IRC.Handlers (allMsgHandlerMakers) where
|
module Network.IRC.Handlers (allMsgHandlerMakers) where
|
||||||
|
|
||||||
import qualified Network.IRC.Handlers.Auth as Auth
|
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.Greet as Greet
|
||||||
import qualified Network.IRC.Handlers.MessageLogger as Logger
|
import qualified Network.IRC.Handlers.MessageLogger as Logger
|
||||||
import qualified Network.IRC.Handlers.NickTracker as NickTracker
|
import qualified Network.IRC.Handlers.NickTracker as NickTracker
|
||||||
|
@ -13,7 +12,6 @@ import Network.IRC.Types
|
||||||
allMsgHandlerMakers :: [MsgHandlerMaker]
|
allMsgHandlerMakers :: [MsgHandlerMaker]
|
||||||
allMsgHandlerMakers = [
|
allMsgHandlerMakers = [
|
||||||
Auth.mkMsgHandler
|
Auth.mkMsgHandler
|
||||||
, Core.mkMsgHandler
|
|
||||||
, Greet.mkMsgHandler
|
, Greet.mkMsgHandler
|
||||||
, Logger.mkMsgHandler
|
, Logger.mkMsgHandler
|
||||||
, NickTracker.mkMsgHandler
|
, NickTracker.mkMsgHandler
|
||||||
|
|
|
@ -66,12 +66,14 @@ authEvent state event = case fromEvent event of
|
||||||
_ -> return RespNothing
|
_ -> return RespNothing
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler BotConfig { .. } _ "auth" = do
|
mkMsgHandler = MsgHandlerMaker "auth" go
|
||||||
state <- io $ openLocalState emptyAuth >>= newIORef
|
|
||||||
return . Just $ newMsgHandler { onMessage = authMessage state
|
|
||||||
, onEvent = authEvent state
|
|
||||||
, onStop = stopAuth state
|
|
||||||
, onHelp = return $ singletonMap "token" helpMsg }
|
|
||||||
where
|
where
|
||||||
helpMsg = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token"
|
helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token"
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
|
||||||
|
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
|
||||||
|
|
|
@ -7,9 +7,11 @@ import Network.IRC.Types
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter }
|
mkMsgHandler = MsgHandlerMaker "greeter" go
|
||||||
mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
|
where
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
go _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter }
|
||||||
|
go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
|
||||||
|
go _ _ _ = return Nothing
|
||||||
|
|
||||||
greeter :: MonadMsgHandler m => Message -> m [Command]
|
greeter :: MonadMsgHandler m => Message -> m [Command]
|
||||||
greeter Message { msgDetails = ChannelMsg { .. }, .. } =
|
greeter Message { msgDetails = ChannelMsg { .. }, .. } =
|
||||||
|
|
|
@ -20,12 +20,14 @@ import Network.IRC.Util
|
||||||
type LoggerState = Maybe (Handle, Day)
|
type LoggerState = Maybe (Handle, Day)
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler botConfig _ "messagelogger" = do
|
mkMsgHandler = MsgHandlerMaker "messagelogger" go
|
||||||
state <- io $ newIORef Nothing
|
where
|
||||||
initMessageLogger botConfig state
|
go botConfig _ "messagelogger" = do
|
||||||
return . Just $ newMsgHandler { onMessage = flip messageLogger state
|
state <- io $ newIORef Nothing
|
||||||
, onStop = exitMessageLogger state }
|
initMessageLogger botConfig state
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
return . Just $ newMsgHandler { onMessage = flip messageLogger state
|
||||||
|
, onStop = exitMessageLogger state }
|
||||||
|
go _ _ _ = return Nothing
|
||||||
|
|
||||||
getLogFilePath :: BotConfig -> IO FilePath
|
getLogFilePath :: BotConfig -> IO FilePath
|
||||||
getLogFilePath BotConfig { .. } = do
|
getLogFilePath BotConfig { .. } = do
|
||||||
|
|
|
@ -187,19 +187,21 @@ stopNickTracker state = io $ do
|
||||||
createCheckpointAndClose acid
|
createCheckpointAndClose acid
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler BotConfig { .. } _ "nicktracker" = do
|
mkMsgHandler = MsgHandlerMaker "nicktracker" go
|
||||||
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 }
|
|
||||||
where
|
where
|
||||||
helpMsgs = mapFromList [
|
helpMsgs = mapFromList [
|
||||||
("!nicks", "Shows alternate nicks of the user. !nicks <nick>"),
|
("!nicks", "Shows alternate nicks of the user. !nicks <nick>"),
|
||||||
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
|
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
|
||||||
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
|
("!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
|
||||||
|
|
|
@ -21,12 +21,14 @@ import Network.IRC.Types
|
||||||
$(deriveLoggers "HSL" [HSL.ERROR])
|
$(deriveLoggers "HSL" [HSL.ERROR])
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler _ _ "songsearch" =
|
mkMsgHandler = MsgHandlerMaker "songsearch" go
|
||||||
return . Just $ newMsgHandler { onMessage = songSearch,
|
|
||||||
onHelp = return $ singletonMap "!m" helpMsg }
|
|
||||||
where
|
where
|
||||||
helpMsg = "Search for song. !m <song> or !m <artist> - <song>"
|
helpMsg = "Search for song. !m <song> or !m <artist> - <song>"
|
||||||
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 }
|
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
|
@ -126,15 +126,17 @@ stopTell state = io $ do
|
||||||
createCheckpointAndClose acid
|
createCheckpointAndClose acid
|
||||||
|
|
||||||
mkMsgHandler :: MsgHandlerMaker
|
mkMsgHandler :: MsgHandlerMaker
|
||||||
mkMsgHandler BotConfig { .. } eventChan "tells" = do
|
mkMsgHandler = MsgHandlerMaker "tell" go
|
||||||
acid <- openLocalState emptyTells
|
|
||||||
state <- newIORef (TellState acid)
|
|
||||||
return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
|
|
||||||
, onEvent = tellEvent eventChan state
|
|
||||||
, onStop = stopTell state
|
|
||||||
, onHelp = return helpMsgs }
|
|
||||||
where
|
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 [
|
helpMsgs = mapFromList [
|
||||||
("!tell", "Publically passes a message to a user or a bunch of users. " ++
|
("!tell", "Publically passes a message to a user or a bunch of users. " ++
|
||||||
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
|
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
|
||||||
|
|
|
@ -78,7 +78,6 @@ library
|
||||||
exposed-modules: Network.IRC.Handlers,
|
exposed-modules: Network.IRC.Handlers,
|
||||||
Network.IRC.Handlers.Auth,
|
Network.IRC.Handlers.Auth,
|
||||||
Network.IRC.Handlers.Auth.Types,
|
Network.IRC.Handlers.Auth.Types,
|
||||||
Network.IRC.Handlers.Core,
|
|
||||||
Network.IRC.Handlers.Greet,
|
Network.IRC.Handlers.Greet,
|
||||||
Network.IRC.Handlers.MessageLogger,
|
Network.IRC.Handlers.MessageLogger,
|
||||||
Network.IRC.Handlers.NickTracker,
|
Network.IRC.Handlers.NickTracker,
|
||||||
|
|
|
@ -1,21 +1,11 @@
|
||||||
{-# LANGUAGE OverlappingInstances #-}
|
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
|
||||||
|
|
||||||
import ClassyPrelude hiding (getArgs)
|
import ClassyPrelude hiding (getArgs)
|
||||||
import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
|
|
||||||
import System.Environment (getArgs, getProgName)
|
import System.Environment (getArgs, getProgName)
|
||||||
import System.Exit (exitFailure)
|
import System.Exit (exitFailure)
|
||||||
|
|
||||||
import Network.IRC.Client
|
import Network.IRC.Client
|
||||||
import Network.IRC.Handlers
|
import Network.IRC.Config
|
||||||
import Network.IRC.Types
|
|
||||||
|
|
||||||
instance Configured a => Configured [a] where
|
|
||||||
convert (List xs) = Just . mapMaybe convert $ xs
|
|
||||||
convert _ = Nothing
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
|
@ -30,26 +20,3 @@ main = do
|
||||||
-- load config and start the bot
|
-- load config and start the bot
|
||||||
let configFile = headEx args
|
let configFile = headEx args
|
||||||
loadBotConfig configFile >>= runBot
|
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
|
|
||||||
|
|
|
@ -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
|
Loading…
Reference in New Issue