clean up, use typeclass for interface, fix some nonsense, remove hardcoded values for the routing logic
This commit is contained in:
Jon Doe
Maciej Bonin
parent
4efaff2c06
commit
34162d7ae5
@ -2,3 +2,4 @@
|
||||
hostname= chat.freenode.org
|
||||
port= 6697
|
||||
channels = ##politics !docking #noshower
|
||||
nickname = ExquisiteTest
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 '"' '"'
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user