More refactoring to simplify dependencies between modules

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

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

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

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
 

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

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

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 = 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 Message { msgDetails = ChannelMsg { .. }, .. } =

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
+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 { .. } = do

hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs

@@ -187,19 +187,21 @@ stopNickTracker state = io $ do
   createCheckpointAndClose acid
 
 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
     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

hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs

@@ -21,12 +21,14 @@ import Network.IRC.Types
 $(deriveLoggers "HSL" [HSL.ERROR])
 
 mkMsgHandler :: MsgHandlerMaker
-mkMsgHandler _ _ "songsearch" =
+mkMsgHandler = MsgHandlerMaker "songsearch" go
-  return . Just $ newMsgHandler { onMessage = songSearch,
-                                  onHelp    = return $ singletonMap "!m" helpMsg }
   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)

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

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,

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.Config
-import Network.IRC.Types
-
-instance Configured a => Configured [a] where
-  convert (List xs) = Just . mapMaybe convert $ xs
-  convert _ = Nothing
 
 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

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