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

smash all this shit together

Browse Source
This commit is contained in:
Jon Doe 2020-09-22 22:09:59 +02:00 committed by Maciej Bonin
parent 21aaa4f3a9
commit 393f52bf1c
5 changed files with 131 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
GypsFulvus.cabal
View File

@ -32,6 +32,7 @@ library
extra-libraries: tcl8.6
Includes: /usr/include/tcl.h,
src/tclstubswrapper/tclstubs.h
ghc-options:
-O2
-threaded
@ -49,64 +50,69 @@ executable GypsFulvus
directory,
hashable,
monad-parallel,
haskeline
haskeline,
unix
ghc-options:
-O2
-threaded
-with-rtsopts=-N
-g
hs-source-dirs: src
other-modules: GypsFulvus.PluginStuff,GypsFulvus, Carrion.Plugin.IO.STDIO
other-modules: GypsFulvus.PluginStuff,GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL
exposed-modules: GypsFulvus
extra-libraries: tcl8.6
Includes: /usr/include/tcl.h,
src/tclstubswrapper/tclstubs.h
C-Sources: src/tclstubswrapper/tclstubs.c
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
--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
-- extra-libraries: tcl8.6
-- Includes: /usr/include/tcl.h,
-- src/tclstubswrapper/tclstubs.h
-- C-Sources: src/tclstubswrapper/tclstubs.c
---- ld-options: -static
-- ghc-options:
-- -O2
-- -threaded
-- -with-rtsopts=-N
-- -g
executable Test-Carrion-Plugin-TCL
hs-source-dirs: src
main-is: Test-Carrion-TCL.hs
other-modules: Carrion.Plugin.TCL, GypsFulvus.PluginStuff
build-depends: base >= 4.7 && < 5,
stm,
text >= 1.2.4.0,
unix,
plugins,
haskeline,
containers,
directory,
hashable,
monad-parallel
default-language: Haskell2010
extra-libraries: tcl8.6
Includes: /usr/include/tcl.h,
src/tclstubswrapper/tclstubs.h
C-Sources: src/tclstubswrapper/tclstubs.c
ghc-options:
-O2
-threaded
-with-rtsopts=-N
-g
--executable Test-Carrion-Plugin-TCL
-- hs-source-dirs: src
-- main-is: Test-Carrion-TCL.hs
-- other-modules: Carrion.Plugin.TCL, GypsFulvus.PluginStuff
-- build-depends: base >= 4.7 && < 5,
-- stm,
-- text >= 1.2.4.0,
-- unix,
-- plugins,
-- haskeline,
-- containers,
-- directory,
-- hashable,
-- monad-parallel
-- default-language: Haskell2010
-- extra-libraries: tcl8.6
-- Includes: /usr/include/tcl.h,
-- src/tclstubswrapper/tclstubs.h
-- C-Sources: src/tclstubswrapper/tclstubs.c
-- ghc-options:
-- -O2
-- -threaded
-- -with-rtsopts=-N
-- -g

23
src/Carrion/Plugin/TCL.hs
View File

@ -3,7 +3,7 @@
module Carrion.Plugin.TCL
( initPlugin,
processCommand,
testThing
tellCommands
) where
import Control.Monad
import Control.Concurrent(forkIO)
@ -47,10 +47,14 @@ type Tcl_EvalEx_Sig = (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteL
type Tcl_GetStringResult_Sig = (Tcl_Interp_Ptr -> IO CString)
tu :: T.Text -> String
tu = T.unpack
tellCommands :: [T.Text]
tellCommands = map T.pack ["tcl"]
myPluginName = T.pack "TCL smeggdrop"
tl :: T.Text
tl = T.pack "local"
mySignature :: SewageAutorInfo
mySignature = GenericStyleAutor myPluginName tl tl
stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
:: SewageAutorInfo -> String -> TCLCommand
@ -122,7 +126,7 @@ testThing = do
putStrLn $ show $ smeginitstatus
-- fakeFromIRC "proc testo4444 args {return \"booboo\n\"}"
dumpDebug = putStrLn
dumpDebug _ = return ()
initPlugin :: Manhole -> IO InitStatus
initPlugin manhole = do
@ -158,6 +162,9 @@ initPlugin manhole = do
return GoodInitStatus
processCommand :: TCLInterpreterWrapper -> Sewage -> IO T.Text
processCommand wi s = do
let tcl_EvalEx = getEvalEx wi
tcl_GetStringResult = getGetStringResult wi
@ -176,13 +183,17 @@ processCommand wi s = do
0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then dumpDebug ("Command: " ++ c ++" ; returned a null pointer result.") >> return "FAILED" else peekCString rs >>= \nrs -> dumpDebug ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";") >> return nrs
_ -> errorInfo >> tcl_GetStringResult interp >>= peekCString
performFromIRC = doTheTCL $ "return [pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}]"
performFromIRC
performFromIRC >>= return . T.pack
rEPL wrappedtclinterp manhole =
let inspectManhole = atomically . readTChan . getInputChan
regift g = atomically . (flip writeTChan g) . getOutputChan in
forever $ do
newGift <- inspectManhole manhole
processedGift <- processCommand wrappedtclinterp newGift
regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) (T.pack processedGift)) manhole
return ()
strippedCmd <- stripCommandLocal (getSewage newGift) manhole
case strippedCmd of
Just cmdBodyStripped -> do
let giftStripped = Sewage (getSewageAutor newGift) cmdBodyStripped
processedGift <- processCommand wrappedtclinterp giftStripped
regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) processedGift) manhole
Nothing -> return ()

