shaniqua-core/src/GypsFulvus.hs

205 lines
7.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module GypsFulvus(execMain) where
import Control.Concurrent.STM
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TChan
import System.Directory
import qualified Data.Text as T
import Control.Concurrent(ThreadId, forkIO, killThread, threadDelay)
import GypsFulvus.PluginStuff
import Control.Monad(liftM,filterM,forever)
import Control.Monad.IO.Class
import qualified Data.Map.Strict as M
import Data.Hashable
import qualified Control.Monad.Parallel as Par
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
import qualified Carrion.Plugin.TCL as TCLSIMP
import qualified Carrion.Plugin.IO.IRC.Client as IRCSIMP
import Prelude hiding ((++),putStrLn,putStr)
import Data.Text.IO(putStrLn, putStr)
import Debug.Trace
data Placeholder = 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
configPath :: IO FilePath
configPath = getXdgDirectory XdgConfig "gypsfulvus" >>= makeAbsolute
assCallbackWithManholeInSewer
:: Hashable a1 =>
TMVar (Sewer)
-> a1 -> Manhole -> STM (TMVar Sewer)
assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
sewer_old <- takeTMVar sewer
h_cname <- return $ hash callback_name
let newSewer =Sewer $ M.insert h_cname callback_manhole (getSewerMap sewer_old)
putTMVar sewer $ newSewer
return sewer
lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
lookupManholeInSewer s p = do
s_l <- readTMVar s
return $ M.lookup (hash p) (getSewerMap s_l)
corePlugName :: T.Text
corePlugName = "core"
mySignature :: SewageAutorInfo
mySignature = GenericStyleAutor corePlugName "local" "local"
isIOPlugin :: Sewage -> TMVar IOPIDS -> IO Bool
isIOPlugin sewage iopids = let pname = (hash . getLocation .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
Just mh' -> readTChan $ getInputChan mh'
Nothing -> retry
in forever $ do
someGarbage <- atomically block
let theAutor = show $ getSewageAutor someGarbage
let theSewage = getSewage someGarbage
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 ()
putStrLn $ T.pack theAutor ++ " sez:"
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'
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
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
makeNewSewer :: Manhole -> IO (TMVar Sewer)
makeNewSewer coreManhole = do
let
plugName = corePlugName
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"
ircPlugName :: T.Text
ircPlugName = "IRC-Simple"
statusBad s = case s of
GoodInitStatus -> False
BadInitStatus _ -> True
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]
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
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 ()
let myTIDs = []
runForever newSewer commandMap iopids
mapM_ killThread myTIDs