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
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,

View File

@ -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

View File

@ -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

View File

@ -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