Began a big refactoring/rewriting (again)

4 files changed, 321 insertions, 0 deletions

diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs
new file mode 100644
index 0000000..7ab23f5
--- /dev/null
+++ b/Hsbot/Config.hs
@@ -0,0 +1,63 @@
+module Hsbot.Config
+    ( Config (..)
+    , TLSConfig (..)
+    , defaultConfig
+    , defaultTLSConfig
+    , noSSL
+    ) where
+
+import Network
+import Network.TLS
+import Network.TLS.Extra
+
+data Config = Config
+    { configErrors    :: Maybe String
+    , configTLS       :: TLSConfig
+    , configAddress   :: String
+    , configPort      :: PortID
+    , configChannels  :: [String]
+    , configNicknames :: [String]
+    , configRealname  :: String
+    , configPlugins   :: [String]
+    }
+
+defaultConfig :: Config
+defaultConfig = Config
+    { configErrors    = Nothing
+    , configTLS       = noSSL
+    , configAddress   = "localhost"
+    , configPort      = PortNumber 6667
+    , configChannels  = ["#hsbot"]
+    , configNicknames = ["hsbot"]
+    , configRealname  = "The One True bot, with it's haskell soul."
+    , configPlugins   = ["Ping", "Core"] }
+
+data TLSConfig = TLSConfig
+    { sslOn       :: Bool
+    , sslCert     :: String
+    , sslKey      :: String
+    , sslVersions :: [Network.TLS.Version]
+    , sslCiphers  :: [Network.TLS.Cipher]
+    , sslVerify   :: Bool
+    } deriving (Show)
+
+defaultTLSConfig :: TLSConfig
+defaultTLSConfig = TLSConfig
+    { sslOn       = True
+    , sslCert     = ""
+    , sslKey      = ""
+    , sslVersions = [SSL3, TLS10, TLS11, TLS12]
+    , sslCiphers  = [ cipher_null_MD5
+                    , cipher_null_SHA1
+                    , cipher_AES128_SHA1
+                    , cipher_AES256_SHA1
+                    , cipher_RC4_128_MD5
+                    , cipher_RC4_128_SHA1
+                    , cipher_AES256_SHA1
+                    , cipher_AES128_SHA256
+                    , cipher_AES256_SHA256 ]
+    , sslVerify   = True }
+
+noSSL :: TLSConfig
+noSSL = defaultTLSConfig { sslOn = False }
+
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
+
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
new file mode 100644
index 0000000..ff57c49
--- /dev/null
+++ b/Hsbot/Types.hs
@@ -0,0 +1,54 @@
+module Hsbot.Types
+    ( Bot
+    , BotState (..)
+    , BotStatus (..)
+    , BotEnv (..)
+    , Env
+    , Message (..)
+    , PluginState (..)
+    ) where
+
+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
+
+-- The bot environment
+type Env = ReaderT BotEnv
+
+data BotEnv = BotEnv
+    { envHandle      :: Handle
+    , envChan        :: Chan Message
+    , envQuitMv      :: MVar (BotStatus)
+    , envThreadIdsMv :: MVar [ThreadId]
+    , envConfig      :: Config
+    , envTLS         :: Maybe TLSParams
+    , envTLSCtx      :: Maybe TLSCtx
+    }
+
+-- The bot monad
+type Bot = StateT BotState
+
+data BotState = BotState
+    { botPlugins  :: M.Map String (PluginState, MVar (), ThreadId)
+    , botCommands :: M.Map String [String]
+    , botChannels :: [String]
+    , botNickname :: String
+    }
+
+-- The Plugin monad
+data PluginState = PluginState
+    { pluginName :: String
+    , pluginChan :: Chan Message
+    }
+
+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
new file mode 100644
index 0000000..785fb10
--- /dev/null
+++ b/Hsbot/Utils.hs
@@ -0,0 +1,99 @@
+module Hsbot.Utils
+    ( addThreadIdToQuitMVar
+    , delThreadIdFromQuitMVar
+    , first
+    , initTLSEnv
+    , readCertificate
+    , readPrivateKey
+    , sendStrToClient
+    , setGlobalQuitMVar
+    ) where
+
+import Control.Concurrent
+import Control.Monad.Reader
+import qualified Crypto.Cipher.RSA as RSA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Certificate.KeyRSA as KeyRSA
+import Data.Certificate.PEM
+import Data.Certificate.X509
+import Data.List
+import Network.TLS
+import System.IO
+
+import Hsbot.Config
+import Hsbot.Types
+
+-- utility functions
+addThreadIdToQuitMVar :: ThreadId -> Env IO ()
+addThreadIdToQuitMVar thrId = do
+    threadIdsMv <- asks envThreadIdsMv
+    liftIO $ modifyMVar_ threadIdsMv (\l -> return $ thrId:l)
+
+delThreadIdFromQuitMVar :: ThreadId -> Env IO ()
+delThreadIdFromQuitMVar thrId = do
+    threadIdsMv <- asks envThreadIdsMv
+    liftIO $ modifyMVar_ threadIdsMv (\l -> return $ delete thrId l)
+
+setGlobalQuitMVar :: BotStatus -> Env IO ()
+setGlobalQuitMVar status = do
+    quitMv <- asks envQuitMv
+    liftIO $ putMVar quitMv status
+
+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
+
+-- TLS utils
+initTLSEnv :: TLSConfig -> IO (TLSParams)
+initTLSEnv ssl = do
+    let certFile = sslCert ssl
+        keyFile  = sslKey ssl
+        versions = sslVersions ssl
+        ciphers  = sslCiphers ssl
+        verify   = sslVerify ssl
+    -- TODO : exception on loading keys
+    cert <- readCertificate certFile
+    pk   <- readPrivateKey keyFile
+    return $ defaultParams { pConnectVersion = TLS12
+                           , pAllowedVersions = versions
+                           , pCiphers = ciphers
+                           , pWantClientCert = verify
+                           , pCertificates = [(cert, Just pk)] }
+
+readCertificate :: FilePath -> IO X509
+readCertificate filepath = do
+    content <- B.readFile filepath
+    let certdata = case parsePEMCert content of
+            Nothing -> error ("no valid certificate section")
+            Just x  -> x
+    let cert = case decodeCertificate $ L.fromChunks [certdata] of
+            Left err -> error ("cannot decode certificate: " ++ err)
+            Right x  -> x
+    return cert
+
+readPrivateKey :: FilePath -> IO PrivateKey
+readPrivateKey filepath = do
+    content <- B.readFile filepath
+    let pkdata = case parsePEMKeyRSA content of
+            Nothing -> error ("no valid RSA key section")
+            Just x  -> L.fromChunks [x]
+    let pk = case KeyRSA.decodePrivate pkdata of
+            Left err -> error ("cannot decode key: " ++ err)
+            Right x  -> PrivRSA $ RSA.PrivateKey
+                { RSA.private_sz   = fromIntegral $ KeyRSA.lenmodulus x
+                , RSA.private_n    = KeyRSA.modulus x
+                , RSA.private_d    = KeyRSA.private_exponant x
+                , RSA.private_p    = KeyRSA.p1 x
+                , RSA.private_q    = KeyRSA.p2 x
+                , RSA.private_dP   = KeyRSA.exp1 x
+                , RSA.private_dQ   = KeyRSA.exp2 x
+                , RSA.private_qinv = KeyRSA.coef x
+                }
+    return pk
+