From 3a85db15d306165117153d30903b59897f5ad4f6 Mon Sep 17 00:00:00 2001 From: Jon Doe Date: Thu, 24 Sep 2020 20:03:10 +0200 Subject: [PATCH] clean up --- GypsFulvus.cabal | 6 +- src/Carrion/Plugin/TCL.hs | 2 +- src/GypsFulvus.hs | 174 +++++++++++++--------------------- src/GypsFulvus/PluginStuff.hs | 16 +++- 4 files changed, 82 insertions(+), 116 deletions(-) diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index 0ff4572..97bb301 100644 --- a/GypsFulvus.cabal +++ b/GypsFulvus.cabal @@ -14,8 +14,8 @@ cabal-version: >=1.10 extra-source-files: README.md library - exposed-modules: GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL - other-modules: GypsFulvus.PluginStuff + exposed-modules: GypsFulvus, GypsFulvus.PluginStuff, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL + other-modules: default-language: Haskell2010 hs-source-dirs: src build-depends: @@ -23,7 +23,6 @@ library stm, containers, text, - plugins >= 1.6.0, directory, hashable, monad-parallel, @@ -46,7 +45,6 @@ executable GypsFulvus stm, containers, text, - plugins >= 1.6.0, directory, hashable, monad-parallel, diff --git a/src/Carrion/Plugin/TCL.hs b/src/Carrion/Plugin/TCL.hs index a33a479..ee61b8e 100644 --- a/src/Carrion/Plugin/TCL.hs +++ b/src/Carrion/Plugin/TCL.hs @@ -55,7 +55,7 @@ tu :: T.Text -> String tu = T.unpack tellCommands :: [T.Text] tellCommands = map T.pack ["tcl"] -myPluginName = T.pack "TCL smeggdrop" +myPluginName = T.pack "TCL-Simple" tl :: T.Text tl = T.pack "local" mySignature :: SewageAutorInfo diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index 02a3670..c135e73 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -12,19 +12,35 @@ import Control.Monad.IO.Class import qualified Data.Map.Strict as M import Data.Hashable import qualified Control.Monad.Parallel as Par -import System.Plugins.Load import qualified Carrion.Plugin.IO.STDIO as CPISTDIO import qualified Carrion.Plugin.TCL as TCLSIMP -import Prelude hiding ((++),putStrLn) -import Data.Text.IO(putStrLn) +import Prelude hiding ((++),putStrLn,putStr) +import Data.Text.IO(putStrLn, putStr) import Debug.Trace data Placeholder = Placeholder -data CommandMap = CommandMap (M.Map T.Text Placeholder) +data CommandMap = CommandMap {getCommandMap :: M.Map Int T.Text} data CommandWorkspace = CommandWorkspace Placeholder data Sewer = Sewer {getSewerMap :: M.Map Int Manhole} +data IOPIDS = IOPIDS [Int] + +(++) :: T.Text -> T.Text -> T.Text a ++ b = T.append a b +lookupPluginNameByCommand + :: TMVar CommandMap -> T.Text -> STM (Maybe T.Text) +lookupPluginNameByCommand m c = do + m <- readTMVar m + case T.breakOn " " c of + (sic,_) -> return $ M.lookup (hash sic) (getCommandMap m) + +registerCommands :: TMVar(CommandMap) -> T.Text -> [T.Text] -> STM () +registerCommands m pn tellFunc = do + m' <- takeTMVar m + let ncm = M.unions (map (\com -> M.insert (hash com) pn (getCommandMap m')) $ tellFunc) + putTMVar m (CommandMap ncm) + + sharedDataPath :: IO FilePath sharedDataPath = getXdgDirectory XdgData "gypsfulvus" >>= makeAbsolute @@ -48,22 +64,19 @@ lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole) lookupManholeInSewer s p = do s_l <- readTMVar s return $ M.lookup (hash p) (getSewerMap s_l) - -dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined --- broadcast ouputs from routines to all (interested) parties -broadcastToConsumers consumerBroadcastChannel sharedCommandWorkspace sharedTaskQueue = undefined --- collect all input from all comms plugins and queue for dispatch -collectInputs collectorChannel availableCommandMap sharedCommandWorkspace sharedTaskQueue = undefined - --- load all the routines that the bot can run (e.g. run tcl code, calculator, youtube, etc.) -loadLabourPlugins availableCommandMap = undefined --- thread to pass any work to be done corePlugName :: T.Text corePlugName = "core" -runForever :: TMVar Sewer -> IO () -runForever s = + +isIOPlugin :: Sewage -> TMVar IOPIDS -> IO Bool +isIOPlugin sewage iopids = let pname = (hash . getName .nsAutorToGenericAutor . getSewageAutor $ sewage) + in do + IOPIDS iop <- atomically $ readTMVar iopids + return $ pname `elem` iop + +runForever :: TMVar Sewer -> TMVar(CommandMap) -> TMVar(IOPIDS) -> IO () +runForever s cmap iopids = let block = do mh <- lookupManholeInSewer s corePlugName case mh of @@ -73,24 +86,28 @@ runForever s = someGarbage <- atomically block let theAutor = show $ getSewageAutor someGarbage let theSewage = getSewage someGarbage - threadDelay 1000000 - if (theAutor == "local:STDIO haskeline@local") then - if ("tcl " `T.isPrefixOf` theSewage) then - sendToTCL s someGarbage - else - return () + amIIO <- isIOPlugin someGarbage iopids + if (amIIO) then + trySendToWorker s someGarbage cmap else do putStrLn $ T.pack theAutor ++ " sez:" - putStrLn theSewage -sendToTCL sewer sewage = do - m <- atomically $ lookupManholeInSewer sewer "TCL-Simple" - case m of - Just m -> regift' sewage m - Nothing -> putStrLn "couldn't find TCL submodule" - -registerComms = undefined + putStrLn $ theSewage + +trySendToWorker + :: TMVar Sewer -> Sewage -> TMVar CommandMap -> IO () +trySendToWorker sewer sewage cmap = do + let sewage' = getSewage sewage + pn <- atomically $ lookupPluginNameByCommand cmap sewage' + case pn of + Just pn' -> do + pm <- atomically $ lookupManholeInSewer sewer pn' + case pm of + Just m -> regiftToWorker sewage m + Nothing -> putStrLn $ "couldn't find channel to " ++ pn' + Nothing -> putStrLn $ "Couldn't find plugin for command " ++ sewage' + + -listDirectory' = listDirectory makeManhole :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole) makeManhole s p = do @@ -102,16 +119,6 @@ makeManhole s p = do return $ Just $ Manhole pluginInputChan coreInputChan Nothing -> return Nothing -makeManhole' :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole) -makeManhole' s p = do - coreManhole <- atomically $ lookupManholeInSewer s corePlugName - case coreManhole of - Just cm -> do - coreInputChan <- return $ getInputChan cm - pluginInputChan <- atomically $ newTChan - return $ Just $ Manhole pluginInputChan coreInputChan - Nothing -> return Nothing - tryRegisterPlugin :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus tryRegisterPlugin s plugName initFunc tellCommandsFunc = do @@ -126,84 +133,37 @@ tryRegisterPlugin s plugName initFunc tellCommandsFunc = do BadInitStatus errs -> return $ BadInitStatus $ "couldn't load the " ++ plugName ++ " plugin: " ++ errs Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected." -tryRegisterTCLPlugin :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus -tryRegisterTCLPlugin 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." - - -tryRegisterIOPlugin :: TMVar(Sewer) -> IO InitStatus -tryRegisterIOPlugin s = do - let plugName = "STDIO" - im <- makeManhole s plugName - case im of - Just im' -> do - stdioModuleStatus <- CPISTDIO.initPlugin im' - case stdioModuleStatus of - GoodInitStatus -> do - atomically $ assCallbackWithManholeInSewer s plugName im' - return GoodInitStatus - BadInitStatus errs -> return $ BadInitStatus $ "couldn't load stdio plugin: " ++ errs - Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected." -loadCoreCommands = undefined +makeNewSewer :: Manhole -> IO (TMVar Sewer) makeNewSewer coreManhole = do let plugName = "core" emptySewer <- atomically $ newTMVar $ Sewer M.empty atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole + +regiop :: Hashable a => a -> TMVar IOPIDS -> STM () +regiop pn iopids = do + IOPIDS iopids' <- takeTMVar iopids + putTMVar iopids (IOPIDS $ (hash pn):iopids') +stdioPlugName :: T.Text +stdioPlugName = "STDIO haskeline" + +tclPlugName :: T.Text +tclPlugName = "TCL-Simple" execMain :: IO () execMain = do 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 "STDIO" CPISTDIO.initPlugin CPISTDIO.tellCommands - tryRegisterTCLPlugin newSewer "TCL-Simple" TCLSIMP.initPlugin TCLSIMP.tellCommands - canary <- atomically $ newTMVar False -- simple 'should I exit' canary - --- forkIO $ loadCommsPlugins canary collectorChannel - --- availableCommandMap <- atomically $ newTMVar CommandMap --- loadLabourPlugins availableCommandMap --- sharedCommandWorkspace <- atomically $ newTMVar CommandWorkspace --- sharedTaskQueue <- atomically $ newTChan --- dispatchTID <- forkIO $ dispatchCommands sharedCommandWorkspace sharedTaskQueue --- broadcastTID <- forkIO $ broadcastToConsumers consumerBroadcastChannel sharedCommandWorkspace sharedTaskQueue --- collectorTID <- forkIO $ collectInputs collectorChannel availableCommandMap sharedCommandWorkspace sharedTaskQueue --- myTIDs = [dispatchTID,broadcastTID,collectorTID] + tryRegisterPlugin newSewer stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands + atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands + atomically $ regiop stdioPlugName iopids + tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands + atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands let myTIDs = [] - runForever newSewer + runForever newSewer commandMap iopids mapM_ killThread myTIDs - - - - ---makePluginsForgetThis canary collectorChannel = --- let potentialPlugins = srcPluginPath >>= \pp -> listDirectory pp >>= filterM (\fuku -> doesDirectoryExist (pp ++ "/" ++ fuku)) >>= mapM (\fuku -> return (pp ++ "/" ++ fuku)) --- in do --- srcPluginPath >>= putStrLn --- srcPluginPath >>= listDirectory >>= mapM putStrLn --- srcPluginPath >>= \pp -> listDirectory pp >>= filterM (\fuku -> putStrLn (pp ++ "/" ++ fuku) >> doesDirectoryExist (pp ++ "/" ++ fuku)) --- pp <- potentialPlugins --- mapM_ putStrLn pp --- ff <- mapM (\d -> findFile [d] "Plugin.hs") pp --- let rff = map (fromMaybe "") $ filter (/= Nothing) ff --- s <- mapM (\hng -> makeAll hng ["-v","-dynamic"]) rff --- mapM (\s' -> case s' of --- MakeSuccess _ p -> putStrLn p --- MakeFailure e -> putStrLn $ show e) s --- _ <- atomically $ swapTMVar canary True - -- I don't actually want to quit here but I don't like errors from STM heuristics when the canary is GCed - --- return () --- end makePluginsForgetThis diff --git a/src/GypsFulvus/PluginStuff.hs b/src/GypsFulvus/PluginStuff.hs index 233da3b..aaedee4 100644 --- a/src/GypsFulvus/PluginStuff.hs +++ b/src/GypsFulvus/PluginStuff.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regift') where +module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regiftToWorker) where import Control.Monad -import System.Plugins.Make + import Data.Maybe import Control.Concurrent.STM import Control.Concurrent.STM.TMVar @@ -14,11 +14,13 @@ a ♯ b = (T.append) a b tooTeToSt :: T.Text -> T.Text -> String tooTeToSt a b = tup $ a ♯ "@" ♯ b + stripCommandPrefix :: T.Text -> [T.Text] -> Either [Maybe T.Text] (Maybe T.Text) stripCommandPrefix c = uniqueHit . filter (/= Nothing) . map (\cs -> T.stripPrefix cs (c ♯ " ")) where uniqueHit cs = if (L.length cs == (1 :: Int)) then Right $ head cs else Left cs + stripCommandPrefix' :: T.Text -> [T.Text] -> Manhole -> SewageAutorInfo -> IO (Maybe T.Text) stripCommandPrefix' c ccs m sig = case stripCommandPrefix c ccs of @@ -26,10 +28,13 @@ stripCommandPrefix' c ccs m sig = case stripCommandPrefix c ccs of Left cs -> do sew <- regift (Sewage sig (if L.null cs then ("No such command: " ♯ c) else ("Found multiple matching commands: " ♯ ((L.foldr1 (\h ng -> h ♯ ", " ♯ ng)) $ (map (fromMaybe "")) cs)))) m return Nothing + tp :: String -> T.Text tp = T.pack + tup :: T.Text -> String tup = T.unpack + data IrcMask = IrcMask { getIdent:: T.Text, getHostname :: T.Text} @@ -61,6 +66,7 @@ type Nickname = T.Text type NetworkIdent = T.Text type NetworkHostname = T.Text type NetworkChannel = T.Text + makeNetworkIdentStyleAutor :: Nickname -> NetworkIdent -> NetworkHostname -> NetworkChannel -> SewageAutorInfo makeNetworkIdentStyleAutor n i h c = NetworkIdentStyleAutor n (IrcMask i h) c @@ -76,7 +82,9 @@ data InitStatus = GoodInitStatus | BadInitStatus T.Text inspectManhole :: Manhole -> IO Sewage inspectManhole = atomically . readTChan . getInputChan + regift :: Sewage -> Manhole -> IO () regift g = atomically . (flip writeTChan g) . getOutputChan -regift' :: Sewage -> Manhole -> IO () -regift' g = atomically . (flip writeTChan g) . getInputChan + +regiftToWorker :: Sewage -> Manhole -> IO () +regiftToWorker g = atomically . (flip writeTChan g) . getInputChan