This commit is contained in:
Jon Doe 2020-09-24 20:03:10 +02:00 committed by Maciej Bonin
parent f874b97291
commit 3a85db15d3
4 changed files with 82 additions and 116 deletions

View File

@ -14,8 +14,8 @@ cabal-version: >=1.10
extra-source-files: README.md extra-source-files: README.md
library library
exposed-modules: GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL exposed-modules: GypsFulvus, GypsFulvus.PluginStuff, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL
other-modules: GypsFulvus.PluginStuff other-modules:
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
build-depends: build-depends:
@ -23,7 +23,6 @@ library
stm, stm,
containers, containers,
text, text,
plugins >= 1.6.0,
directory, directory,
hashable, hashable,
monad-parallel, monad-parallel,
@ -46,7 +45,6 @@ executable GypsFulvus
stm, stm,
containers, containers,
text, text,
plugins >= 1.6.0,
directory, directory,
hashable, hashable,
monad-parallel, monad-parallel,

View File

@ -55,7 +55,7 @@ tu :: T.Text -> String
tu = T.unpack tu = T.unpack
tellCommands :: [T.Text] tellCommands :: [T.Text]
tellCommands = map T.pack ["tcl"] tellCommands = map T.pack ["tcl"]
myPluginName = T.pack "TCL smeggdrop" myPluginName = T.pack "TCL-Simple"
tl :: T.Text tl :: T.Text
tl = T.pack "local" tl = T.pack "local"
mySignature :: SewageAutorInfo mySignature :: SewageAutorInfo

View File

@ -12,19 +12,35 @@ import Control.Monad.IO.Class
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Hashable import Data.Hashable
import qualified Control.Monad.Parallel as Par import qualified Control.Monad.Parallel as Par
import System.Plugins.Load
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
import qualified Carrion.Plugin.TCL as TCLSIMP import qualified Carrion.Plugin.TCL as TCLSIMP
import Prelude hiding ((++),putStrLn) import Prelude hiding ((++),putStrLn,putStr)
import Data.Text.IO(putStrLn) import Data.Text.IO(putStrLn, putStr)
import Debug.Trace import Debug.Trace
data Placeholder = Placeholder 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 CommandWorkspace = CommandWorkspace Placeholder
data Sewer = Sewer {getSewerMap :: M.Map Int Manhole} data Sewer = Sewer {getSewerMap :: M.Map Int Manhole}
data IOPIDS = IOPIDS [Int]
(++) :: T.Text -> T.Text -> T.Text
a ++ b = T.append a b 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 :: IO FilePath
sharedDataPath = getXdgDirectory XdgData "gypsfulvus" >>= makeAbsolute sharedDataPath = getXdgDirectory XdgData "gypsfulvus" >>= makeAbsolute
@ -48,22 +64,19 @@ lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
lookupManholeInSewer s p = do lookupManholeInSewer s p = do
s_l <- readTMVar s s_l <- readTMVar s
return $ M.lookup (hash p) (getSewerMap s_l) 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 :: T.Text
corePlugName = "core" 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 let block = do
mh <- lookupManholeInSewer s corePlugName mh <- lookupManholeInSewer s corePlugName
case mh of case mh of
@ -73,24 +86,28 @@ runForever s =
someGarbage <- atomically block someGarbage <- atomically block
let theAutor = show $ getSewageAutor someGarbage let theAutor = show $ getSewageAutor someGarbage
let theSewage = getSewage someGarbage let theSewage = getSewage someGarbage
threadDelay 1000000 amIIO <- isIOPlugin someGarbage iopids
if (theAutor == "local:STDIO haskeline@local") then if (amIIO) then
if ("tcl " `T.isPrefixOf` theSewage) then trySendToWorker s someGarbage cmap
sendToTCL s someGarbage
else
return ()
else do else do
putStrLn $ T.pack theAutor ++ " sez:" putStrLn $ T.pack theAutor ++ " sez:"
putStrLn theSewage putStrLn $ theSewage
sendToTCL sewer sewage = do
m <- atomically $ lookupManholeInSewer sewer "TCL-Simple" trySendToWorker
case m of :: TMVar Sewer -> Sewage -> TMVar CommandMap -> IO ()
Just m -> regift' sewage m trySendToWorker sewer sewage cmap = do
Nothing -> putStrLn "couldn't find TCL submodule" let sewage' = getSewage sewage
pn <- atomically $ lookupPluginNameByCommand cmap sewage'
registerComms = undefined 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 :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole)
makeManhole s p = do makeManhole s p = do
@ -102,16 +119,6 @@ makeManhole s p = do
return $ Just $ Manhole pluginInputChan coreInputChan return $ Just $ Manhole pluginInputChan coreInputChan
Nothing -> return Nothing 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 :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus
tryRegisterPlugin s plugName initFunc tellCommandsFunc = do 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 BadInitStatus errs -> return $ BadInitStatus $ "couldn't load the " ++ plugName ++ " plugin: " ++ errs
Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected." 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 makeNewSewer coreManhole = do
let let
plugName = "core" plugName = "core"
emptySewer <- atomically $ newTMVar $ Sewer M.empty emptySewer <- atomically $ newTMVar $ Sewer M.empty
atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole 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 :: IO ()
execMain = do execMain = do
collectorChannel <- atomically newTChan -- normal channel for dumping any user input, this is the output channel for all plugins 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 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 newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel
tryRegisterPlugin newSewer "STDIO" CPISTDIO.initPlugin CPISTDIO.tellCommands tryRegisterPlugin newSewer stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands
tryRegisterTCLPlugin newSewer "TCL-Simple" TCLSIMP.initPlugin TCLSIMP.tellCommands atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands
canary <- atomically $ newTMVar False -- simple 'should I exit' canary atomically $ regiop stdioPlugName iopids
tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands
-- forkIO $ loadCommsPlugins canary collectorChannel atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands
-- 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]
let myTIDs = [] let myTIDs = []
runForever newSewer runForever newSewer commandMap iopids
mapM_ killThread myTIDs 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

