shaniqua-core/src/GypsFulvus.hs

155 lines
6.0 KiB
Haskell
Raw Normal View History

2020-09-22 16:52:52 +02:00
{-# LANGUAGE OverloadedStrings #-}
module GypsFulvus(execMain) where
2020-09-20 20:41:30 +02:00
import Control.Concurrent.STM
2020-09-12 21:44:21 +02:00
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TChan
2020-09-20 20:41:30 +02:00
import System.Directory
2020-09-12 21:44:21 +02:00
import qualified Data.Text as T
import Control.Concurrent(ThreadId, forkIO, killThread)
import GypsFulvus.PluginStuff
2020-09-22 16:52:52 +02:00
import Control.Monad(liftM,filterM,forever)
2020-09-21 22:51:27 +02:00
import Control.Monad.IO.Class
2020-09-20 20:41:30 +02:00
import qualified Data.Map.Strict as M
import Data.Hashable
2020-09-21 00:05:58 +02:00
import qualified Control.Monad.Parallel as Par
import System.Plugins.Load
2020-09-22 16:52:52 +02:00
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
import Prelude hiding ((++),putStrLn)
import Data.Text.IO(putStrLn)
2020-09-12 21:44:21 +02:00
data Placeholder = Placeholder
data CommandMap = CommandMap (M.Map T.Text Placeholder)
data CommandWorkspace = CommandWorkspace Placeholder
2020-09-21 22:51:27 +02:00
data Sewer = Sewer {getSewerMap :: M.Map Int Manhole}
2020-09-22 16:52:52 +02:00
a ++ b = T.append a b
2020-09-12 21:44:21 +02:00
2020-09-22 16:52:52 +02:00
sharedDataPath :: IO FilePath
sharedDataPath = getXdgDirectory XdgData "gypsfulvus" >>= makeAbsolute
2020-09-20 20:41:30 +02:00
configPath :: IO FilePath
2020-09-22 16:52:52 +02:00
configPath = getXdgDirectory XdgConfig "gypsfulvus" >>= makeAbsolute
2020-09-20 20:41:30 +02:00
assCallbackWithManholeInSewer
:: Hashable a1 =>
2020-09-21 22:51:27 +02:00
TMVar (Sewer)
-> a1 -> Manhole -> STM (TMVar Sewer)
2020-09-20 20:41:30 +02:00
assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
sewer_old <- takeTMVar sewer
h_cname <- return $ hash callback_name
2020-09-21 22:51:27 +02:00
let newSewer =Sewer $ M.insert h_cname callback_manhole (getSewerMap sewer_old)
putTMVar sewer $ newSewer
return sewer
2020-09-22 16:52:52 +02:00
lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
2020-09-21 00:05:58 +02:00
lookupManholeInSewer s p = do
s_l <- readTMVar s
2020-09-21 22:51:27 +02:00
return $ M.lookup (hash p) (getSewerMap s_l)
2020-09-20 20:41:30 +02:00
2020-09-12 21:44:21 +02:00
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
2020-09-20 20:41:30 +02:00
-- 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
2020-09-22 16:52:52 +02:00
corePlugName :: T.Text
corePlugName = "core"
2020-09-20 20:41:30 +02:00
2020-09-22 16:52:52 +02:00
runForever :: TMVar Sewer -> IO ()
runForever s =
2020-09-12 21:44:21 +02:00
let block = do
2020-09-22 16:52:52 +02:00
mh <- lookupManholeInSewer s corePlugName
case mh of
Just mh' -> readTChan $ getInputChan mh'
Nothing -> retry
in forever $ do
someGarbage <- atomically block
let theAutor = show $ getSewageAutor someGarbage
putStrLn $ (T.pack theAutor) ++ " sez:"
putStrLn $ getSewage someGarbage
2020-09-12 21:44:21 +02:00
registerComms = undefined
2020-09-21 22:51:27 +02:00
listDirectory' = listDirectory
2020-09-21 00:05:58 +02:00
2020-09-21 22:51:27 +02:00
makeInputManhole :: TMVar(Sewer) -> String -> IO (Maybe Manhole)
2020-09-21 00:05:58 +02:00
makeInputManhole s p = do
2020-09-22 16:52:52 +02:00
coreManhole <- atomically $ lookupManholeInSewer s corePlugName
2020-09-21 00:05:58 +02:00
case coreManhole of
Just cm -> do
coreInputChan <- return $ getInputChan cm
2020-09-21 22:51:27 +02:00
pluginInputChan <- atomically $ newTChan
2020-09-21 00:05:58 +02:00
return $ Just $ Manhole pluginInputChan coreInputChan
Nothing -> return Nothing
2020-09-21 22:51:27 +02:00
2020-09-22 16:52:52 +02:00
tryRegisterIOPlugin :: TMVar(Sewer) -> IO InitStatus
tryRegisterIOPlugin s = do
let plugName = "STDIO"
im <- makeInputManhole s plugName
2020-09-21 00:05:58 +02:00
case im of
Just im' -> do
2020-09-22 16:52:52 +02:00
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
2020-09-21 00:05:58 +02:00
Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected."
2020-09-20 20:41:30 +02:00
loadCoreCommands = undefined
2020-09-12 21:44:21 +02:00
2020-09-21 22:51:27 +02:00
makeNewSewer coreManhole = do
2020-09-22 16:52:52 +02:00
let
plugName = "core"
2020-09-21 22:51:27 +02:00
emptySewer <- atomically $ newTMVar $ Sewer M.empty
2020-09-22 16:52:52 +02:00
atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole
2020-09-21 22:51:27 +02:00
2020-09-12 21:44:21 +02:00
execMain :: IO ()
execMain = do
2020-09-20 20:41:30 +02:00
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
2020-09-21 22:51:27 +02:00
newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel
2020-09-22 16:52:52 +02:00
tryRegisterIOPlugin newSewer
2020-09-12 21:44:21 +02:00
canary <- atomically $ newTMVar False -- simple 'should I exit' canary
2020-09-20 20:41:30 +02:00
-- forkIO $ loadCommsPlugins canary collectorChannel
2020-09-12 23:56:49 +02:00
-- 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 = []
2020-09-22 16:52:52 +02:00
runForever newSewer
2020-09-12 23:56:49 +02:00
mapM_ killThread myTIDs
2020-09-20 20:41:30 +02:00
--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