shaniqua-core/src/GypsFulvus.hs

205 lines
7.2 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
2020-09-22 22:09:59 +02:00
import Control.Concurrent(ThreadId, forkIO, killThread, threadDelay)
2020-09-12 21:44:21 +02:00
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
2020-09-22 16:52:52 +02:00
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
2020-09-22 22:09:59 +02:00
import qualified Carrion.Plugin.TCL as TCLSIMP
2020-09-26 21:26:42 +02:00
import qualified Carrion.Plugin.IO.IRC.Client as IRCSIMP
2020-09-24 20:03:10 +02:00
import Prelude hiding ((++),putStrLn,putStr)
import Data.Text.IO(putStrLn, putStr)
2020-09-22 22:09:59 +02:00
import Debug.Trace
2020-09-12 21:44:21 +02:00
data Placeholder = Placeholder
2020-09-24 20:03:10 +02:00
data CommandMap = CommandMap {getCommandMap :: M.Map Int T.Text}
2020-09-12 21:44:21 +02:00
data CommandWorkspace = CommandWorkspace Placeholder
2020-09-21 22:51:27 +02:00
data Sewer = Sewer {getSewerMap :: M.Map Int Manhole}
2020-09-24 20:03:10 +02:00
data IOPIDS = IOPIDS [Int]
(++) :: T.Text -> T.Text -> T.Text
2020-09-22 16:52:52 +02:00
a ++ b = T.append a b
2020-09-12 21:44:21 +02:00
2020-09-24 20:03:10 +02:00
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)
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-23 20:17:56 +02:00
return $ M.lookup (hash p) (getSewerMap s_l)
2020-09-24 20:03:10 +02:00
2020-09-22 16:52:52 +02:00
corePlugName :: T.Text
corePlugName = "core"
mySignature :: SewageAutorInfo
mySignature = GenericStyleAutor corePlugName "local" "local"
2020-09-24 20:03:10 +02:00
isIOPlugin :: Sewage -> TMVar IOPIDS -> IO Bool
isIOPlugin sewage iopids = let pname = (hash . getLocation .nsAutorToGenericAutor . getSewageAutor $ sewage)
2020-09-24 20:03:10 +02:00
in do
IOPIDS iop <- atomically $ readTMVar iopids
2020-09-24 20:03:10 +02:00
return $ pname `elem` iop
runForever :: TMVar Sewer -> TMVar(CommandMap) -> TMVar(IOPIDS) -> IO ()
runForever s cmap iopids =
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
2020-09-22 22:09:59 +02:00
let theSewage = getSewage someGarbage
2020-09-24 20:03:10 +02:00
amIIO <- isIOPlugin someGarbage iopids
if (amIIO) then
trySendToWorker s someGarbage cmap
else do
pm <- atomically $ lookupManholeInSewer s (getName . nsAutorToGenericAutor . getSewageAutor $ someGarbage)
case pm of
Just pm -> regiftToWorker someGarbage pm
Nothing -> return ()
2020-09-26 21:26:42 +02:00
putStrLn $ T.pack theAutor ++ " sez:"
putStrLn $ theSewage
2020-09-24 20:03:10 +02:00
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'
2020-09-21 00:05:58 +02:00
2020-09-22 22:09:59 +02:00
makeManhole :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole)
makeManhole 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 22:09:59 +02:00
2020-09-12 21:44:21 +02:00
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
2020-09-24 20:03:10 +02:00
makeNewSewer :: Manhole -> IO (TMVar Sewer)
2020-09-21 22:51:27 +02:00
makeNewSewer coreManhole = do
2020-09-22 16:52:52 +02:00
let
plugName = corePlugName
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-24 20:03:10 +02:00
regiop :: Hashable a => a -> TMVar IOPIDS -> STM ()
regiop pn iopids = do
IOPIDS iopids' <- takeTMVar iopids
putTMVar iopids (IOPIDS $ (hash pn):iopids')
2020-09-21 22:51:27 +02:00
2020-09-24 20:03:10 +02:00
stdioPlugName :: T.Text
stdioPlugName = "STDIO haskeline"
tclPlugName :: T.Text
tclPlugName = "TCL-Simple"
2020-09-26 21:26:42 +02:00
ircPlugName :: T.Text
ircPlugName = "IRC-Simple"
2020-09-21 22:51:27 +02:00
statusBad s = case s of
GoodInitStatus -> False
BadInitStatus _ -> True
2020-09-12 21:44:21 +02:00
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]
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-24 20:03:10 +02:00
commandMap <- atomically $ newTMVar $ CommandMap M.empty
iopids <- atomically $ newTMVar $ IOPIDS []
2020-09-21 22:51:27 +02:00
newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel
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 ()
2020-09-12 23:56:49 +02:00
let myTIDs = []
2020-09-24 20:03:10 +02:00
runForever newSewer commandMap iopids
2020-09-12 23:56:49 +02:00
mapM_ killThread myTIDs