summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
Diffstat (limited to 'Hsbot')
-rw-r--r--Hsbot/Config.hs1
-rw-r--r--Hsbot/Core.hs1
-rw-r--r--Hsbot/Types.hs13
-rw-r--r--Hsbot/Utils.hs19
4 files changed, 31 insertions, 3 deletions
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"