diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index f400125..e0ea906 100644 --- a/GypsFulvus.cabal +++ b/GypsFulvus.cabal @@ -14,7 +14,7 @@ cabal-version: >=1.10 extra-source-files: README.md library - exposed-modules: GypsFulvus + exposed-modules: GypsFulvus, Carrion.Plugin.IO.STDIO other-modules: GypsFulvus.PluginStuff default-language: Haskell2010 hs-source-dirs: src @@ -33,6 +33,8 @@ library -threaded -with-rtsopts=-N -g + -keep-o-files + -keep-hi-files executable GypsFulvus default-language: Haskell2010 @@ -51,6 +53,31 @@ executable GypsFulvus -threaded -with-rtsopts=-N -g + -keep-o-files + -keep-hi-files hs-source-dirs: src - other-modules: GypsFulvus, GypsFulvus.PluginStuff + other-modules: GypsFulvus.PluginStuff,GypsFulvus, Carrion.Plugin.IO.STDIO + exposed-modules: GypsFulvus main-is: Main.hs + +executable Test-Carrion-Plugin-IO-STDIO + hs-source-dirs: src + main-is: Test-STDIO-Haskeline.hs + other-modules: Carrion.Plugin.IO.STDIO, GypsFulvus.PluginStuff + build-depends: base >= 4.7 && < 5, + stm, + text >= 1.2.4.0, + unix, + haskeline, + plugins, + directory, + containers, + hashable, + monad-parallel + default-language: Haskell2010 +-- ld-options: -static + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -g diff --git a/src/Carrion/Plugin/IO/STDIO.hs b/src/Carrion/Plugin/IO/STDIO.hs new file mode 100644 index 0000000..8415965 --- /dev/null +++ b/src/Carrion/Plugin/IO/STDIO.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +module Carrion.Plugin.IO.STDIO + ( initPlugin, + processCommand, + testThing, + tellCommands, + ) where +import Control.Monad.IO.Class +import Control.Monad +import Control.Concurrent(forkIO) +import Control.Concurrent.STM +import qualified Data.Text as T +import GypsFulvus.PluginStuff(Manhole(..),Sewage(..), InitStatus(..),SewageAutorInfo(..),genericAutorToNSAutor,inspectManhole,regift, stripCommandPrefix') +import System.Console.Haskeline +import Data.Maybe +import qualified Data.List as L +import Prelude hiding ((++)) + +a ++ b = T.append a b +testThing = runInputT defaultSettings loop + where + loop :: InputT IO () + loop = do + minput <- getInputLine "% " + case minput of + Nothing -> return () + Just "quit" -> return () + Just input -> do outputStrLn $ T.unpack ("Input was: " ++ T.pack input) + loop +mySignature = GenericStyleAutor "STDIO haskeline" "local" "local" +tellCommands = [""] + +stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature +initPlugin :: Manhole -> IO InitStatus +initPlugin manhole = do + + forkIO $ rEPL manhole + return GoodInitStatus + +processCommand = undefined + +processUserInputs = undefined +processCommandResults = undefined + +rEPL manhole = do + let getInputs = runInputT defaultSettings loop + fuku :: InputT IO () + fuku = do + aresult <- liftIO (inspectManhole manhole) + outputStrLn $ T.unpack . getSewage $ aresult + fuku + loop :: InputT IO () + loop = do + minput <- getInputLine "% " + case minput of + Nothing -> return () + Just "quit" -> return () + Just input -> do liftIO $ regift (Sewage mySignature (T.pack input)) manhole + loop + getResults = runInputT defaultSettings fuku + forkIO $ getInputs + forkIO $ getResults + return () diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index ba7c5ee..cc339a8 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -1,4 +1,5 @@ -module GypsFulvus(execMain, Manhole(..), Sewage(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, regift,stripCommandPrefix',inspectManhole) where +{-# LANGUAGE OverloadedStrings #-} +module GypsFulvus(execMain) where import Control.Concurrent.STM import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TChan @@ -6,28 +7,27 @@ import System.Directory import qualified Data.Text as T import Control.Concurrent(ThreadId, forkIO, killThread) import GypsFulvus.PluginStuff -import Control.Monad(liftM,filterM) +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 System.Plugins.Load +import qualified Carrion.Plugin.IO.STDIO as CPISTDIO +import Prelude hiding ((++),putStrLn) +import Data.Text.IO(putStrLn) data Placeholder = Placeholder data CommandMap = CommandMap (M.Map T.Text Placeholder) data CommandWorkspace = CommandWorkspace Placeholder data Sewer = Sewer {getSewerMap :: M.Map Int Manhole} +a ++ b = T.append a b -srcPluginPath :: IO FilePath -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 +sharedDataPath :: IO FilePath +sharedDataPath = getXdgDirectory XdgData "gypsfulvus" >>= makeAbsolute configPath :: IO FilePath -configPath = getXdgDirectory XdgConfig "gypsfulvus" +configPath = getXdgDirectory XdgConfig "gypsfulvus" >>= makeAbsolute @@ -41,7 +41,8 @@ assCallbackWithManholeInSewer sewer callback_name callback_manhole = do 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) @@ -56,35 +57,28 @@ collectInputs collectorChannel availableCommandMap sharedCommandWorkspace shared -- 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 Bool -> IO () -runForever diediedie = +runForever :: TMVar Sewer -> IO () +runForever s = let block = do - canaryDead <- readTMVar diediedie - if (canaryDead) then - return canaryDead - else - retry - in atomically block >>= \isDone -> - 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 + 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 registerComms = undefined listDirectory' = listDirectory - -loadIOBackends :: TMVar (Sewer) -> IO () -loadIOBackends sewer = do - 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 <- atomically $ lookupManholeInSewer s "core" + coreManhole <- atomically $ lookupManholeInSewer s corePlugName case coreManhole of Just cm -> do coreInputChan <- return $ getInputChan cm @@ -92,26 +86,26 @@ makeInputManhole s p = do return $ Just $ Manhole pluginInputChan coreInputChan Nothing -> return Nothing -tryRegisterIOPlugin :: TMVar(Sewer) -> FilePath -> String -> IO InitStatus -tryRegisterIOPlugin s pp pn = do - im <- makeInputManhole s pn +tryRegisterIOPlugin :: TMVar(Sewer) -> IO InitStatus +tryRegisterIOPlugin s = do + let plugName = "STDIO" + im <- makeInputManhole s plugName case im of Just im' -> do --- 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/haskeline-0.7.5.0/","/home/pszczola/.stack/programs/x86_64-linux/ghc-tinfo6-8.8.4/lib/ghc-8.8.4/haskeline-0.7.5.0/libHShaskeline-0.7.5.0-ghc8.8.4.so","/home/pszczola/.stack/snapshots/x86_64-linux-tinfo6/edde100bf8de6cb65f105b56e08069dfa3348c9270d546adc9aa73e98e3c573a/8.8.4/lib/x86_64-linux-ghc-8.8.4/","/home/pszczola/.stack/snapshots/x86_64-linux-tinfo6/edde100bf8de6cb65f105b56e08069dfa3348c9270d546adc9aa73e98e3c573a/8.8.4/lib/x86_64-linux-ghc-8.8.4/lib/","/home/pszczola/.stack/snapshots/x86_64-linux-tinfo6/edde100bf8de6cb65f105b56e08069dfa3348c9270d546adc9aa73e98e3c573a/8.8.4/lib/x86_64-linux-ghc-8.8.4/haskeline-0.8.1.0-2IMMl1Qcetx8pSusZdUu4N/"] "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 + 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 coreManhole = do + let + plugName = "core" emptySewer <- atomically $ newTMVar $ Sewer M.empty - atomically $ assCallbackWithManholeInSewer (emptySewer) "core" coreManhole + atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole execMain :: IO () @@ -119,7 +113,7 @@ 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 + tryRegisterIOPlugin newSewer canary <- atomically $ newTMVar False -- simple 'should I exit' canary -- forkIO $ loadCommsPlugins canary collectorChannel @@ -133,7 +127,7 @@ execMain = do -- collectorTID <- forkIO $ collectInputs collectorChannel availableCommandMap sharedCommandWorkspace sharedTaskQueue -- myTIDs = [dispatchTID,broadcastTID,collectorTID] let myTIDs = [] - runForever canary + runForever newSewer mapM_ killThread myTIDs diff --git a/src/Test-STDIO-Haskeline.hs b/src/Test-STDIO-Haskeline.hs new file mode 100644 index 0000000..1cb3ae2 --- /dev/null +++ b/src/Test-STDIO-Haskeline.hs @@ -0,0 +1,19 @@ +module Main +where +import Carrion.Plugin.IO.STDIO +import GypsFulvus.PluginStuff +import Control.Concurrent.STM +import Control.Concurrent.STM.TChan +import Control.Monad +import qualified Data.Text as T +main :: IO () +main = do + inchan <- atomically $ newTChan + outchan <- atomically $ newTChan + let mymanhole = Manhole inchan outchan + initPlugin mymanhole + let testCommand = Sewage (GenericStyleAutor (T.pack "Test Bin") (T.pack "local") (T.pack "local")) (T.pack "inspect inspect") + atomically $ writeTChan inchan testCommand + forever $ do + newstuff <- atomically $ readTChan outchan + putStrLn $ "Backend " ++ (show $ getSewageAutor newstuff) ++ " returned " ++ (T.unpack $ getSewage newstuff) diff --git a/stack.yaml b/stack.yaml index d22577c..f11ab99 100644 --- a/stack.yaml +++ b/stack.yaml @@ -37,6 +37,8 @@ packages: extra-deps: - git: git@github.com:v-e-h/plugins.git commit: e175d3c2ea9a8cc08126d37d9e30a327d8dc8b29 + - haskeline-0.8.1.0 + # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a diff --git a/stack.yaml.lock b/stack.yaml.lock index d449c80..6ded722 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -18,6 +18,13 @@ packages: original: git: git@github.com:v-e-h/plugins.git commit: e175d3c2ea9a8cc08126d37d9e30a327d8dc8b29 +- completed: + hackage: haskeline-0.8.1.0@sha256:6a6158c90b929ce7aa5331ff5e9819aa32c7df8f4a7ba324b3cc055ee96b48cb,5818 + pantry-tree: + size: 2955 + sha256: b80332551d20389637851299b618679a8435531bed1fed905195ae7163526999 + original: + hackage: haskeline-0.8.1.0 snapshots: - completed: size: 532381