From 34162d7ae58a8cb46b2e71d8d1d0606925275a62 Mon Sep 17 00:00:00 2001
From: Jon Doe <john@bugmenot.com>
Date: Mon, 28 Sep 2020 17:39:43 +0200
Subject: [PATCH] clean up, use typeclass for interface, fix some nonsense,
remove hardcoded values for the routing logic
---
exquisiterobot.conf.example | 1 +
src/Carrion/Plugin/IO/IRC/Client.hs | 134 +++++++++++++++++++---------
src/Carrion/Plugin/IO/STDIO.hs | 6 +-
src/Carrion/Plugin/TCL.hs | 58 ++++++------
src/GypsFulvus.hs | 71 ++++++++++-----
src/GypsFulvus/PluginStuff.hs | 15 +++-
6 files changed, 187 insertions(+), 98 deletions(-)
diff --git a/exquisiterobot.conf.example b/exquisiterobot.conf.example
index d0ced8b..7c73e77 100644
--- a/exquisiterobot.conf.example
+++ b/exquisiterobot.conf.example
@@ -2,3 +2,4 @@
hostname= chat.freenode.org
port= 6697
channels = ##politics !docking #noshower
+nickname = ExquisiteTest
\ No newline at end of file
diff --git a/src/Carrion/Plugin/IO/IRC/Client.hs b/src/Carrion/Plugin/IO/IRC/Client.hs
index f5522fe..cf1eada 100644
--- a/src/Carrion/Plugin/IO/IRC/Client.hs
+++ b/src/Carrion/Plugin/IO/IRC/Client.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module Carrion.Plugin.IO.IRC.Client
- (initPlugin,tellCommands)
+ (initPlugin,tellCommands,myPlugName)
where
import GypsFulvus.PluginStuff(Manhole(..),Sewage(..), InitStatus(..),SewageAutorInfo(..),genericAutorToNSAutor,inspectManhole,regift, stripCommandPrefix')
import Network.IRC.Client
@@ -26,20 +26,33 @@ import Network.IRC.CTCP(CTCPByteString(..))
import Control.Applicative ((<$>), (<|>))
import Data.List(nub,(\\))
import Data.Ini
+import Data.Maybe(fromMaybe)
import qualified Data.Text.IO as TIO
type MyNicknames = M.Map (T.Text) ([T.Text])
+(♯) :: T.Text -> T.Text -> T.Text
a ♯ b = T.append a b
+
+unpack :: T.Text -> String
unpack = T.unpack
+
myPlugName :: T.Text
myPlugName = T.pack "IRC-Simple"
+
lOCAL :: T.Text
lOCAL = T.pack "local"
-mySignature = GenericStyleAutor myPlugName lOCAL lOCAL
+mySignature :: SewageAutorInfo
+mySignature = GenericStyleAutor myPlugName myPlugName lOCAL
+
+tellCommands :: [T.Text]
tellCommands = ["tcl"]
+
+privateBotCommands :: [T.Text]
privateBotCommands = ["!join","!part","!kick","!op","!cycle","!reconnect","!ostracise","tcl"]
+
+myOwners :: [[Char]]
myOwners = ["hastur"]
--myChannels :: [T.Text]
@@ -72,8 +85,26 @@ replaceNNS nns theChan theNicknames= do
otherJoinHandler :: EventHandler s
otherJoinHandler = huntAlligators (matchType _Join) $ \_ c -> sendNAMES c
-otherPartHandler :: EventHandler s
-otherPartHandler = huntAlligators (matchType _Part) $ \_ (c,_) -> sendNAMES c
+
+otherPartHandler
+ :: TMVar (M.Map (NickName T.Text) [ChannelName T.Text])
+ -> EventHandler s
+otherPartHandler nns = huntAlligators (matchType' _Part nns) $ \src (nns, (c,r)) -> do
+ case src of
+ Channel n c -> do
+ liftIO . atomically $ removeFromNNS nns c n
+ return ()
+ _ -> return ()
+
+otherQuitHandler
+ :: TMVar (M.Map (NickName T.Text) [ChannelName T.Text])
+ -> EventHandler s
+otherQuitHandler nns = huntAlligators (matchType' _Quit nns) $ \src (nns, r) -> do
+ case src of
+ Channel n c -> do
+ liftIO . atomically $ removeFromNNS nns c n
+ return ()
+ _ -> return ()
removeFromNNS
:: (Ord k, Eq a) =>
@@ -91,7 +122,7 @@ namesReplyHandler
:: a -> TMVar (M.Map T.Text [T.Text]) -> EventHandler s
namesReplyHandler mh nns = huntAlligators (matchNumeric' rPL_NAMREPLY (mh,nns)) $
\src ((mh,nns), (meirl:theEqualsSignAsASeparateElementWhyTheFuckNot:theChan:theNicknames:[])) ->
- (liftIO . atomically $ replaceNNS nns theChan theNicknames) >>= (liftIO . putStrLn . show)
+ (liftIO . atomically $ replaceNNS nns theChan theNicknames) >> return () -- >>= (liftIO . putStrLn . show)
matchNumeric'
@@ -117,6 +148,7 @@ huntAlligators
huntAlligators mf cf = EventHandler mf cf
+fYourKickHandler :: TMVar (M.Map T.Text [T.Text]) -> EventHandler s
fYourKickHandler nns = huntAlligators (matchType' _Kick nns) $ \src (nns, (channame, nickname, reason)) -> do
tvarI <- get instanceConfig <$> getIRCState
iGotBooted <- liftIO . atomically $ do
@@ -134,9 +166,16 @@ fYourKickHandler nns = huntAlligators (matchType' _Kick nns) $ \src (nns, (chann
spamCoordinator :: Manhole -> T.Text -> IO ()
spamCoordinator mh msg = regift (Sewage mySignature msg) mh
-spamFromIRC mh msg thenick thechan = regift (Sewage (GenericStyleAutor myPlugName "local" thechan) msg) mh
+
+spamFromIRC :: Manhole -> T.Text -> T.Text -> T.Text -> IO ()
+spamFromIRC mh msg thenick thechan = regift (Sewage (GenericStyleAutor thenick myPlugName thechan) msg) mh
+
+stripDangerousNickname :: p -> T.Text -> T.Text
stripDangerousNickname n = T.filter (\c -> (not . (c `elem`)) ['[',']','{','}'])
+detectCommandHandler
+ :: (TMVar (M.Map (ChannelName T.Text) [T.Text]), Manhole)
+ -> EventHandler s
detectCommandHandler (nns,mh) = huntAlligators (matchType' _Privmsg (nns,mh)) $ \src ((nns,mh),(tgt,blergh)) -> do
tvarI <- get instanceConfig <$> getIRCState
case blergh of
@@ -150,68 +189,77 @@ detectCommandHandler (nns,mh) = huntAlligators (matchType' _Privmsg (nns,mh)) $
Just c -> do
case src of
Channel thechannelname thenickname -> do
- liftIO $ putStrLn $ "what the fuck: " ++ T.unpack thenickname ++ " " ++ T.unpack thechannelname
+-- liftIO $ putStrLn $ "what the fuck: " ++ T.unpack thenickname ++ " " ++ T.unpack thechannelname
lnns <- liftIO . atomically $ readTMVar nns
- let thenames = foldr1 (++) $ M.elems lnns -- fuck it all nicks
+ let thenames = (fromMaybe [T.pack ""]) $ M.lookup thechannelname lnns
liftIO $ spamCoordinator mh $ T.pack "tcl cache put irc chanlist [list " ♯ (foldr1 (\a b -> a ♯ " " ♯ b) $ (map (stripDangerousNickname $ T.pack)) $ thenames) ♯ "]"
liftIO $ spamFromIRC mh body thenickname thechannelname -- actually process the commands here
_ -> return () -- no secret commands fuck it
else return ()
Left _ -> return ()
+
stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
+data IRCConfig = IRCConfig {getIRCHost:: T.Text, getIRCPort :: Int, getIRCChannels :: [T.Text], getIRCNickname :: T.Text} | FuckedIRCConfig T.Text
+
+getIRCConfig :: IO IRCConfig
getIRCConfig = do
c <- TIO.readFile "./exquisiterobot.conf" >>= return . parseIni
case c of
- Left _ -> return (T.pack "",0,T.pack "")
+ Left _ -> return $ FuckedIRCConfig "Couldn't read the configuration file."
Right i -> do
let host = lookupValue "Server" "hostname" i
port = lookupValue "Server" "port" i
channels = lookupValue "Server" "channels" i
- case (host,port,channels) of
- (Right h, Right p, Right cs) -> return (h,(read . T.unpack $ p),cs)
- _ -> return ("",0,"")
+ myNickname = lookupValue "Server" "nickname" i
+ case (host,port,channels,myNickname) of
+ (Right h, Right p, Right cs, Right n) -> return $ IRCConfig h (read . T.unpack $ p) (T.splitOn " " cs) n
+ (h,p,cs,n) -> return $ FuckedIRCConfig $ foldr1 (♯) . map (T.pack . show) $ [h,p,cs,n]
+
initPlugin :: Manhole -> IO InitStatus
initPlugin mh = do
- (myHost,myPort,myChannels') <- getIRCConfig
- let myChannels = T.splitOn " " myChannels'
- let myNickname = "ExquisiteRobot"
- cpara = defaultParamsClient (unpack myHost) ""
- validate cs vc sid cc = do
- -- First validate with the standard function
- res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
- -- Then strip out non-issues
- return $ filter (`notElem` [UnknownCA, SelfSigned]) res
- myClientConfig = (tlsClientConfig myPort (encodeUtf8 myHost)) { tlsClientTLSSettings = TLSSettings cpara
- { clientHooks = (clientHooks cpara)
- { onServerCertificate = validate }
- , clientSupported = (clientSupported cpara)
- { supportedVersions = [TLS12, TLS11, TLS10]
- , supportedCiphers = ciphersuite_strong
- }
- }
- }
- conn = (tlsConnection $ WithClientConfig myClientConfig) & flood .~ 0
- myNNS <- atomically $ newTMVar M.empty
- let namesReplyHandler' = namesReplyHandler mh myNNS
- rejoinOnKickHandler = fYourKickHandler myNNS
- mySpecialHandlers = [rejoinOnKickHandler,detectCommandHandler',joinHandler',namesReplyHandler',otherJoinHandler,otherPartHandler]
- cfg = defaultInstanceConfig myNickname & channels %~ (myChannels ++) & handlers %~ (++ mySpecialHandlers)
- detectCommandHandler' = detectCommandHandler (myNNS,mh)
- myIRCState <- newIRCState conn cfg ()
- forkIO $ runClientWith myIRCState
- forkIO $ acceptExternalComms myIRCState mh
- return GoodInitStatus
-
+ ircConfig <- getIRCConfig
+ case ircConfig of
+ IRCConfig myHost myPort myChannels myNickname -> do
+ let cpara = defaultParamsClient (unpack myHost) ""
+ validate cs vc sid cc = do
+ -- First validate with the standard function
+ res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
+ -- Then strip out non-issues
+ return $ filter (`notElem` [UnknownCA, SelfSigned]) res
+ myClientConfig = (tlsClientConfig myPort (encodeUtf8 myHost)) { tlsClientTLSSettings = TLSSettings cpara
+ { clientHooks = (clientHooks cpara)
+ { onServerCertificate = validate }
+ , clientSupported = (clientSupported cpara)
+ { supportedVersions = [TLS12, TLS11, TLS10]
+ , supportedCiphers = ciphersuite_strong
+ }
+ }
+ }
+ conn = (tlsConnection $ WithClientConfig myClientConfig) & flood .~ 0
+ myNNS <- atomically $ newTMVar M.empty
+ let namesReplyHandler' = namesReplyHandler mh myNNS
+ rejoinOnKickHandler = fYourKickHandler myNNS
+ mySpecialHandlers = [rejoinOnKickHandler,detectCommandHandler',joinHandler',namesReplyHandler',otherJoinHandler,otherPartHandler myNNS, otherQuitHandler myNNS]
+ cfg = defaultInstanceConfig myNickname & channels %~ (myChannels ++) & handlers %~ (++ mySpecialHandlers)
+ detectCommandHandler' = detectCommandHandler (myNNS,mh)
+ myIRCState <- newIRCState conn cfg ()
+ forkIO $ runClientWith myIRCState
+ forkIO $ acceptExternalComms myIRCState mh
+ return GoodInitStatus
+ FuckedIRCConfig err -> return $ BadInitStatus err
+
+acceptExternalComms :: MonadIO f => IRCState s -> Manhole -> f b
acceptExternalComms myIRCState manhole =
let inspectManhole = atomically . readTChan . getInputChan
regift g = atomically . (flip writeTChan g) . getOutputChan in
forever $ do
newGift <- liftIO $ inspectManhole manhole
- putStrLn $ "trying to maybe send to " ++ (T.unpack .getChannel . genericAutorToNSAutor . getSewageAutor $ newGift)
+-- putStrLn $ "trying to maybe send to " ++ (T.unpack .getChannel . genericAutorToNSAutor . getSewageAutor $ newGift)
runIRCAction (mapM (\fff -> send $ Privmsg (getChannel . genericAutorToNSAutor . getSewageAutor $ newGift) $ Right fff) (nlSplit $ getSewage newGift)) myIRCState
+nlSplit :: T.Text -> [T.Text]
nlSplit = T.splitOn "\n"
diff --git a/src/Carrion/Plugin/IO/STDIO.hs b/src/Carrion/Plugin/IO/STDIO.hs
index 8415965..d1cabaa 100644
--- a/src/Carrion/Plugin/IO/STDIO.hs
+++ b/src/Carrion/Plugin/IO/STDIO.hs
@@ -1,9 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Carrion.Plugin.IO.STDIO
( initPlugin,
- processCommand,
- testThing,
tellCommands,
+ myPlugName
) where
import Control.Monad.IO.Class
import Control.Monad
@@ -27,7 +26,8 @@ testThing = runInputT defaultSettings loop
Just "quit" -> return ()
Just input -> do outputStrLn $ T.unpack ("Input was: " ++ T.pack input)
loop
-mySignature = GenericStyleAutor "STDIO haskeline" "local" "local"
+myPlugName = "STDIO haskeline"
+mySignature = GenericStyleAutor myPlugName myPlugName "local"
tellCommands = [""]
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
diff --git a/src/Carrion/Plugin/TCL.hs b/src/Carrion/Plugin/TCL.hs
index 90eb5e5..b3802a3 100644
--- a/src/Carrion/Plugin/TCL.hs
+++ b/src/Carrion/Plugin/TCL.hs
@@ -2,8 +2,8 @@
module Carrion.Plugin.TCL
( initPlugin,
- processCommand,
- tellCommands
+ tellCommands,
+ myPlugName
) where
import Control.Monad
import Control.Concurrent(forkIO, threadDelay, killThread)
@@ -53,27 +53,34 @@ foreign import ccall "dynamic" mkTcl_EvalEx :: FunPtr (Tcl_Interp_Ptr -> TclScri
tu :: T.Text -> String
tu = T.unpack
+
tellCommands :: [T.Text]
tellCommands = map T.pack ["tcl","tclAdmin"]
+
+privilegedAutors :: [T.Text]
privilegedAutors = map T.pack ["core","STDIO haskeline","hastur","IRC-Simple"]
+
+myPluginName :: T.Text
myPluginName = T.pack "TCL-Simple"
-tl :: T.Text
-tl = T.pack "local"
+myPlugName = myPluginName
+lOCAL :: T.Text
+lOCAL = T.pack "local"
+
mySignature :: SewageAutorInfo
-mySignature = GenericStyleAutor myPluginName tl tl
-sigWithChan ch = GenericStyleAutor myPluginName tl ch
+mySignature = GenericStyleAutor myPluginName myPluginName lOCAL
+
+sigWithChan :: T.Text -> SewageAutorInfo
+sigWithChan ch = GenericStyleAutor myPluginName myPluginName ch
+
stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
-fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
- :: SewageAutorInfo -> String -> TCLCommand
-fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson b = case b of
- GenericStyleAutor a b c -> fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson . genericAutorToNSAutor $ GenericStyleAutor a b c
- NetworkIdentStyleAutor a b c -> TCLCommand (tu a) (show b) "" (tu c)
mkTCLCommandFromAIAndMsg :: SewageAutorInfo -> String -> TCLCommand
-mkTCLCommandFromAIAndMsg = fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
-
+mkTCLCommandFromAIAndMsg b = case b of
+ GenericStyleAutor a b c -> mkTCLCommandFromAIAndMsg . genericAutorToNSAutor $ GenericStyleAutor a b c
+ NetworkIdentStyleAutor a b c -> TCLCommand (tu a) (show b) "" (tu c)
+
data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Interp_Ptr),
getEvalFile :: Tcl_EvalFile_Sig,
getEvalEx :: Tcl_EvalEx_Sig,
@@ -84,9 +91,11 @@ data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Inter
lEN_AUTO :: Int
lEN_AUTO = -1
+
eVAL_FLAGS_CLEAR :: Int
eVAL_FLAGS_CLEAR = 0
+dumpDebug :: Monad m => p -> m ()
dumpDebug _ = return ()
initPlugin :: Manhole -> IO InitStatus
@@ -146,25 +155,20 @@ processCommand wi s ip = do
let runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
runTclCommand s = newCString s >>= runscript
errorInfo = runTclCommand "return $errorInfo"
-
doTheTCL c = runTclCommand c >>= \st ->
case st of
0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then dumpDebug ("Command: " ++ c ++" ; returned a null pointer result.") >> return "FAILED" else peekCString rs >>= \nrs -> dumpDebug ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";") >> return nrs
_ -> errorInfo >> tcl_GetStringResult interp >>= peekCString
performFromIRC = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
performAdminLevel = doTheTCL sewCmd
--- harvester <- forkIO $ do
--- threadDelay 15000000
--- putStrLn "cancelling thread!!!"
--- fff <- tcl_CancelEval interp nullPtr nullPtr 0x100000
--- putStrLn $ "cancel status " ++ (show fff)
--- hngggg <- tcl_AsyncInvoke interp 0
--- putStrLn $ "asyncinvoke returned " ++ (show hngggg)
res <- if (ip) then performAdminLevel else performFromIRC
--- putStrLn "putting back the interp"
atomically $ putTMVar i interp
return $ T.pack res
+sigWithChan' :: T.Text -> T.Text -> SewageAutorInfo
+sigWithChan' thechannel originallocation = GenericStyleAutor originallocation myPluginName thechannel
+
+rEPL :: TCLInterpreterWrapper -> Manhole -> IO b
rEPL wrappedtclinterp manhole =
let inspectManhole = atomically . readTChan . getInputChan
regift g = atomically . (flip writeTChan g) . getOutputChan in
@@ -178,16 +182,13 @@ rEPL wrappedtclinterp manhole =
case hmm of
Nothing -> do
let theOriginalChannel = getContext . nsAutorToGenericAutor . getSewageAutor $ newGift
+ theOriginalPlugin = getLocation . nsAutorToGenericAutor . getSewageAutor $ newGift
let isPrivileged = if T.pack "tclAdmin " `T.isPrefixOf` (getSewage newGift) && ( getNick . genericAutorToNSAutor . getSewageAutor $ newGift) `elem` privilegedAutors then True else False
processedGift <- processCommand wrappedtclinterp giftStripped isPrivileged
- regift (Sewage (sigWithChan theOriginalChannel) processedGift) manhole
+ regift (Sewage (sigWithChan' theOriginalChannel theOriginalPlugin) processedGift) manhole
Just berror -> regift (Sewage mySignature (T.pack berror)) manhole
Nothing -> return ()
--- stolen from the internet and adapted for tcl
--- Return whether a string contains balanced brackets. Nothing indicates a
--- balanced string, while (Just i) means an imbalance was found at, or just
--- after, the i'th bracket. We assume the string contains only brackets.
isBalanced :: Char -> Char -> String -> Maybe String
isBalanced openc closec = bal (-1) 0
where
@@ -202,9 +203,12 @@ isBalanced openc closec = bal (-1) 0
(sc:rs) -> if sc == openc || sc == closec then bal (i+2) n rs else bal (i+1) n rs
| otherwise = bal (i+1) n bs
+gnarlyBalanced :: String -> Maybe String
gnarlyBalanced = isBalanced '{' '}'
-- it's better not to check for double quotes and square brackets I think since they can be escaped and not used internally for pub:tcl:perform...
+squareBalanced :: String -> Maybe String
squareBalanced = isBalanced '[' ']'
+dquoteBalanced :: String -> Maybe String
dquoteBalanced = isBalanced '"' '"'
diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs
index 732ab82..0242452 100644
--- a/src/GypsFulvus.hs
+++ b/src/GypsFulvus.hs
@@ -68,12 +68,15 @@ lookupManholeInSewer s p = do
corePlugName :: T.Text
corePlugName = "core"
+
+mySignature :: SewageAutorInfo
mySignature = GenericStyleAutor corePlugName "local" "local"
isIOPlugin :: Sewage -> TMVar IOPIDS -> IO Bool
-isIOPlugin sewage iopids = let pname = (hash . getName .nsAutorToGenericAutor . getSewageAutor $ sewage)
+isIOPlugin sewage iopids = let pname = (hash . getLocation .nsAutorToGenericAutor . getSewageAutor $ sewage)
in do
IOPIDS iop <- atomically $ readTMVar iopids
+
return $ pname `elem` iop
runForever :: TMVar Sewer -> TMVar(CommandMap) -> TMVar(IOPIDS) -> IO ()
@@ -91,7 +94,7 @@ runForever s cmap iopids =
if (amIIO) then
trySendToWorker s someGarbage cmap
else do
- pm <- atomically $ lookupManholeInSewer s "IRC-Simple"
+ pm <- atomically $ lookupManholeInSewer s (getName . nsAutorToGenericAutor . getSewageAutor $ someGarbage)
case pm of
Just pm -> regiftToWorker someGarbage pm
Nothing -> return ()
@@ -125,24 +128,42 @@ makeManhole s p = do
Nothing -> return Nothing
-tryRegisterPlugin :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus
-tryRegisterPlugin s plugName initFunc tellCommandsFunc = do
- im <- makeManhole s plugName
- case im of
- Just im' -> do
- moduleInitStatus <- initFunc im'
- case moduleInitStatus of
- GoodInitStatus -> do
- atomically $ assCallbackWithManholeInSewer s plugName im'
- return GoodInitStatus
- BadInitStatus errs -> return $ BadInitStatus $ "couldn't load the " ++ plugName ++ " plugin: " ++ errs
- Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected."
+
+registerPlugin_
+ :: TMVar Sewer
+ -> T.Text -> (Manhole -> IO InitStatus) -> IO InitStatus
+registerPlugin_ s plugName initFunc = do
+ im <- makeManhole s plugName
+ case im of
+ Just im' -> do
+ moduleInitStatus <- initFunc im'
+ case moduleInitStatus of
+ GoodInitStatus -> do
+ atomically $ assCallbackWithManholeInSewer s plugName im'
+ return GoodInitStatus
+ BadInitStatus errs -> return $ BadInitStatus $ "couldn't load the " ++ plugName ++ " plugin: " ++ errs
+ Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected."
+tryRegisterPlugin
+ :: TMVar Sewer
+ -> TMVar IOPIDS -> TMVar CommandMap -> CarrionPlugin -> IO InitStatus
+tryRegisterPlugin s iopids commandMap plugin = do
+ let plugName = tellPlugName plugin
+ let initFunc = initPlugin plugin
+ let tellFunc = tellCommands plugin
+ theStatus <- registerPlugin_ s plugName initFunc
+ atomically $ registerCommands commandMap plugName tellFunc
+ case plugin of
+ InputPlugin initFunc tellFunc plugName -> do
+ atomically $ regiop plugName iopids
+ return ()
+ WorkerPlugin _ _ _ -> return ()
+ return theStatus
makeNewSewer :: Manhole -> IO (TMVar Sewer)
makeNewSewer coreManhole = do
let
- plugName = "core"
+ plugName = corePlugName
emptySewer <- atomically $ newTMVar $ Sewer M.empty
atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole
@@ -156,24 +177,28 @@ stdioPlugName = "STDIO haskeline"
tclPlugName :: T.Text
tclPlugName = "TCL-Simple"
+
ircPlugName :: T.Text
ircPlugName = "IRC-Simple"
+statusBad s = case s of
+ GoodInitStatus -> False
+ BadInitStatus _ -> True
+
execMain :: IO ()
execMain = do
+ let cpstdio = InputPlugin CPISTDIO.initPlugin CPISTDIO.tellCommands CPISTDIO.myPlugName
+ ircsimp = InputPlugin IRCSIMP.initPlugin IRCSIMP.tellCommands IRCSIMP.myPlugName
+ tclsimp = WorkerPlugin TCLSIMP.initPlugin TCLSIMP.tellCommands TCLSIMP.myPlugName
+ myPlugins = [cpstdio,ircsimp,tclsimp]
collectorChannel <- atomically newTChan -- normal channel for dumping any user input, this is the output channel for all plugins
dumperChannel <- atomically newTChan -- uh this doesnt make any sense, every dings needs to have its own channel
commandMap <- atomically $ newTMVar $ CommandMap M.empty
iopids <- atomically $ newTMVar $ IOPIDS []
newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel
- tryRegisterPlugin newSewer stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands
- atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands
- atomically $ regiop stdioPlugName iopids
- tryRegisterPlugin newSewer ircPlugName IRCSIMP.initPlugin IRCSIMP.tellCommands
- atomically $ registerCommands commandMap ircPlugName IRCSIMP.tellCommands
- atomically $ regiop ircPlugName iopids
- tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands
- atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands
+ initStatuses <- Par.mapM (tryRegisterPlugin newSewer iopids commandMap ) myPlugins
+ let badstatuses = filter (statusBad) initStatuses
+ if (not . null $ badstatuses) then mapM_ (putStrLn . T.pack . show) initStatuses >> error (T.unpack "Plugin load failed, see above.") else return ()
let myTIDs = []
runForever newSewer commandMap iopids
mapM_ killThread myTIDs
diff --git a/src/GypsFulvus/PluginStuff.hs b/src/GypsFulvus/PluginStuff.hs
index 82d0766..be6c73e 100644
--- a/src/GypsFulvus/PluginStuff.hs
+++ b/src/GypsFulvus/PluginStuff.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regiftToWorker) where
+module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regiftToWorker, Carrion(..),CarrionPlugin(..)) where
import Control.Monad
@@ -78,7 +78,7 @@ data Sewage = Sewage {
data Manhole = Manhole {
getInputChan :: TChan Sewage,
getOutputChan :: TChan Sewage}
-data InitStatus = GoodInitStatus | BadInitStatus T.Text
+data InitStatus = GoodInitStatus | BadInitStatus T.Text deriving Show
inspectManhole :: Manhole -> IO Sewage
inspectManhole = atomically . readTChan . getInputChan
@@ -88,3 +88,14 @@ regift g = atomically . (flip writeTChan g) . getOutputChan
regiftToWorker :: Sewage -> Manhole -> IO ()
regiftToWorker g = atomically . (flip writeTChan g) . getInputChan
+
+data CarrionPlugin = InputPlugin {getInitPlugin :: (Manhole -> IO InitStatus), getTellCommands :: [T.Text], getMyPlugName :: T.Text} | WorkerPlugin {getInitPlugin :: (Manhole -> IO InitStatus), getTellCommands :: [T.Text], getMyPlugName :: T.Text}
+
+class Carrion a where
+ initPlugin :: a -> Manhole -> IO InitStatus
+ tellCommands :: a -> [T.Text]
+ tellPlugName :: a -> T.Text
+instance Carrion CarrionPlugin where
+ initPlugin = getInitPlugin
+ tellCommands = getTellCommands
+ tellPlugName = getMyPlugName