From b666e543d0ae03f79ca8b8527c099ca6320f27b0 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 11 Jul 2011 22:35:41 +0200 Subject: Fixed TLS client implementation --- Hsbot/Utils.hs | 59 ++++++---------------------------------------------------- 1 file changed, 6 insertions(+), 53 deletions(-) (limited to 'Hsbot/Utils.hs') diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 6eec5c4..e56e9f7 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -2,23 +2,14 @@ module Hsbot.Utils ( addThreadIdToQuitMVar , delThreadIdFromQuitMVar , initTLSEnv - , readCertificate - , readPrivateKey , sendStr , 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 qualified Data.ByteString.Lazy.UTF8 as L import Data.List -import Data.Maybe import Network.TLS import System.IO @@ -42,52 +33,14 @@ setGlobalQuitMVar status = do -- Helpers sendStr :: Handle -> Maybe TLSCtx -> String -> IO () -sendStr _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg] -sendStr handle Nothing msg = hPutStrLn handle msg +sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n" +sendStr handle Nothing msg = hPutStrLn handle $ msg ++ "\r\n" -- TLS utils initTLSEnv :: TLSConfig -> IO TLSParams initTLSEnv ssl = do - let certFile = sslCert ssl - keyFile = sslKey ssl - versions = sslVersions ssl + let 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 = fromMaybe (error "no valid certificate section") $ parsePEMCert content - 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 + return $ defaultParams { pAllowedVersions = versions + , pCiphers = ciphers } -- cgit v1.2.3 From 1c8cab09cb00abc3e3a0ee2e4a2d7bd6cf703d2f Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 8 Aug 2011 11:39:41 +0200 Subject: Added access controls to hsbot. --- Hsbot/Config.hs | 1 + Hsbot/Core.hs | 1 + Hsbot/Types.hs | 13 ++++++++++++- Hsbot/Utils.hs | 19 +++++++++++++++++-- TODO | 4 +--- 5 files changed, 32 insertions(+), 6 deletions(-) (limited to 'Hsbot/Utils.hs') diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs index 8c85810..6053e9e 100644 --- a/Hsbot/Config.hs +++ b/Hsbot/Config.hs @@ -16,6 +16,7 @@ defaultConfig = Config , configTLS = noSSL , configAddress = "localhost" , configPort = PortNumber 6667 + , configAccess = [] , configChannels = ["#hsbot"] , configNicknames = ["hsbot"] , configRealname = "The One True bot, with it's haskell soul." diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 11c8732..eacbe63 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -76,6 +76,7 @@ runHsbot = do mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels -- Finally we set the new bot state asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty + , botAccess = configAccess config , botHooks = [] , botChannels = channels , botNickname = nickname } diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 7e340e3..8f84482 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -1,5 +1,7 @@ module Hsbot.Types - ( Bot + ( AccessList (..) + , AccessRight (..) + , Bot , BotState (..) , BotStatus (..) , BotEnv (..) @@ -40,6 +42,7 @@ type Bot = StateT BotState data BotState = BotState { botPlugins :: M.Map String (PluginEnv, ThreadId) + , botAccess :: [AccessList] , botHooks :: [Chan Message] , botChannels :: [String] , botNickname :: String @@ -71,12 +74,20 @@ data Config = Config , configTLS :: TLSConfig , configAddress :: String , configPort :: PortID + , configAccess :: [AccessList] , configChannels :: [String] , configNicknames :: [String] , configRealname :: String , configPlugins :: [PluginId] } +data AccessRight = Admin | JoinPart | Kick | Say deriving (Eq, Show) + +data AccessList = AccessList + { accessMask :: IRC.Prefix + , accessList :: [AccessRight] + } deriving (Show) + data TLSConfig = TLSConfig { sslOn :: Bool , sslVersions :: [Network.TLS.Version] diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index e56e9f7..912e746 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -1,6 +1,7 @@ module Hsbot.Utils ( addThreadIdToQuitMVar , delThreadIdFromQuitMVar + , hasAccess , initTLSEnv , sendStr , setGlobalQuitMVar @@ -8,8 +9,10 @@ module Hsbot.Utils import Control.Concurrent import Control.Monad.Reader +import Control.Monad.State import qualified Data.ByteString.Lazy.UTF8 as L -import Data.List +import qualified Data.List as L +import qualified Network.IRC as IRC import Network.TLS import System.IO @@ -24,13 +27,25 @@ addThreadIdToQuitMVar thrId = do delThreadIdFromQuitMVar :: ThreadId -> Env IO () delThreadIdFromQuitMVar thrId = do threadIdsMv <- asks envThreadIdsMv - liftIO $ modifyMVar_ threadIdsMv (return . delete thrId) + liftIO $ modifyMVar_ threadIdsMv (return . L.delete thrId) setGlobalQuitMVar :: BotStatus -> Env IO () setGlobalQuitMVar status = do quitMv <- asks envQuitMv liftIO $ putMVar quitMv status +-- Access rights +hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO (Bool) +hasAccess Nothing _ = return False +hasAccess (Just mask) right = do + botMVar <- asks envBotState + liftIO (readMVar botMVar) >>= evalStateT (gets botAccess >>= return . or . map accessMatch) + where + accessMatch :: AccessList -> Bool + accessMatch (AccessList amask arights) + | mask == amask = or [L.elem Admin arights, L.elem right arights] + | otherwise = False + -- Helpers sendStr :: Handle -> Maybe TLSCtx -> String -> IO () sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n" diff --git a/TODO b/TODO index 89fd863..cb32d7c 100644 --- a/TODO +++ b/TODO @@ -1,8 +1,6 @@ -* add admin rights -* add the hability to manage rights for plugins, as quote editing * better hooks? * add help MVar - +* add regexes support in accessList prefix -- cgit v1.2.3 From 4f50db840967c2409c9bf96c2d6525f99e39cdca Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 8 Aug 2011 13:03:31 +0200 Subject: Fixed bad comments and some cosmetics --- Hsbot/Plugin/Duck.hs | 2 +- Hsbot/Plugin/Ping.hs | 3 ++- Hsbot/Utils.hs | 6 +++--- 3 files changed, 6 insertions(+), 5 deletions(-) (limited to 'Hsbot/Utils.hs') diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs index 946cb0c..b152685 100644 --- a/Hsbot/Plugin/Duck.hs +++ b/Hsbot/Plugin/Duck.hs @@ -51,7 +51,7 @@ $(makeAcidic ''StatDB ['getDuckStats, 'updateScore]) duck :: PluginId duck = PluginId { pluginName = "duck" - , pluginEp = theDuck $ DuckArgs { duckChannel = "", duckFreq = 10 } } + , pluginEp = theDuck DuckArgs { duckChannel = "", duckFreq = 10 } } data DuckArgs = DuckArgs { duckChannel :: String diff --git a/Hsbot/Plugin/Ping.hs b/Hsbot/Plugin/Ping.hs index 6d28ef9..9105630 100644 --- a/Hsbot/Plugin/Ping.hs +++ b/Hsbot/Plugin/Ping.hs @@ -11,12 +11,13 @@ import Prelude hiding (catch) import Hsbot.Message import Hsbot.Types +-- | The ping plugin identity ping :: PluginId ping = PluginId { pluginName = "ping" , pluginEp = thePing } --- | The IrcPlugin monad main function +-- | An IRC plugin that answer PING requests thePing :: Plugin (Env IO) () thePing = forever $ readMsg >>= eval where diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 912e746..2a8f58c 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -35,15 +35,15 @@ setGlobalQuitMVar status = do liftIO $ putMVar quitMv status -- Access rights -hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO (Bool) +hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO Bool hasAccess Nothing _ = return False hasAccess (Just mask) right = do botMVar <- asks envBotState - liftIO (readMVar botMVar) >>= evalStateT (gets botAccess >>= return . or . map accessMatch) + liftIO (readMVar botMVar) >>= evalStateT (fmap (any accessMatch) (gets botAccess)) where accessMatch :: AccessList -> Bool accessMatch (AccessList amask arights) - | mask == amask = or [L.elem Admin arights, L.elem right arights] + | mask == amask = or [Admin `L.elem` arights, right `L.elem` arights] | otherwise = False -- Helpers -- cgit v1.2.3 From 3b914c1b7729f52ba96e51ad43424909acae681c Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 8 Aug 2011 20:56:20 +0200 Subject: Added exception handling, an autorestart when that happens and output in case of restart/reload --- Hsbot.hs | 30 +++++++++++++++++++++++++++--- Hsbot/Core.hs | 35 +++++++++++++++++------------------ Hsbot/Plugin/Admin.hs | 4 ++-- Hsbot/Types.hs | 2 +- Hsbot/Utils.hs | 15 ++++++++++++--- TODO | 11 ++--------- 6 files changed, 61 insertions(+), 36 deletions(-) (limited to 'Hsbot/Utils.hs') diff --git a/Hsbot.hs b/Hsbot.hs index c02b2e5..08456bf 100644 --- a/Hsbot.hs +++ b/Hsbot.hs @@ -5,13 +5,19 @@ module Hsbot import qualified Config.Dyre as Dyre import Config.Dyre.Relaunch import Control.Monad.Reader +import qualified Data.Map as M import System.Log.Logger +import qualified Network.IRC as IRC import Hsbot.Core import Hsbot.Types +import Hsbot.Utils + +data State = State (M.Map String String) deriving (Read, Show) startHsbot :: Config -> IO () startHsbot config = do + (State buffer) <- restoreTextState $ State M.empty -- checking for configuration file compilation error case configErrors config of Nothing -> return () @@ -19,16 +25,34 @@ startHsbot config = do -- initialization infoM "Hsbot" "Bot initializations" hsbotEnv <- initHsbot config + -- Handle previous exit state if it exists + die_msgs <- case M.lookup "die_msg" buffer of + Just dieMsg -> case reads dieMsg :: [(BotStatus, String)] of + (status, _):_ -> case status of + BotReload reason -> return ["hsbot reloaded, reason : " ++ reason] + BotRestart (reason, Just info) -> return ["hsbot restarted, readon : " ++ reason, "additional information: " ++ info] + BotRestart (reason, Nothing) -> return ["hsbot restarted, readon : " ++ reason] + BotExit -> return [] + _ -> return ["hsbot die_msg parsing error, this should not happen"] + Nothing -> return [] + let connhdl = envHandle hsbotEnv + tlsCtx = envTLSCtx hsbotEnv + channels = configChannels config + mapM_ (infoM "Hsbot") die_msgs + mapM_ (\msg -> mapM_ (\channel -> sendStr hsbotEnv connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs -- main stuff infoM "Hsbot" "Bot core starting" status <- runReaderT runHsbot hsbotEnv infoM "Hsbot" $ "Bot core exited with status " ++ show status -- Handling exit signal case status of - BotContinue -> startHsbot config -- TODO do something not so dumb about starting over BotExit -> runReaderT terminateHsbot hsbotEnv - BotReload -> relaunchMaster Nothing -- TODO relaunchWithTextState (state { stateConfig = config }) Nothing, add a flag that prevent spawning the sockets again - BotRestart -> relaunchMaster Nothing -- TODO relaunch and kill sockets + BotReload reason -> do + runReaderT terminateHsbot hsbotEnv + relaunchWithTextState (M.singleton "die_msg" . show $ BotReload reason) Nothing -- TODO find a way to properly implement that, then insert necessary information in this MVar + BotRestart reason -> do + runReaderT terminateHsbot hsbotEnv + relaunchWithTextState (M.singleton "die_msg" . show $ BotRestart reason) Nothing hsbot :: Config -> IO () hsbot = Dyre.wrapMain $ Dyre.defaultParams diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index eacbe63..49f5f5d 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -70,10 +70,10 @@ runHsbot = do 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) + liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.nick nickname + liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config) -- Then we join channels - mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels + mapM_ (liftIO . sendStr env connhdl tlsCtx . IRC.encode . IRC.joinChan) channels -- Finally we set the new bot state asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty , botAccess = configAccess config @@ -88,9 +88,8 @@ runHsbot = do liftIO $ debugM "Hsbot.Core" "Spawning reader thread" let connhdl = envHandle env tlsCtx = envTLSCtx env - myOwnThreadId <- liftIO myThreadId chan <- asks envChan - (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar + (liftIO . forkIO $ botReader env connhdl tlsCtx chan) >>= addThreadIdToQuitMVar -- Then we spawn all plugins asks envConfig >>= mapM_ loadPlugin . configPlugins -- Finally we spawn the main bot loop @@ -102,18 +101,18 @@ runHsbot = do -- TODO : kill plugin threads return code -botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO () -botReader _ (Just ctx) chan _ = forever $ - fmap L.toString (recvData ctx) >>= handleIncomingStr chan -- 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 "" +botReader :: BotEnv -> Handle -> Maybe TLSCtx -> Chan Message -> IO () +botReader env _ (Just ctx) chan = forever $ + fmap L.toString (recvData ctx) `catch` handleIOException env "botReader died" >>= handleIncomingStr chan +botReader env handle Nothing chan = forever $ + hGetLine handle `catch` handleIOException env "botReader died" >>= handleIncomingStr chan + +handleIOException :: BotEnv -> String -> IOException -> IO String +handleIOException env msg ioException = do + runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env + myId <- myThreadId + killThread myId + return "" handleIncomingStr :: Chan Message -> String -> IO () handleIncomingStr chan str = @@ -136,7 +135,7 @@ botLoop = forever $ do let connhdl = envHandle env tlsCtx = envTLSCtx env liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg - liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg + liftIO . sendStr env connhdl tlsCtx $ IRC.encode outMsg terminateHsbot :: Env IO () terminateHsbot = do diff --git a/Hsbot/Plugin/Admin.hs b/Hsbot/Plugin/Admin.hs index 7dba362..cbec152 100644 --- a/Hsbot/Plugin/Admin.hs +++ b/Hsbot/Plugin/Admin.hs @@ -33,11 +33,11 @@ theAdmin = forever $ readMsg >>= eval else answerMsg msg "Only admins can do that." "restart":"help":_ -> answerMsg msg "restart hsbot, reset the running state to config file directives." "restart":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right - then lift $ setGlobalQuitMVar BotRestart + then lift . setGlobalQuitMVar $ BotRestart (getSender msg ++ " request", Nothing) else answerMsg msg "Only admins can do that." "reload":"help":_ -> answerMsg msg "reload hsbot, and try merge the new config file directives with actual running state)." "reload":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right - then lift $ setGlobalQuitMVar BotReload + then lift . setGlobalQuitMVar . BotReload $ getSender msg ++ " request" else answerMsg msg "Only admins can do that." _ -> return () | otherwise = return () diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 8f84482..7ca9ee0 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -66,7 +66,7 @@ data PluginId = PluginId data Message = IncomingMsg IRC.Message | OutgoingMsg IRC.Message -data BotStatus = BotContinue | BotExit | BotReload | BotRestart deriving (Show) +data BotStatus = BotExit | BotReload String | BotRestart (String, Maybe String) deriving (Read, Show) -- Config data Config = Config diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 2a8f58c..043037d 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -8,12 +8,14 @@ module Hsbot.Utils ) where import Control.Concurrent +import Control.Exception (IOException, catch) import Control.Monad.Reader import Control.Monad.State import qualified Data.ByteString.Lazy.UTF8 as L import qualified Data.List as L import qualified Network.IRC as IRC import Network.TLS +import Prelude hiding (catch) import System.IO import Hsbot.Types @@ -47,9 +49,16 @@ hasAccess (Just mask) right = do | otherwise = False -- Helpers -sendStr :: Handle -> Maybe TLSCtx -> String -> IO () -sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n" -sendStr handle Nothing msg = hPutStrLn handle $ msg ++ "\r\n" +sendStr :: BotEnv -> Handle -> Maybe TLSCtx -> String -> IO () +sendStr env _ (Just ctx) msg = sendData ctx (L.fromString $ msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg) +sendStr env handle Nothing msg = hPutStrLn handle (msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg) + +handleIOException :: BotEnv -> String -> IOException -> IO () +handleIOException env msg ioException = do + runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env + myId <- myThreadId + killThread myId + return () -- TLS utils initTLSEnv :: TLSConfig -> IO TLSParams diff --git a/TODO b/TODO index cb32d7c..92d1f3e 100644 --- a/TODO +++ b/TODO @@ -1,7 +1,7 @@ * better hooks? * add help MVar * add regexes support in accessList prefix - +* exception handling on channel and MVar operations? @@ -9,7 +9,6 @@ :julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif -* Improve configuration file errors display * fork process in background * add a function to answer by /msg to somebody @@ -18,16 +17,10 @@ * detect too identical quoting in a raw, or implement quote abort * find a better way to track who voted for what? - need authentication against the bot -* write the help module -* clean the plugin module -* clean cleaning for the quote module * write a channel tracking plugin. Write the part chan command -* add a plugin for admin checks and tracking +* add a plugin for admin rights checking and user tracking * add a plugin for timer functionnalities other plugin could subscribe to (the troll plugin). -* add a "I have stuff to save so don't kill me too hard" status for plugins - -* Make the bot auto-reconnect (/!\ admin plugin!) * Find a way to prevent the socket from being garbage collected, by writing a connection handler for example * Find a way so that not a single message/information would be lost in the case of a reboot -- cgit v1.2.3 From d933088dcb7d9b7ed05e0fbeb478472e0dae5a7a Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 8 Aug 2011 21:11:01 +0200 Subject: cosmetic --- Hsbot/Utils.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'Hsbot/Utils.hs') diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 043037d..2ea1a49 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -40,8 +40,7 @@ setGlobalQuitMVar status = do hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO Bool hasAccess Nothing _ = return False hasAccess (Just mask) right = do - botMVar <- asks envBotState - liftIO (readMVar botMVar) >>= evalStateT (fmap (any accessMatch) (gets botAccess)) + asks envBotState >>= liftIO . readMVar >>= evalStateT (fmap (any accessMatch) (gets botAccess)) where accessMatch :: AccessList -> Bool accessMatch (AccessList amask arights) -- cgit v1.2.3