summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
Diffstat (limited to 'Hsbot')
-rw-r--r--Hsbot/Config.hs7
-rw-r--r--Hsbot/Core.hs78
-rw-r--r--Hsbot/Message.hs9
-rw-r--r--Hsbot/Plugin/Ping.hs38
-rw-r--r--Hsbot/Types.hs19
-rw-r--r--Hsbot/Utils.hs23
6 files changed, 137 insertions, 37 deletions
diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs
index 7ab23f5..1f9329b 100644
--- a/Hsbot/Config.hs
+++ b/Hsbot/Config.hs
@@ -6,10 +6,13 @@ module Hsbot.Config
, noSSL
) where
+import Control.Concurrent.Chan
import Network
+import qualified Network.IRC as IRC
import Network.TLS
import Network.TLS.Extra
+import Hsbot.Message
data Config = Config
{ configErrors :: Maybe String
, configTLS :: TLSConfig
@@ -18,7 +21,7 @@ data Config = Config
, configChannels :: [String]
, configNicknames :: [String]
, configRealname :: String
- , configPlugins :: [String]
+ , configPlugins :: [(String, Chan Message -> Chan Message -> IO ())]
}
defaultConfig :: Config
@@ -30,7 +33,7 @@ defaultConfig = Config
, configChannels = ["#hsbot"]
, configNicknames = ["hsbot"]
, configRealname = "The One True bot, with it's haskell soul."
- , configPlugins = ["Ping", "Core"] }
+ , configPlugins = [] }
data TLSConfig = TLSConfig
{ sslOn :: Bool
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index cab05bd..d11f211 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -7,8 +7,10 @@ module Hsbot.Core
import Control.Concurrent
import Control.Exception (IOException, catch)
import Control.Monad.Reader
+import Control.Monad.State
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
import Network
import qualified Network.IRC as IRC
import Network.BSD (getHostName)
@@ -51,31 +53,43 @@ initHsbot config = do
runHsbot :: Env IO (BotStatus)
runHsbot = do
- -- First we say hello
- env <- ask
- hostname <- liftIO getHostName
- let connhdl = envHandle env
- tlsCtx = envTLSCtx env
- config = envConfig env
- nickname = head $ configNicknames config
- channels = configChannels config
- liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.nick nickname
- liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
- mapM_ (liftIO . sendStrToClient connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
- -- Next we spawn the reader thread
- liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
- myOwnThreadId <- liftIO $ myThreadId
- chan <- asks envChan
- (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar
- -- Then we spawn all plugins
- -- asks envSocket >>= mapM_ ( ----- what's next? the core server handling! ----- )
- -- Finally we spawn the main bot loop
- --
- -- We wait for the quit signal
- code <- asks envQuitMv >>= liftIO . takeMVar
- -- and we clean things up
- asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
- return code
+ let bot = BotState { botPlugins = M.empty
+ , botHooks = []
+ , botChannels = []
+ , botNickname = [] }
+ evalStateT trueRunHsbot bot
+ where
+ trueRunHsbot :: Bot (Env IO) (BotStatus)
+ trueRunHsbot = do
+ -- First we say hello
+ env <- lift ask
+ hostname <- liftIO getHostName
+ let connhdl = envHandle env
+ tlsCtx = envTLSCtx env
+ 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)
+ mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
+ -- Next we spawn the reader thread
+ liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
+ myOwnThreadId <- liftIO $ myThreadId
+ chan <- lift $ asks envChan
+ (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar
+ -- Then we spawn all plugins
+ -- asks envSocket >>= mapM_ ( ----- what's next? the core server handling! ----- )
+ -- Finally we spawn the main bot loop
+ bot <- get
+ finalStateMVar <- liftIO newEmptyMVar
+ (liftIO . forkIO $ runReaderT (execStateT botLoop bot >>= storeFinalState finalStateMVar) env) >>= lift . addThreadIdToQuitMVar
+ -- We wait for the quit signal
+ code <- asks envQuitMv >>= liftIO . takeMVar
+ -- and we clean things up
+ asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
+ return code
+ storeFinalState :: MVar BotState -> BotState -> Env IO ()
+ storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState
botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
botReader _ (Just ctx) chan _ = forever $
@@ -90,6 +104,20 @@ botReader handle Nothing chan fatherThreadId = forever $
killThread myId
return ""
+botLoop :: Bot (Env IO) ()
+botLoop = do
+ chan <- lift $ asks envChan
+ hooks <- gets botHooks
+ msg <- liftIO $ readChan chan
+ mapM_ (liftIO . flip writeChan msg) hooks
+ case msg of
+ IncomingMsg _ -> return () -- TODO parse for core commands
+ OutgoingMsg outMsg -> do
+ env <- lift ask
+ let connhdl = envHandle env
+ tlsCtx = envTLSCtx env
+ liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
+
handleIncomingStr :: Chan Message -> String -> IO ()
handleIncomingStr chan str = do
case IRC.decode str of
diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs
new file mode 100644
index 0000000..5ec35ed
--- /dev/null
+++ b/Hsbot/Message.hs
@@ -0,0 +1,9 @@
+module Hsbot.Message
+ ( Message (..)
+ ) where
+
+import qualified Network.IRC as IRC
+
+data Message = IncomingMsg IRC.Message
+ | OutgoingMsg IRC.Message
+
diff --git a/Hsbot/Plugin/Ping.hs b/Hsbot/Plugin/Ping.hs
new file mode 100644
index 0000000..b020359
--- /dev/null
+++ b/Hsbot/Plugin/Ping.hs
@@ -0,0 +1,38 @@
+module Hsbot.Plugin.Ping
+ ( pingId
+ , ping
+ ) where
+
+import Control.Concurrent.Chan ()
+import Control.Exception
+import Control.Monad.State (execStateT, forever)
+import qualified Network.IRC as IRC
+import Prelude hiding (catch)
+
+import Hsbot.Message
+import Hsbot.Types
+import Hsbot.Utils
+
+pingId :: PluginId
+pingId = PluginId
+ { pluginName = "ping"
+ , pluginEp = ping }
+
+-- | The plugin's main entry point
+ping :: PluginState -> IO ()
+ping state = do
+ _ <- (execStateT run state) `catch` (\(_ :: AsyncException) -> return state)
+ return ()
+
+-- | The IrcPlugin monad main function
+run :: Plugin IO ()
+run = forever $ do
+ msg <- readMsg
+ eval msg
+ where
+ eval :: Message -> Plugin IO ()
+ eval (IncomingMsg msg)
+ | (IRC.msg_command msg) == "PING" = writeMsg . OutgoingMsg . IRC.Message Nothing "PONG" $ IRC.msg_params msg
+ | otherwise = return ()
+ eval _ = return ()
+
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index ff57c49..28ad430 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -5,6 +5,8 @@ module Hsbot.Types
, BotEnv (..)
, Env
, Message (..)
+ , Plugin
+ , PluginId (..)
, PluginState (..)
) where
@@ -12,11 +14,11 @@ import Control.Concurrent
import qualified Data.Map as M
import Control.Monad.Reader
import Control.Monad.State
-import qualified Network.IRC as IRC
import Network.TLS
import System.IO
import Hsbot.Config
+import Hsbot.Message
-- The bot environment
type Env = ReaderT BotEnv
@@ -36,19 +38,24 @@ type Bot = StateT BotState
data BotState = BotState
{ botPlugins :: M.Map String (PluginState, MVar (), ThreadId)
- , botCommands :: M.Map String [String]
+ , botHooks :: [Chan Message]
, botChannels :: [String]
, botNickname :: String
}
-- The Plugin monad
+type Plugin = StateT PluginState
+
data PluginState = PluginState
+ { pluginId :: PluginId
+ , pluginChan :: Chan Message
+ , pluginMaster :: Chan Message
+ }
+
+data PluginId = PluginId
{ pluginName :: String
- , pluginChan :: Chan Message
+ , pluginEp :: PluginState -> IO ()
}
data BotStatus = BotContinue | BotExit | BotReload | BotRestart deriving (Show)
-data Message = IncomingMsg IRC.Message
- | OutgoingMsg IRC.Message
-
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 785fb10..6b7f85e 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -4,13 +4,16 @@ module Hsbot.Utils
, first
, initTLSEnv
, readCertificate
+ , readMsg
, readPrivateKey
- , sendStrToClient
+ , sendStr
, setGlobalQuitMVar
+ , writeMsg
) where
import Control.Concurrent
import Control.Monad.Reader
+import Control.Monad.State
import qualified Crypto.Cipher.RSA as RSA
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
@@ -23,6 +26,7 @@ import Network.TLS
import System.IO
import Hsbot.Config
+import Hsbot.Message
import Hsbot.Types
-- utility functions
@@ -45,9 +49,20 @@ first :: (a, b, c) -> a
first (a, _, _) = a
-- Helpers
-sendStrToClient :: Handle -> Maybe TLSCtx -> String -> IO ()
-sendStrToClient _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
-sendStrToClient handle Nothing msg = hPutStrLn handle msg
+sendStr :: Handle -> Maybe TLSCtx -> String -> IO ()
+sendStr _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
+sendStr handle Nothing msg = hPutStrLn handle msg
+
+-- Plugin Utils
+readMsg :: Plugin IO (Message)
+readMsg = do
+ chan <- gets pluginChan
+ liftIO $ readChan chan >>= return
+
+writeMsg :: Message -> Plugin IO ()
+writeMsg msg = do
+ chan <- gets pluginMaster
+ liftIO $ writeChan chan msg
-- TLS utils
initTLSEnv :: TLSConfig -> IO (TLSParams)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 06:17:58 +0000