diff options
Diffstat (limited to '')
| -rw-r--r-- | Hsbot.hs | 26 | ||||
| -rw-r--r-- | Hsbot/Config.hs | 7 | ||||
| -rw-r--r-- | Hsbot/Core.hs | 58 | ||||
| -rw-r--r-- | Hsbot/Message.hs | 15 | ||||
| -rw-r--r-- | Hsbot/Plugin/Admin.hs | 45 | ||||
| -rw-r--r-- | Hsbot/Plugin/Duck.hs | 84 | ||||
| -rw-r--r-- | Hsbot/Plugin/Ping.hs | 3 | ||||
| -rw-r--r-- | Hsbot/Types.hs | 17 | ||||
| -rw-r--r-- | Hsbot/Utils.hs | 88 | ||||
| -rw-r--r-- | TODO | 25 | ||||
| -rw-r--r-- | hsbot.cabal | 4 |
11 files changed, 203 insertions, 169 deletions
@@ -5,30 +5,48 @@ 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 Hsbot.Core import Hsbot.Types +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 () Just em -> putStrLn $ "Error: " ++ em + -- Handle previous exit state if it exists + dieMsgs <- 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, reason : " ++ reason, "additional information: " ++ info] + BotRestart (reason, Nothing) -> return ["hsbot restarted, reason : " ++ reason] + BotExit -> return [] + _ -> return ["hsbot die_msg parsing error, this should not happen"] + Nothing -> return [] + mapM_ (infoM "Hsbot") dieMsgs -- initialization infoM "Hsbot" "Bot initializations" hsbotEnv <- initHsbot config -- main stuff infoM "Hsbot" "Bot core starting" - status <- runReaderT runHsbot hsbotEnv + status <- runReaderT (runHsbot dieMsgs) 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 (State $ 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 (State $ M.singleton "die_msg" . show $ BotRestart reason) Nothing hsbot :: Config -> IO () hsbot = Dyre.wrapMain $ Dyre.defaultParams diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs index d51387b..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." @@ -24,12 +25,8 @@ defaultConfig = Config defaultTLSConfig :: TLSConfig defaultTLSConfig = TLSConfig { sslOn = True - , sslCert = "" - , sslKey = "" , sslVersions = [SSL3, TLS10, TLS11, TLS12] - , sslCiphers = [ cipher_null_MD5 - , cipher_null_SHA1 - , cipher_AES128_SHA1 + , sslCiphers = [ cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 9c72771..4dc1e92 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -8,8 +8,7 @@ import Control.Concurrent import Control.Exception (IOException, catch) import Control.Monad.Reader import Crypto.Random -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.UTF8 as L import qualified Data.Map as M import Network import qualified Network.IRC as IRC @@ -33,15 +32,16 @@ initHsbot config = do port = configPort config infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port connhdl <- connectTo hostname port - hSetBuffering connhdl LineBuffering + hSetBuffering connhdl NoBuffering hSetEncoding connhdl utf8 (tls, tlsCtx) <- if sslOn $ configTLS config then (do - infoM "Hsbot.Core" "TLS init" + infoM "Hsbot.Core" "Initializing TLS communication" tlsenv <- initTLSEnv (configTLS config) randomGen <- newGenIO :: IO SystemRandom sCtx <- client tlsenv randomGen connhdl - handshake sCtx + success <- handshake sCtx + unless success $ errorM "Hsbot.Core" "TLS handshake failed" -- TODO: do some usefull error handling return (Just tlsenv, Just sCtx)) else return (Nothing, Nothing) return BotEnv { envBotState = botState @@ -53,8 +53,8 @@ initHsbot config = do , envTLS = tls , envTLSCtx = tlsCtx } -runHsbot :: Env IO BotStatus -runHsbot = do +runHsbot :: [String] -> Env IO BotStatus +runHsbot die_msgs = do botNotInitialized <- asks envBotState >>= liftIO . isEmptyMVar when botNotInitialized runFirstSteps trueRunHsbot @@ -70,12 +70,15 @@ 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 + -- We advertise any death message we should + mapM_ (\msg -> mapM_ (\channel -> liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs -- Finally we set the new bot state asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty + , botAccess = configAccess config , botHooks = [] , botChannels = channels , botNickname = nickname } @@ -87,9 +90,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 @@ -101,26 +103,26 @@ runHsbot = do -- TODO : kill plugin threads return code -botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO () -botReader _ (Just ctx) chan _ = forever $ - fmap L.toChunks (recvData ctx) >>= 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 "" +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 = case IRC.decode str of Just msg -> do - debugM "Ircd.Reader" $ "<-- " ++ show msg + debugM "Hsbot.Reader" $ "<-- " ++ show msg writeChan chan $ IncomingMsg msg - Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control + Nothing -> return () botLoop :: Env IO () botLoop = forever $ do @@ -134,8 +136,8 @@ botLoop = forever $ do env <- ask let connhdl = envHandle env tlsCtx = envTLSCtx env - liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg - liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg + liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg + liftIO . sendStr env connhdl tlsCtx $ IRC.encode outMsg terminateHsbot :: Env IO () terminateHsbot = do diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index 14488a1..a34659d 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -30,12 +30,15 @@ answerMsg _ _ = return () -- | Get the command in the IRC message if there is one getCommand :: IRC.Message -> Env IO [String] -getCommand (IRC.Message _ _ (_:msg:[])) = do - currentBotState <- asks envBotState >>= liftIO . readMVar - let cmd:stuff = if msg /= "" then words msg else ["",""] - if botNickname currentBotState `L.isPrefixOf` cmd - then return stuff - else return [] +getCommand (IRC.Message _ _ (_:msg:[])) = getCommandFrom $ words msg + where + getCommandFrom :: [String] -> Env IO [String] + getCommandFrom (cmd:stuff) = do + currentBotState <- asks envBotState >>= liftIO . readMVar + if botNickname currentBotState `L.isPrefixOf` cmd + then return stuff + else return [] + getCommandFrom _ = return [] getCommand _ = return [] getSender :: IRC.Message -> String diff --git a/Hsbot/Plugin/Admin.hs b/Hsbot/Plugin/Admin.hs new file mode 100644 index 0000000..cbec152 --- /dev/null +++ b/Hsbot/Plugin/Admin.hs @@ -0,0 +1,45 @@ +module Hsbot.Plugin.Admin + ( admin + , theAdmin + ) where + +import Control.Concurrent.Chan () +import Control.Monad.Reader +import qualified Network.IRC as IRC +import Prelude hiding (catch) + +import Hsbot.Message +import Hsbot.Types +import Hsbot.Utils + +-- | The Admin plugin identity +admin :: PluginId +admin = PluginId + { pluginName = "admin" + , pluginEp = theAdmin } + +-- | An IRC plugin for manage hsbot +theAdmin :: Plugin (Env IO) () +theAdmin = forever $ readMsg >>= eval + where + eval :: Message -> Plugin (Env IO) () + eval (IncomingMsg msg) + | IRC.msg_command msg == "PRIVMSG" = do + cmdArgs <- lift $ getCommand msg + case cmdArgs of + "exit":"help":_ -> answerMsg msg "exit hsbot." + "exit":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right + then lift $ setGlobalQuitMVar BotExit + 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 (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 $ getSender msg ++ " request" + else answerMsg msg "Only admins can do that." + _ -> return () + | otherwise = return () + eval _ = return () + diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs index 187c62d..1044591 100644 --- a/Hsbot/Plugin/Duck.hs +++ b/Hsbot/Plugin/Duck.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-} -- | This module is an IRC plugin that generates and kills ducks module Hsbot.Plugin.Duck - ( duck + ( DuckArgs (..) + , duck , theDuck ) where @@ -12,6 +13,7 @@ import Data.Acid import qualified Data.List as L import qualified Data.Map as M import Data.Maybe +import Data.Ord () import Data.SafeCopy import Data.Typeable import qualified Network.IRC as IRC @@ -22,56 +24,43 @@ import Hsbot.Message import Hsbot.Types import Hsbot.Utils --- | A user statistic -data Stat = Stat - { statRounds :: Int - , statShot :: Int - , statKilled :: Int - } deriving (Show, Typeable) - --- | Default values for new stat -emptyStat :: Stat -emptyStat = Stat { statRounds = 0 - , statShot = 0 - , statKilled = 0 } - -- The statistics database data StatDB = StatDB - { nickStats :: M.Map String Stat + { nickStats :: M.Map String Int } deriving (Show, Typeable) -- | Statistics database initial state emptyStatDB :: StatDB emptyStatDB = StatDB { nickStats = M.empty } -$(deriveSafeCopy 0 'base ''Stat) $(deriveSafeCopy 0 'base ''StatDB) -- | Statistics database transactions -scoreAction :: String -> Int -> Int -> Int -> Update StatDB () -scoreAction sender rounds shots kills = do +updateScore :: String -> Int -> Update StatDB () +updateScore sender score = do statDB <- get let stats = nickStats statDB - stat = fromMaybe emptyStat $ M.lookup sender stats - stat' = stat { statRounds = rounds + statRounds stat - , statShot = shots + statShot stat - , statKilled = kills + statKilled stat } - put statDB { nickStats = M.insert sender stat' stats } + stat = fromMaybe 0 $ M.lookup sender stats + put statDB { nickStats = M.insert sender (stat + score) stats } getDuckStats :: Query StatDB StatDB getDuckStats = ask -$(makeAcidic ''StatDB ['getDuckStats, 'scoreAction]) +$(makeAcidic ''StatDB ['getDuckStats, 'updateScore]) -- | The duck plugin identity duck :: PluginId duck = PluginId { pluginName = "duck" - , pluginEp = theDuck "" 10 } + , pluginEp = theDuck DuckArgs { duckChannel = "", duckFreq = 10 } } + +data DuckArgs = DuckArgs + { duckChannel :: String + , duckFreq :: Int } -- | An IRC plugin that generates and kills ducks -theDuck :: String -> Int -> Plugin (Env IO) () -theDuck channel seconds = do +theDuck :: DuckArgs -> Plugin (Env IO) () +theDuck (DuckArgs channel seconds) = do baseDir <- liftIO $ System.Environment.XDG.BaseDir.getUserDataDir "hsbot" statDB <- liftIO $ openAcidStateFrom (baseDir ++ "/duckDB/") emptyStatDB ducksMVar <- liftIO newEmptyMVar @@ -85,21 +74,19 @@ theDuck channel seconds = do -- First we kill the ducks that we find in the message let kills = howManyDucksInThere . concat $ IRC.msg_params msg when (kills /= "") $ answerMsg msg kills - -- Then we check if someone shot some duck when (getDestination msg == channel) $ do + -- Then we check if someone shot some duck let shots = howManyBulletFiredInThere . concat $ IRC.msg_params msg when (shots > 0) $ do - _ <- update' statDB (ScoreAction (getSender msg) 0 shots 0) - noDucksToShoot <- liftIO $ isEmptyMVar ducksMVar - unless noDucksToShoot $ do - ducksWaitingForDeath <- liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x)) - _ <- update' statDB (ScoreAction (getSender msg) 0 0 (min ducksWaitingForDeath shots)) - when (shots >= ducksWaitingForDeath) $ do - _ <- liftIO $ takeMVar ducksMVar - time <- liftIO $ readMVar timeMVar - duckSpawner channel time ducksMVar - _ <- update' statDB (ScoreAction (getSender msg) 1 0 0) - return () + empty <- liftIO $ isEmptyMVar ducksMVar + ducksWaitingForDeath <- if empty then return 0 + else liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x)) + _ <- update' statDB . UpdateScore (getSender msg) $ computeScore ducksWaitingForDeath shots + when (and [ ducksWaitingForDeath > 0, shots >= ducksWaitingForDeath ]) $ do + _ <- liftIO $ takeMVar ducksMVar + time <- liftIO $ readMVar timeMVar + duckSpawner channel time ducksMVar + return () -- Finally we check if we received some command cmdArgs <- lift $ getCommand msg case cmdArgs of @@ -113,6 +100,11 @@ theDuck channel seconds = do _ -> return () | otherwise = return () eval _ _ _ _ = return () + computeScore :: Int -> Int -> Int + computeScore ducksWaitingForDeath shots + | shots < ducksWaitingForDeath = shots - 1 + | shots == ducksWaitingForDeath = shots + 1 + | otherwise = negate shots -- | Spawns ducks on a channel, just waiting to be shot duckSpawner :: String -> Int -> MVar Int -> Plugin (Env IO) () @@ -150,7 +142,7 @@ ducks = [ x : y : z | x <- ">=", y <- face, z <- ["__/", "_/"] ] ++ [ L.reverse $ x : y : z | x <- "<=", y <- face, z <- ["__\\", "_\\"] ] where face :: String - face = "oO°@©®ð*òôóø⊕ΩꙫꙩꙨ◔" + face = "oO°@©®ð*òôóø⊕ΩꙫꙩꙨ◔ȯõ⁰" -- | Weapons can have different noises bangs :: [String] @@ -160,11 +152,15 @@ bangs = [ "PAN", "PAN!" ] printDuckStats :: String -> StatDB -> Plugin (Env IO) () printDuckStats channel statDB = do sendLine "Duck slaughter simulator - Hall of Fame" - mapM_ (sendLine . buildLine) $ M.toList (nickStats statDB) + mapM_ (sendLine . buildLine) . reverse . L.sortBy scoreSort $ M.toList (nickStats statDB) where - buildLine :: (String, Stat) -> String - buildLine (nick, stat) = concat [ nick, ": ", show $ statRounds stat, " rounds won, ", show $ statShot stat - , " shots fired, ", show $ statKilled stat, " ducks killed" ] + scoreSort :: (String, Int) -> (String, Int) -> Ordering + scoreSort (_, s1) (_,s2) + | s1 < s2 = LT + | s1 > s2 = GT + | otherwise = EQ + buildLine :: (String, Int) -> String + buildLine (nick, score) = concat [ nick, ": ", show score ] sendLine :: String -> Plugin (Env IO) () sendLine msg = writeMsg . OutgoingMsg $ IRC.Message Nothing "PRIVMSG" [channel, msg] 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/Types.hs b/Hsbot/Types.hs index c7331d3..7ca9ee0 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 @@ -63,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 @@ -71,16 +74,22 @@ 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 - , sslCert :: String - , sslKey :: String , sslVersions :: [Network.TLS.Version] , sslCiphers :: [Network.TLS.Cipher] , sslVerify :: Bool diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 6eec5c4..2ea1a49 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -1,25 +1,21 @@ module Hsbot.Utils ( addThreadIdToQuitMVar , delThreadIdFromQuitMVar + , hasAccess , initTLSEnv - , readCertificate - , readPrivateKey , sendStr , setGlobalQuitMVar ) where import Control.Concurrent +import Control.Exception (IOException, catch) 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 Data.Maybe +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 @@ -33,61 +29,41 @@ 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 + asks envBotState >>= liftIO . readMVar >>= evalStateT (fmap (any accessMatch) (gets botAccess)) + where + accessMatch :: AccessList -> Bool + accessMatch (AccessList amask arights) + | mask == amask = or [Admin `L.elem` arights, right `L.elem` arights] + | otherwise = False + -- 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 :: 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 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 } @@ -1,7 +1,7 @@ -* owner rights * better hooks? - - +* add help MVar +* add regexes support in accessList prefix +* exception handling on channel and MVar operations? @@ -9,34 +9,19 @@ :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 * write the vote system for the quote module * only the quote reporter should be able to edit it * detect too identical quoting in a raw, or implement quote abort -* handle the case we attempt to quote on an empty database -* solve the multiquote problem about the quote owner (with a quoteElem data structure) -* find a better way to track who voted for what? +* 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 the quoteadm command to the quote module +* 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 register for casual conversations for plugins? -* add a "I have stuff to save so don't kill me too hard" status for plugins - -* Make the bot auto-reconnect (/!\ admin plugin!) -* discard all trace with a color param and replace those with functions info/warn/error/debug -* write a safe reload : try reload before unloading -* remove from Types.hs what can be removed from it -* Find a way to handle bot reloading threw exec * 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 diff --git a/hsbot.cabal b/hsbot.cabal index 8182657..efcd91d 100644 --- a/hsbot.cabal +++ b/hsbot.cabal @@ -23,6 +23,7 @@ Library Hsbot.Core Hsbot.Message Hsbot.Plugin + Hsbot.Plugin.Admin Hsbot.Plugin.Duck Hsbot.Plugin.Ping Hsbot.Plugin.Quote @@ -43,9 +44,10 @@ Library network, random, safecopy, - tls >= 0.6.1, + tls >= 0.7.1, tls-extra >= 0.2.0, time, + utf8-string, xdg-basedir |