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

More refactoring to simplify dependencies between modules

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-06-02 00:26:41 +05:30
parent 924e023e27
commit 5b28bdbe3e
14 changed files with 117 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
hask-irc-core/Network/IRC/Client.hs
View File

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

16
hask-irc-handlers/Network/IRC/Handlers/Core.hs → hask-irc-core/Network/IRC/Handlers/Core.hs
View File

@ -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 <command>"
mkMsgHandler _ _ _ = return Nothing
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do

12
hask-irc-core/Network/IRC/Types.hs
View File

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

4
hask-irc-core/hask-irc-core.cabal
View File

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

2
hask-irc-handlers/Network/IRC/Handlers.hs
View File

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

18
hask-irc-handlers/Network/IRC/Handlers/Auth.hs
View File

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

8
hask-irc-handlers/Network/IRC/Handlers/Greet.hs
View File

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

14
hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
View File

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

24
hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs
View File

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

10
hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs
View File

@ -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 <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 }
deriving (Show, Eq)

18
hask-irc-handlers/Network/IRC/Handlers/Tell.hs
View File

@ -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 <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
mkMsgHandler _ _ _ = return Nothing

1
hask-irc-handlers/hask-irc-handlers.cabal
View File

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

35
hask-irc-runner/Main.hs
View File

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

38
hask-irc-runner/Network/IRC/Config.hs Normal file
View File

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