64
src/GypsFulvus.hs
View File

@ -5,7 +5,7 @@ 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)
import Control.Concurrent(ThreadId, forkIO, killThread, threadDelay)
import GypsFulvus.PluginStuff
import Control.Monad(liftM,filterM,forever)
import Control.Monad.IO.Class
@ -14,8 +14,10 @@ import Data.Hashable
import qualified Control.Monad.Parallel as Par
import System.Plugins.Load
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
import qualified Carrion.Plugin.TCL as TCLSIMP
import Prelude hiding ((++),putStrLn)
import Data.Text.IO(putStrLn)
import Debug.Trace
data Placeholder = Placeholder
data CommandMap = CommandMap (M.Map T.Text Placeholder)
data CommandWorkspace = CommandWorkspace Placeholder
@ -45,7 +47,7 @@ assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
lookupManholeInSewer s p = do
s_l <- readTMVar s
return $ M.lookup (hash p) (getSewerMap s_l)
return $ traceShow (hash p) $ M.lookup (hash p) (getSewerMap s_l)
dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
-- broadcast ouputs from routines to all (interested) parties
@ -70,14 +72,23 @@ runForever s =
in forever $ do
someGarbage <- atomically block
let theAutor = show $ getSewageAutor someGarbage
let theSewage = getSewage someGarbage
putStrLn $ (T.pack theAutor) ++ " sez:"
putStrLn $ getSewage someGarbage
putStrLn $ theSewage
threadDelay 1000000
if (theAutor == "local:STDIO haskeline@local" && ("tcl " `T.isPrefixOf` theSewage)) then sendToTCL s someGarbage else return ()
sendToTCL sewer sewage = do
m <- atomically $ lookupManholeInSewer sewer "TCL-Simple"
case m of
Just m -> traceShow (getSewageAutor sewage,getSewage sewage) regift' sewage m
Nothing -> putStrLn "couldn't find TCL submodule"
registerComms = undefined
listDirectory' = listDirectory
makeInputManhole :: TMVar(Sewer) -> String -> IO (Maybe Manhole)
makeInputManhole s p = do
makeManhole :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole)
makeManhole s p = do
coreManhole <- atomically $ lookupManholeInSewer s corePlugName
case coreManhole of
Just cm -> do
@ -86,10 +97,48 @@ makeInputManhole s p = do
return $ Just $ Manhole pluginInputChan coreInputChan
Nothing -> return Nothing
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
tryRegisterPlugin :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus
tryRegisterPlugin s plugName initFunc tellCommandsFunc = 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."
tryRegisterTCLPlugin :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus
tryRegisterTCLPlugin s plugName initFunc tellCommandsFunc = 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."
tryRegisterIOPlugin :: TMVar(Sewer) -> IO InitStatus
tryRegisterIOPlugin s = do
let plugName = "STDIO"
im <- makeInputManhole s plugName
im <- makeManhole s plugName
case im of
Just im' -> do
stdioModuleStatus <- CPISTDIO.initPlugin im'
@ -113,7 +162,8 @@ 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
tryRegisterIOPlugin newSewer
tryRegisterPlugin newSewer "STDIO" CPISTDIO.initPlugin CPISTDIO.tellCommands
tryRegisterTCLPlugin newSewer "TCL-Simple" TCLSIMP.initPlugin TCLSIMP.tellCommands
canary <- atomically $ newTMVar False -- simple 'should I exit' canary
-- forkIO $ loadCommsPlugins canary collectorChannel

4
src/GypsFulvus/PluginStuff.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix') where
module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regift') where
import Control.Monad
import System.Plugins.Make
@ -78,3 +78,5 @@ inspectManhole :: Manhole -> IO Sewage
inspectManhole = atomically . readTChan . getInputChan
regift :: Sewage -> Manhole -> IO ()
regift g = atomically . (flip writeTChan g) . getOutputChan
regift' :: Sewage -> Manhole -> IO ()
regift' g = atomically . (flip writeTChan g) . getInputChan

BIN
src/tclstubswrapper/tclstubs.o
View File

Binary file not shown.