From 34162d7ae58a8cb46b2e71d8d1d0606925275a62 Mon Sep 17 00:00:00 2001 From: Jon Doe 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