From ff07633fb8f81577ffec409cbf0a3c7361990f6c Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Wed, 13 Apr 2011 20:15:55 +0200
Subject: Began a big refactoring/rewriting (again)

---
 Hsbot/Core.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 105 insertions(+)
 create mode 100644 Hsbot/Core.hs

(limited to 'Hsbot/Core.hs')

diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
new file mode 100644
index 0000000..cab05bd
--- /dev/null
+++ b/Hsbot/Core.hs
@@ -0,0 +1,105 @@
+module Hsbot.Core
+    ( initHsbot
+    , runHsbot
+    , terminateHsbot
+    ) where
+
+import Control.Concurrent
+import Control.Exception (IOException, catch)
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+import Network
+import qualified Network.IRC as IRC
+import Network.BSD (getHostName)
+import Network.TLS
+import Prelude hiding (catch)
+import System.IO
+import System.Log.Logger
+
+import Hsbot.Config
+import Hsbot.Types
+import Hsbot.Utils
+
+initHsbot :: Config -> IO (BotEnv)
+initHsbot config = do
+    chan <- newChan :: IO (Chan Message)
+    threadIdsMv <- newMVar []
+    quitMv <- newEmptyMVar
+    let hostname = configAddress config
+        port = configPort config
+    infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port
+    connhdl <- connectTo hostname port
+    hSetBuffering connhdl LineBuffering
+    hSetEncoding connhdl utf8
+    (tls, tlsCtx) <- case sslOn $ configTLS config of
+        True  -> do
+            infoM "Hsbot.Core" "TLS init"
+            tlsenv <- initTLSEnv (configTLS config)
+            randomGen <- makeSRandomGen >>= either (fail . show) (return . id)
+            sCtx <- client tlsenv randomGen connhdl
+            handshake sCtx
+            return (Just tlsenv, Just sCtx)
+        False -> return (Nothing, Nothing)
+    return BotEnv { envHandle      = connhdl
+                  , envChan        = chan
+                  , envQuitMv      = quitMv
+                  , envThreadIdsMv = threadIdsMv
+                  , envConfig      = config
+                  , envTLS         = tls
+                  , envTLSCtx      = tlsCtx }
+
+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
+
+botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
+botReader _ (Just ctx) chan _ = forever $
+    recvData ctx >>= return . L.toChunks >>= mapM_ (handleIncomingStr chan . C.unpack)  -- TODO exceptions
+botReader handle Nothing chan fatherThreadId = forever $
+    (hGetLine handle) `catch` handleIOException >>= handleIncomingStr chan
+  where
+    handleIOException :: IOException -> IO (String)
+    handleIOException ioException = do
+        throwTo fatherThreadId ioException
+        myId <- myThreadId
+        killThread myId
+        return ""
+
+handleIncomingStr :: Chan Message -> String -> IO ()
+handleIncomingStr chan str = do
+    case IRC.decode str of
+        Just msg -> do
+            debugM "Ircd.Reader" $ "<-- " ++ (show msg)
+            writeChan chan $ IncomingMsg msg
+        Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str     -- TODO: spam control
+
+terminateHsbot :: Env IO ()
+terminateHsbot = do
+    liftIO $ infoM "Hsbot.Core" "Closing connection"
+    asks envHandle >>= liftIO . hClose
+
-- 
cgit v1.2.3