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

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