View File

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 Control.Monad
import System.Plugins.Make
import Data.Maybe import Data.Maybe
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TMVar
@ -14,11 +14,13 @@ a ♯ b = (T.append) a b
tooTeToSt :: T.Text -> T.Text -> String tooTeToSt :: T.Text -> T.Text -> String
tooTeToSt a b = tup $ a "@" b tooTeToSt a b = tup $ a "@" b
stripCommandPrefix stripCommandPrefix
:: T.Text -> [T.Text] -> Either [Maybe T.Text] (Maybe T.Text) :: T.Text -> [T.Text] -> Either [Maybe T.Text] (Maybe T.Text)
stripCommandPrefix c = uniqueHit . filter (/= Nothing) . map (\cs -> T.stripPrefix cs (c " ")) stripCommandPrefix c = uniqueHit . filter (/= Nothing) . map (\cs -> T.stripPrefix cs (c " "))
where where
uniqueHit cs = if (L.length cs == (1 :: Int)) then Right $ head cs else Left cs uniqueHit cs = if (L.length cs == (1 :: Int)) then Right $ head cs else Left cs
stripCommandPrefix' stripCommandPrefix'
:: T.Text -> [T.Text] -> Manhole -> SewageAutorInfo -> IO (Maybe T.Text) :: T.Text -> [T.Text] -> Manhole -> SewageAutorInfo -> IO (Maybe T.Text)
stripCommandPrefix' c ccs m sig = case stripCommandPrefix c ccs of 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 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 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 return Nothing
tp :: String -> T.Text tp :: String -> T.Text
tp = T.pack tp = T.pack
tup :: T.Text -> String tup :: T.Text -> String
tup = T.unpack tup = T.unpack
data IrcMask = IrcMask { data IrcMask = IrcMask {
getIdent:: T.Text, getIdent:: T.Text,
getHostname :: T.Text} getHostname :: T.Text}
@ -61,6 +66,7 @@ type Nickname = T.Text
type NetworkIdent = T.Text type NetworkIdent = T.Text
type NetworkHostname = T.Text type NetworkHostname = T.Text
type NetworkChannel = T.Text type NetworkChannel = T.Text
makeNetworkIdentStyleAutor makeNetworkIdentStyleAutor
:: Nickname -> NetworkIdent -> NetworkHostname -> NetworkChannel -> SewageAutorInfo :: Nickname -> NetworkIdent -> NetworkHostname -> NetworkChannel -> SewageAutorInfo
makeNetworkIdentStyleAutor n i h c = NetworkIdentStyleAutor n (IrcMask i h) c 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 :: Manhole -> IO Sewage
inspectManhole = atomically . readTChan . getInputChan inspectManhole = atomically . readTChan . getInputChan
regift :: Sewage -> Manhole -> IO () regift :: Sewage -> Manhole -> IO ()
regift g = atomically . (flip writeTChan g) . getOutputChan 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