From acb4abe9acf26ccf800af988d4083c3cedd12535 Mon Sep 17 00:00:00 2001 From: Jon Doe Date: Mon, 21 Sep 2020 22:51:27 +0200 Subject: [PATCH] doesnt work --- GypsFulvus.cabal | 2 ++ src/GypsFulvus.hs | 57 ++++++++++++++++++++++++++++++++++------------- 2 files changed, 44 insertions(+), 15 deletions(-) diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index cea76c2..d9f8d52 100644 --- a/GypsFulvus.cabal +++ b/GypsFulvus.cabal @@ -31,6 +31,7 @@ library -O2 -threaded -with-rtsopts=-N + -g executable GypsFulvus default-language: Haskell2010 @@ -47,6 +48,7 @@ executable GypsFulvus -O2 -threaded -with-rtsopts=-N + -g hs-source-dirs: src other-modules: GypsFulvus, GypsFulvus.PluginStuff main-is: Main.hs diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index 5814861..f97ba63 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -7,6 +7,7 @@ import qualified Data.Text as T import Control.Concurrent(ThreadId, forkIO, killThread) import GypsFulvus.PluginStuff import Control.Monad(liftM,filterM) +import Control.Monad.IO.Class import qualified Data.Map.Strict as M import Data.Hashable import qualified Control.Monad.Parallel as Par @@ -14,7 +15,7 @@ import System.Plugins.Load data Placeholder = Placeholder data CommandMap = CommandMap (M.Map T.Text Placeholder) data CommandWorkspace = CommandWorkspace Placeholder -data Sewer = Sewer (M.Map Int Manhole) +data Sewer = Sewer {getSewerMap :: M.Map Int Manhole} srcPluginPath :: IO FilePath @@ -22,6 +23,8 @@ srcPluginPath = getXdgDirectory XdgData "gypsfulvus/srcplugins" >>= makeAbsolute binPluginPath :: IO FilePath binPluginPath = getXdgDirectory XdgData "gypsfulvus/srcplugins" >>= makeAbsolute +ioBinPluginPath :: IO FilePath +ioBinPluginPath = getXdgDirectory XdgData "gypsfulvus/binplugins/io" >>= makeAbsolute configPath :: IO FilePath configPath = getXdgDirectory XdgConfig "gypsfulvus" @@ -30,15 +33,18 @@ configPath = getXdgDirectory XdgConfig "gypsfulvus" assCallbackWithManholeInSewer :: Hashable a1 => - TMVar (M.Map Int Manhole) - -> a1 -> Manhole -> STM () + TMVar (Sewer) + -> a1 -> Manhole -> STM (TMVar Sewer) assCallbackWithManholeInSewer sewer callback_name callback_manhole = do sewer_old <- takeTMVar sewer h_cname <- return $ hash callback_name - putTMVar sewer $ M.insert h_cname callback_manhole sewer_old + let newSewer =Sewer $ M.insert h_cname callback_manhole (getSewerMap sewer_old) + putTMVar sewer $ newSewer + return sewer + lookupManholeInSewer s p = do s_l <- readTMVar s - return $ M.lookup (hash p) s_l + return $ M.lookup (hash p) (getSewerMap s_l) dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined -- broadcast ouputs from routines to all (interested) parties @@ -64,35 +70,56 @@ runForever diediedie = if (isDone) then putStrLn "Exiting cleanly." else error "I escaped my eternal prison somehow." -- it shouldn't be possible for the else to be reached unless something melts down registerComms = undefined +listDirectory' = listDirectory + +loadIOBackends :: TMVar (Sewer) -> IO () loadIOBackends sewer = do - potentialPlugins <- binPluginPath >>= \pp -> listDirectory pp >>= \xs -> filterM (\sd -> doesDirectoryExist (pp ++ "/" ++ sd)) xs >>= \xs' -> return $ Par.mapM (\sd -> pp ++ "/" ++ sd) xs' - Par.mapM (\pp -> atomically $ tryRegisterIOPlugin sewer pp) potentialPlugins + potentialPlugins <- do + pp <- ioBinPluginPath + xs <- listDirectory pp + xs' <- filterM (\sd -> doesDirectoryExist (pp ++ "/" ++ sd)) xs + Par.mapM (\sind -> return $ ((pp ++ "/" ++ sind), sind)) xs' + Par.mapM (\(pp,sd) -> tryRegisterIOPlugin sewer pp sd) potentialPlugins return () - +makeInputManhole :: TMVar(Sewer) -> String -> IO (Maybe Manhole) makeInputManhole s p = do - coreManhole <- lookupManholeInSewer s "core" + coreManhole <- atomically $ lookupManholeInSewer s "core" case coreManhole of Just cm -> do coreInputChan <- return $ getInputChan cm - pluginInputChan <- newTChan + pluginInputChan <- atomically $ newTChan return $ Just $ Manhole pluginInputChan coreInputChan Nothing -> return Nothing - -tryRegisterIOPlugin s p = do - im <- makeInputManhole s p + +tryRegisterIOPlugin :: TMVar(Sewer) -> FilePath -> String -> IO InitStatus +tryRegisterIOPlugin s pp pn = do + im <- makeInputManhole s pn case im of Just im' -> do - assCallbackWithManholeInSewer s p im' +-- let initPluginLoad :: IO ( LoadStatus Module (Manhole -> IO InitStatus)) + putStrLn $ pp ++ "/" ++ pn ++ ".o" + initPluginLoad <- load_ (pp ++ "/" ++ pn ++ ".o") ["/usr/lib","/usr","/home/pszczola/.stack","/home/pszczola/.stack/programs/x86_64-linux/ghc-tinfo6-8.8.4/lib/ghc-8.8.4/base-4.13.0.0","/home/pszczola/.stack/programs/x86_64-linux/ghc-tinfo6-8.8.4/lib/ghc-8.8.4/base-4.13.0.0", "/home/pszczola/.stack/programs/x86_64-linux/ghc-tinfo6-8.8.4/lib/ghc-8.8.4/base-4.13.0.0/libHSbase-4.13.0.0-ghc8.8.4.so","/home/pszczola/Carrion-Plugin-IO-STDIO/.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.0.1.0/build/","/home/pszczola/Carrion-Plugin-IO-STDIO/.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.0.1.0/","/usr/lib/ghc-8.10.2/base-4.14.1.0/"] "initPlugin" + case initPluginLoad of + LoadSuccess m sym -> putStrLn "loaded symbol initPlugin for pn" + LoadFailure e -> mapM putStrLn e >> return () +-- initPlugin <- initPluginLoad + atomically $ assCallbackWithManholeInSewer s pn im' return GoodInitStatus Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected." loadCoreCommands = undefined +makeNewSewer coreManhole = do + emptySewer <- atomically $ newTMVar $ Sewer M.empty + atomically $ assCallbackWithManholeInSewer (emptySewer) "core" coreManhole + + 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 - + newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel + loadIOBackends newSewer canary <- atomically $ newTMVar False -- simple 'should I exit' canary -- forkIO $ loadCommsPlugins canary collectorChannel