summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
authorJulien Dessaux2011-09-10 00:10:00 +0200
committerJulien Dessaux2011-09-10 00:10:00 +0200
commit900c242551f624f4ab5b3ea79fd51611b47bd95e (patch)
tree215be6ae5c35f08eaa1be497b504abc0b28ee7c6 /Hsbot
parentFixed compilation errors. Since I forgot to add the quote module to cabal the... (diff)
parentAdded score sorting for the duck module (diff)
downloadhsbot-900c242551f624f4ab5b3ea79fd51611b47bd95e.tar.gz
hsbot-900c242551f624f4ab5b3ea79fd51611b47bd95e.tar.bz2
hsbot-900c242551f624f4ab5b3ea79fd51611b47bd95e.zip
Merge branch 'master' into quoteModule
Conflicts: hsbot.cabal
Diffstat (limited to '')
-rw-r--r--Hsbot.hs26
-rw-r--r--Hsbot/Config.hs7
-rw-r--r--Hsbot/Core.hs58
-rw-r--r--Hsbot/Message.hs15
-rw-r--r--Hsbot/Plugin/Admin.hs45
-rw-r--r--Hsbot/Plugin/Duck.hs84
-rw-r--r--Hsbot/Plugin/Ping.hs3
-rw-r--r--Hsbot/Types.hs17
-rw-r--r--Hsbot/Utils.hs88
9 files changed, 195 insertions, 148 deletions
diff --git a/Hsbot.hs b/Hsbot.hs
index c02b2e5..e2e771e 100644
--- a/Hsbot.hs
+++ b/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
- 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 }