Merge branch 'master' into quoteModule

Conflicts:
	hsbot.cabal

Hsbot.hs

@@ -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
+         BotReload reason -> do
-         BotRestart -> relaunchMaster Nothing -- TODO relaunch and kill sockets
+             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

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
+    , sslCiphers  = [ cipher_AES128_SHA1
-                    , cipher_null_SHA1
-                    , cipher_AES128_SHA1
                     , cipher_AES256_SHA1
                     , cipher_RC4_128_MD5
                     , cipher_RC4_128_SHA1

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.UTF8 as L
-import qualified Data.ByteString.Lazy 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 :: [String] -> Env IO BotStatus
-runHsbot = do
+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 env 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.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 :: BotEnv -> Handle -> Maybe TLSCtx -> Chan Message -> IO ()
-botReader _ (Just ctx) chan _ = forever $
+botReader env _ (Just ctx) chan = forever $
-    fmap L.toChunks (recvData ctx) >>= mapM_ (handleIncomingStr chan . C.unpack)  -- TODO exceptions
+    fmap L.toString (recvData ctx) `catch` handleIOException env  "botReader died" >>= handleIncomingStr chan
-botReader handle Nothing chan fatherThreadId = forever $
+botReader env handle Nothing chan = forever $
-    hGetLine handle `catch` handleIOException >>= handleIncomingStr chan
+    hGetLine handle `catch` handleIOException env "botReader died" >>= handleIncomingStr chan
-  where
+
-    handleIOException :: IOException -> IO String
+handleIOException :: BotEnv -> String -> IOException -> IO String
-    handleIOException ioException = do
+handleIOException env msg ioException = do
-        throwTo fatherThreadId ioException
+    runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env
-        myId <- myThreadId
+    myId <- myThreadId
-        killThread myId
+    killThread myId
-        return ""
+    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 $ 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

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
+getCommand (IRC.Message _ _ (_:msg:[])) = getCommandFrom $ words msg
-    currentBotState <- asks envBotState >>= liftIO . readMVar
+  where
-    let cmd:stuff = if msg /= "" then words msg else ["",""]
+    getCommandFrom :: [String] -> Env IO [String]
-    if botNickname currentBotState `L.isPrefixOf` cmd
+    getCommandFrom (cmd:stuff) = do
-        then return stuff
+        currentBotState <- asks envBotState >>= liftIO . readMVar
-        else return []
+        if botNickname currentBotState `L.isPrefixOf` cmd
+            then return stuff
+            else return []
+    getCommandFrom _ = return []
 getCommand _ = return []
 
 getSender :: IRC.Message -> String

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 ()
+

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 ()
+updateScore :: String -> Int -> Update StatDB ()
-scoreAction sender rounds shots kills = do
+updateScore sender score = do
     statDB <- get
     let stats = nickStats statDB
-        stat = fromMaybe emptyStat $ M.lookup sender stats
+        stat = fromMaybe 0 $ M.lookup sender stats
-        stat' = stat { statRounds = rounds + statRounds stat
+    put statDB { nickStats = M.insert sender (stat + score) stats }
-                     , statShot   = shots  + statShot   stat
-                     , statKilled = kills  + statKilled stat }
-    put statDB { nickStats = M.insert sender stat' 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 :: DuckArgs -> Plugin (Env IO) ()
-theDuck channel seconds = do
+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)
+                    empty <- liftIO $ isEmptyMVar ducksMVar
-                    noDucksToShoot <- liftIO $ isEmptyMVar ducksMVar
+                    ducksWaitingForDeath <- if empty then return 0
-                    unless noDucksToShoot $ do
+                                                     else liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x))
-                        ducksWaitingForDeath <- liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x))
+                    _ <- update' statDB . UpdateScore (getSender msg) $ computeScore ducksWaitingForDeath shots
-                        _ <- update' statDB (ScoreAction (getSender msg) 0 0 (min ducksWaitingForDeath shots))
+                    when (and [ ducksWaitingForDeath > 0, shots >= ducksWaitingForDeath ]) $ do
-                        when (shots >= ducksWaitingForDeath) $ do
+                        _ <- liftIO $ takeMVar ducksMVar
-                            _ <- liftIO $ takeMVar ducksMVar
+                        time <- liftIO $ readMVar timeMVar
-                            time <- liftIO $ readMVar timeMVar
+                        duckSpawner channel time ducksMVar
-                            duckSpawner channel time ducksMVar
+                    return ()
-                            _ <- update' statDB (ScoreAction (getSender msg) 1 0 0)
-                            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
+    scoreSort :: (String, Int) -> (String, Int) -> Ordering
-    buildLine (nick, stat) = concat [ nick,  ": ", show $ statRounds stat, " rounds won, ", show $ statShot stat
+    scoreSort (_, s1) (_,s2)
-                                    , " shots fired, ", show $ statKilled stat, " ducks killed" ]
+      | 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]
 

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

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

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 Control.Monad.State
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.UTF8 as L
-import qualified Data.ByteString.Char8 as C
+import qualified Data.List as L
-import qualified Data.ByteString.Lazy as L
+import qualified Network.IRC as IRC
-import qualified Data.Certificate.KeyRSA as KeyRSA
-import Data.Certificate.PEM
-import Data.Certificate.X509
-import Data.List
-import Data.Maybe
 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 :: BotEnv -> Handle -> Maybe TLSCtx -> String -> IO ()
-sendStr _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
+sendStr env _ (Just ctx) msg = sendData ctx (L.fromString $ msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg)
-sendStr handle Nothing msg = hPutStrLn handle 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
+    let versions = sslVersions ssl
-        keyFile  = sslKey ssl
-        versions = sslVersions ssl
         ciphers  = sslCiphers ssl
-        verify   = sslVerify ssl
+    return $ defaultParams { pAllowedVersions = versions
-    -- TODO : exception on loading keys
+                           , pCiphers = ciphers }
-    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
 

TODO

@@ -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
+* find a better way to track who voted for what? - need authentication against the bot
-* solve the multiquote problem about the quote owner (with a quoteElem data structure)
-* find a better way to track who voted for what?
 
-* 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 the quoteadm command to the quote module
 * 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
 

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