Continue refactoring, worked on the core loop and the plugin infrastructure.

6 files changed, 137 insertions, 37 deletions

diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs
index 7ab23f5..1f9329b 100644
--- a/Hsbot/Config.hs
+++ b/Hsbot/Config.hs
@@ -6,10 +6,13 @@ module Hsbot.Config
     , noSSL
     ) where
 
+import Control.Concurrent.Chan
 import Network
+import qualified Network.IRC as IRC
 import Network.TLS
 import Network.TLS.Extra
 
+import Hsbot.Message
 data Config = Config
     { configErrors    :: Maybe String
     , configTLS       :: TLSConfig
@@ -18,7 +21,7 @@ data Config = Config
     , configChannels  :: [String]
     , configNicknames :: [String]
     , configRealname  :: String
-    , configPlugins   :: [String]
+    , configPlugins   :: [(String, Chan Message -> Chan Message -> IO ())]
     }
 
 defaultConfig :: Config
@@ -30,7 +33,7 @@ defaultConfig = Config
     , configChannels  = ["#hsbot"]
     , configNicknames = ["hsbot"]
     , configRealname  = "The One True bot, with it's haskell soul."
-    , configPlugins   = ["Ping", "Core"] }
+    , configPlugins   = [] }
 
 data TLSConfig = TLSConfig
     { sslOn       :: Bool
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index cab05bd..d11f211 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -7,8 +7,10 @@ module Hsbot.Core
 import Control.Concurrent
 import Control.Exception (IOException, catch)
 import Control.Monad.Reader
+import Control.Monad.State
 import qualified Data.ByteString.Char8 as C
 import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
 import Network
 import qualified Network.IRC as IRC
 import Network.BSD (getHostName)
@@ -51,31 +53,43 @@ initHsbot config = do
 
 runHsbot :: Env IO (BotStatus)
 runHsbot = do
-    -- First we say hello
-    env <- ask
-    hostname <- liftIO getHostName
-    let connhdl  = envHandle env
-        tlsCtx   = envTLSCtx env
-        config   = envConfig env
-        nickname = head $ configNicknames config
-        channels = configChannels config
-    liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.nick nickname
-    liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
-    mapM_ (liftIO . sendStrToClient connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
-    -- Next we spawn the reader thread
-    liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
-    myOwnThreadId  <- liftIO $ myThreadId
-    chan <- asks envChan
-    (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar
-    -- Then we spawn all plugins
-    -- asks envSocket  >>= mapM_ ( ----- what's next? the core server handling! ----- )
-    -- Finally we spawn the main bot loop
-    --
-    -- We wait for the quit signal
-    code <- asks envQuitMv >>= liftIO . takeMVar
-    -- and we clean things up
-    asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
-    return code
+    let bot = BotState { botPlugins  = M.empty
+                       , botHooks    = []
+                       , botChannels = []
+                       , botNickname = [] }
+    evalStateT trueRunHsbot bot
+  where
+    trueRunHsbot :: Bot (Env IO) (BotStatus)
+    trueRunHsbot = do
+        -- First we say hello
+        env <- lift ask
+        hostname <- liftIO getHostName
+        let connhdl  = envHandle env
+            tlsCtx   = envTLSCtx env
+            config   = envConfig env
+            nickname = head $ configNicknames config
+            channels = configChannels config
+        liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.nick nickname
+        liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
+        mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
+        -- Next we spawn the reader thread
+        liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
+        myOwnThreadId  <- liftIO $ myThreadId
+        chan <- lift $ asks envChan
+        (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar
+        -- Then we spawn all plugins
+        -- asks envSocket  >>= mapM_ ( ----- what's next? the core server handling! ----- )
+        -- Finally we spawn the main bot loop
+        bot <- get
+        finalStateMVar <- liftIO newEmptyMVar
+        (liftIO . forkIO $ runReaderT (execStateT botLoop bot >>= storeFinalState finalStateMVar) env) >>= lift . addThreadIdToQuitMVar
+        -- We wait for the quit signal
+        code <- asks envQuitMv >>= liftIO . takeMVar
+        -- and we clean things up
+        asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
+        return code
+    storeFinalState :: MVar BotState -> BotState -> Env IO ()
+    storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState
 
 botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
 botReader _ (Just ctx) chan _ = forever $
@@ -90,6 +104,20 @@ botReader handle Nothing chan fatherThreadId = forever $
         killThread myId
         return ""
 
+botLoop :: Bot (Env IO) ()
+botLoop = do
+    chan <- lift $ asks envChan
+    hooks <- gets botHooks
+    msg  <- liftIO $ readChan chan
+    mapM_ (liftIO . flip writeChan msg) hooks
+    case msg of
+        IncomingMsg _ -> return () -- TODO parse for core commands
+        OutgoingMsg outMsg -> do
+            env <- lift ask
+            let connhdl  = envHandle env
+                tlsCtx   = envTLSCtx env
+            liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
+
 handleIncomingStr :: Chan Message -> String -> IO ()
 handleIncomingStr chan str = do
     case IRC.decode str of
diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs
new file mode 100644
index 0000000..5ec35ed
--- /dev/null
+++ b/Hsbot/Message.hs
@@ -0,0 +1,9 @@
+module Hsbot.Message
+    ( Message (..)
+    ) where
+
+import qualified Network.IRC as IRC
+
+data Message = IncomingMsg IRC.Message
+             | OutgoingMsg IRC.Message
+
diff --git a/Hsbot/Plugin/Ping.hs b/Hsbot/Plugin/Ping.hs
new file mode 100644
index 0000000..b020359
--- /dev/null
+++ b/Hsbot/Plugin/Ping.hs
@@ -0,0 +1,38 @@
+module Hsbot.Plugin.Ping
+    ( pingId
+    , ping
+    ) where
+
+import Control.Concurrent.Chan ()
+import Control.Exception
+import Control.Monad.State (execStateT, forever)
+import qualified Network.IRC as IRC
+import Prelude hiding (catch)
+
+import Hsbot.Message
+import Hsbot.Types
+import Hsbot.Utils
+
+pingId :: PluginId
+pingId = PluginId
+    { pluginName = "ping"
+    , pluginEp   = ping }
+
+-- | The plugin's main entry point
+ping :: PluginState -> IO ()
+ping state = do
+    _ <- (execStateT run state) `catch` (\(_ :: AsyncException) -> return state)
+    return ()
+
+-- | The IrcPlugin monad main function
+run :: Plugin IO ()
+run = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    eval :: Message -> Plugin IO ()
+    eval (IncomingMsg msg)
+        | (IRC.msg_command msg) == "PING" = writeMsg . OutgoingMsg . IRC.Message Nothing "PONG" $ IRC.msg_params msg
+        | otherwise = return ()
+    eval _ = return ()
+
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index ff57c49..28ad430 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -5,6 +5,8 @@ module Hsbot.Types
     , BotEnv (..)
     , Env
     , Message (..)
+    , Plugin
+    , PluginId (..)
     , PluginState (..)
     ) where
 
@@ -12,11 +14,11 @@ import Control.Concurrent
 import qualified Data.Map as M
 import Control.Monad.Reader
 import Control.Monad.State
-import qualified Network.IRC as IRC
 import Network.TLS
 import System.IO
 
 import Hsbot.Config
+import Hsbot.Message
 
 -- The bot environment
 type Env = ReaderT BotEnv
@@ -36,19 +38,24 @@ type Bot = StateT BotState
 
 data BotState = BotState
     { botPlugins  :: M.Map String (PluginState, MVar (), ThreadId)
-    , botCommands :: M.Map String [String]
+    , botHooks    :: [Chan Message]
     , botChannels :: [String]
     , botNickname :: String
     }
 
 -- The Plugin monad
+type Plugin = StateT PluginState
+
 data PluginState = PluginState
+    { pluginId     :: PluginId
+    , pluginChan   :: Chan Message
+    , pluginMaster :: Chan Message
+    }
+
+data PluginId = PluginId
     { pluginName :: String
-    , pluginChan :: Chan Message
+    , pluginEp   :: PluginState -> IO ()
     }
 
 data BotStatus = BotContinue | BotExit | BotReload | BotRestart deriving (Show)
 
-data Message = IncomingMsg IRC.Message
-             | OutgoingMsg IRC.Message
-
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 785fb10..6b7f85e 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -4,13 +4,16 @@ module Hsbot.Utils
     , first
     , initTLSEnv
     , readCertificate
+    , readMsg
     , readPrivateKey
-    , sendStrToClient
+    , sendStr
     , setGlobalQuitMVar
+    , writeMsg
     ) where
 
 import Control.Concurrent
 import Control.Monad.Reader
+import Control.Monad.State
 import qualified Crypto.Cipher.RSA as RSA
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C
@@ -23,6 +26,7 @@ import Network.TLS
 import System.IO
 
 import Hsbot.Config
+import Hsbot.Message
 import Hsbot.Types
 
 -- utility functions
@@ -45,9 +49,20 @@ first :: (a, b, c) -> a
 first (a, _, _) = a
 
 -- Helpers
-sendStrToClient :: Handle -> Maybe TLSCtx -> String -> IO ()
-sendStrToClient _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
-sendStrToClient handle Nothing msg = hPutStrLn handle msg
+sendStr :: Handle -> Maybe TLSCtx -> String -> IO ()
+sendStr _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
+sendStr handle Nothing msg = hPutStrLn handle msg
+
+-- Plugin Utils
+readMsg :: Plugin IO (Message)
+readMsg = do
+    chan <- gets pluginChan
+    liftIO $ readChan chan >>= return
+
+writeMsg :: Message -> Plugin IO ()
+writeMsg msg = do
+   chan <- gets pluginMaster
+   liftIO $ writeChan chan msg
 
 -- TLS utils
 initTLSEnv :: TLSConfig -> IO (TLSParams)