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/Config.hs | 63 ++++++++++++++++++++++++++++++++++ Hsbot/Core.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Hsbot/Types.hs | 54 +++++++++++++++++++++++++++++ Hsbot/Utils.hs | 99 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 321 insertions(+) create mode 100644 Hsbot/Config.hs create mode 100644 Hsbot/Core.hs create mode 100644 Hsbot/Types.hs create mode 100644 Hsbot/Utils.hs (limited to 'Hsbot') 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 + -- cgit v1.2.3