Moved files around as a preliminary for architectural changes.

1 files changed, 177 insertions, 0 deletions

diff --git a/HsbotIrcBot/Hsbot/Irc/Core.hs b/HsbotIrcBot/Hsbot/Irc/Core.hs
new file mode 100644
index 0000000..d65e975
--- /dev/null
+++ b/HsbotIrcBot/Hsbot/Irc/Core.hs
@@ -0,0 +1,177 @@
+module Hsbot.Irc.Core
+    ( startIrcbot
+    ) where
+
+import Control.Concurrent
+import Control.Exception (AsyncException, Handler (..), IOException, catch, catches)
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Network
+import Prelude hiding (catch)
+import System.IO
+import System.Posix.IO (fdToHandle, handleToFd)
+import System.Posix.Types (Fd)
+
+import Hsbot.Irc.Command
+import Hsbot.Irc.Config
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin
+import Hsbot.Irc.Server
+import Hsbot.Irc.Types
+import Hsbot.Types
+
+-- | IrcBot's main entry point
+startIrcbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> Maybe String -> IO ()
+startIrcbot config masterChan myChan txtResumeData = do
+    let resumeData = case txtResumeData of
+            Just txtData -> read txtData :: ResumeData  -- TODO : catch exception
+            Nothing -> M.empty :: ResumeData
+    print resumeData
+    putStrLn "[IrcBot] Opening communication channel... "
+    chan <- newChan :: IO (Chan IrcBotMsg)
+    handle <- case M.lookup "HANDLE" resumeData of
+        Just txtFd -> do
+            let fd = read txtFd :: Fd
+            fdToHandle fd
+        Nothing -> do
+            putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
+            handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
+            hSetBuffering handle NoBuffering
+            hSetEncoding handle utf8
+            return handle
+    fd <- handleToFd handle
+    putStrLn "[IrcBot] Spawning reader threads..."
+    myOwnThreadId  <- myThreadId
+    readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
+    masterReaderThreadId <- forkIO $ ircBotMasterReader myChan chan
+    putStrLn "[IrcBot] Initializing server connection..."
+    let ircServerState = IrcServerState { ircServerId            = ircConfigAddress config
+                                        , ircServerChannels      = []
+                                        , ircServerNickname      = ircConfigNickname config
+                                        , ircServerCommandPrefix = ircConfigCommandPrefix config
+                                        , ircServerChan          = chan }
+        ircBotState = IrcBotState { ircBotPlugins              = M.empty
+                                  , ircBotCommands             = M.empty
+                                  , ircBotChan                 = chan
+                                  , ircBotMasterChan           = masterChan
+                                  , ircBotServerState          = ircServerState
+                                  , ircBotHandle               = handle
+                                  , ircBotConfig               = config
+                                  , ircBotResumeData           = M.singleton "HANDLE" (show fd) }
+    ircBotState' <- execStateT (initBotServerConnection config) ircBotState
+    putStrLn "[IrcBot] Spawning plugins..."
+    ircBotState'' <- execStateT spawnIrcPlugins ircBotState'
+    putStrLn "[IrcBot] Entering Core loop... "
+    ircBotState''' <- (execStateT ircBotLoop ircBotState'') `catches` [ Handler (\ (_ :: IOException) -> return (ircBotState''))
+                                                                      , Handler (\ (_ :: AsyncException) -> return (ircBotState'')) ]
+    putStrLn "[IrcBot] Killing reader threads..."
+    killThread readerThreadId
+    killThread masterReaderThreadId
+    putStrLn "[IrcBot] Killing active plugins... "
+    let resumeData' = ircBotResumeData ircBotState'''
+        ircPlugins = read (fromMaybe [] (M.lookup "PLUGINS" resumeData')) :: [String]
+    evalStateT (mapM_ killIrcPlugin ircPlugins) ircBotState'''
+    return ()
+
+--resumeIrcBot
+--resumeIrcBot
+
+-- | Runs the IrcBot's reader loop
+ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
+ircBotReader handle chan fatherThreadId = forever $ do
+    str <- (hGetLine handle) `catch` handleIOException
+    let msg = parseIrcMsg str
+    case msg of
+        Right msg' -> writeChan chan (InIrcMsg msg')
+        _          -> return ()
+  where
+    handleIOException :: IOException -> IO (String)
+    handleIOException ioException = do
+        throwTo fatherThreadId ioException
+        myId <- myThreadId
+        killThread myId
+        return ""
+
+-- | Reads the Master's chan
+ircBotMasterReader :: Chan BotMsg -> Chan IrcBotMsg -> IO ()
+ircBotMasterReader masterChan _ = forever $ do
+    _ <- readChan masterChan
+    return ()
+    -- TODO : handle botMsg
+
+-- | Initialize the bot's server connection
+initBotServerConnection :: IrcConfig -> IrcBot ()
+initBotServerConnection config = do
+    ircBot <- get
+    let ircServerState = ircBotServerState ircBot
+    ircServerState' <- execStateT (initServerConnection config) ircServerState
+    put $ ircBot { ircBotServerState = ircServerState' }
+
+-- | Run the IrcBot's main loop
+ircBotLoop :: IrcBot ()
+ircBotLoop = forever $ do
+    chan <- gets ircBotChan
+    msg  <- liftIO $ readChan chan
+    case msg of
+        InIrcMsg inIrcMsg   -> dispatchMessage $ InIrcMsg inIrcMsg
+        OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
+        IntIrcCmd intIrcCmd -> do
+            reboot <- processInternalCommand $ IntIrcCmd intIrcCmd
+            reportUpdate
+            if reboot == BotReboot
+              then processRebootCommand
+              else return ()
+  where
+    sendThisMessage :: IrcMsg -> IrcBot ()
+    sendThisMessage outputMsg = do
+        let str = serializeIrcMsg outputMsg
+        handle <- gets ircBotHandle
+        liftIO $ hPutStr handle (str ++ "\r\n")
+
+-- | Dispatches an input message
+dispatchMessage :: IrcBotMsg -> IrcBot ()
+dispatchMessage (InIrcMsg inIrcMsg) = do
+    config  <- gets ircBotConfig
+    plugins <- gets ircBotPlugins
+    cmds    <- gets ircBotCommands
+    if (isPluginCommand config)
+      then
+        let key         = tail . head $ words getMsgContent
+            pluginNames = fromMaybe [] $ M.lookup key cmds
+            plugins'    = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
+        in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins'
+      else
+        mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins)
+  where
+    isPluginCommand :: IrcConfig -> Bool
+    isPluginCommand config =
+        and [ ircMsgCommand inIrcMsg == "PRIVMSG"
+        , (head getMsgContent) == ircConfigCommandPrefix config ]
+    sendRunCommand :: String -> IrcPluginState -> IrcBot ()
+    sendRunCommand cmd plugin =  sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
+    getMsgContent :: String
+    getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
+dispatchMessage _ = return ()
+
+-- | Reports an update to the master bot
+reportUpdate :: IrcBot ()
+reportUpdate = do
+    ircbot <- get
+    let masterChan = ircBotMasterChan ircbot
+        msg = UpdMsg $ ResMsg { resMsgFrom = ircConfigName $ ircBotConfig ircbot
+                              , resMsgData = ircBotResumeData ircbot }
+    liftIO $ writeChan masterChan msg
+
+-- | Process a reboot command
+processRebootCommand :: IrcBot ()
+processRebootCommand = do
+    ircbot <- get
+    let masterChan = ircBotMasterChan ircbot
+        msg = IntMsg $ Msg { msgType  = "REBOOT"
+                           , msgFrom  = ircConfigName $ ircBotConfig ircbot
+                           , msgTo    = "CORE"
+                           , msgStuff = show $ ircBotResumeData ircbot
+                           }
+    liftIO $ writeChan masterChan msg
+