wrath/shaniqua-core
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

stdio works now sort of

Browse Source
This commit is contained in:
Jon Doe 2020-09-22 16:52:52 +02:00 committed by Maciej Bonin
parent a8b67daa05
commit 369b7f63f0
6 changed files with 161 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
GypsFulvus.cabal
View File

@ -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

63
src/Carrion/Plugin/IO/STDIO.hs Normal file
View File

@ -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 ()

88
src/GypsFulvus.hs
View File

@ -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

19
src/Test-STDIO-Haskeline.hs Normal file
View File

@ -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)

2
stack.yaml
View File

@ -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

7
stack.yaml.lock
View File

@ -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