smash all this shit together

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

View File

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

View File

@ -3,7 +3,7 @@
module Carrion.Plugin.TCL module Carrion.Plugin.TCL
( initPlugin, ( initPlugin,
processCommand, processCommand,
testThing tellCommands
) where ) where
import Control.Monad import Control.Monad
import Control.Concurrent(forkIO) 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) type Tcl_GetStringResult_Sig = (Tcl_Interp_Ptr -> IO CString)
tu :: T.Text -> String tu :: T.Text -> String
tu = T.unpack tu = T.unpack
tellCommands :: [T.Text]
tellCommands = map T.pack ["tcl"] tellCommands = map T.pack ["tcl"]
myPluginName = T.pack "TCL smeggdrop" myPluginName = T.pack "TCL smeggdrop"
tl :: T.Text
tl = T.pack "local" tl = T.pack "local"
mySignature :: SewageAutorInfo
mySignature = GenericStyleAutor myPluginName tl tl mySignature = GenericStyleAutor myPluginName tl tl
stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
:: SewageAutorInfo -> String -> TCLCommand :: SewageAutorInfo -> String -> TCLCommand
@ -122,7 +126,7 @@ testThing = do
putStrLn $ show $ smeginitstatus putStrLn $ show $ smeginitstatus
-- fakeFromIRC "proc testo4444 args {return \"booboo\n\"}" -- fakeFromIRC "proc testo4444 args {return \"booboo\n\"}"
dumpDebug = putStrLn dumpDebug _ = return ()
initPlugin :: Manhole -> IO InitStatus initPlugin :: Manhole -> IO InitStatus
initPlugin manhole = do initPlugin manhole = do
@ -158,6 +162,9 @@ initPlugin manhole = do
return GoodInitStatus return GoodInitStatus
processCommand :: TCLInterpreterWrapper -> Sewage -> IO T.Text
processCommand wi s = do processCommand wi s = do
let tcl_EvalEx = getEvalEx wi let tcl_EvalEx = getEvalEx wi
tcl_GetStringResult = getGetStringResult 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 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 _ -> errorInfo >> tcl_GetStringResult interp >>= peekCString
performFromIRC = doTheTCL $ "return [pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}]" performFromIRC = doTheTCL $ "return [pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}]"
performFromIRC performFromIRC >>= return . T.pack
rEPL wrappedtclinterp manhole = rEPL wrappedtclinterp manhole =
let inspectManhole = atomically . readTChan . getInputChan let inspectManhole = atomically . readTChan . getInputChan
regift g = atomically . (flip writeTChan g) . getOutputChan in regift g = atomically . (flip writeTChan g) . getOutputChan in
forever $ do forever $ do
newGift <- inspectManhole manhole newGift <- inspectManhole manhole
processedGift <- processCommand wrappedtclinterp newGift strippedCmd <- stripCommandLocal (getSewage newGift) manhole
regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) (T.pack processedGift)) manhole case strippedCmd of
return () 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 ()

View File

@ -5,7 +5,7 @@ import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TChan
import System.Directory import System.Directory
import qualified Data.Text as T import qualified Data.Text as T
import Control.Concurrent(ThreadId, forkIO, killThread) import Control.Concurrent(ThreadId, forkIO, killThread, threadDelay)
import GypsFulvus.PluginStuff import GypsFulvus.PluginStuff
import Control.Monad(liftM,filterM,forever) import Control.Monad(liftM,filterM,forever)
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -14,8 +14,10 @@ import Data.Hashable
import qualified Control.Monad.Parallel as Par import qualified Control.Monad.Parallel as Par
import System.Plugins.Load import System.Plugins.Load
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
import qualified Carrion.Plugin.TCL as TCLSIMP
import Prelude hiding ((++),putStrLn) import Prelude hiding ((++),putStrLn)
import Data.Text.IO(putStrLn) import Data.Text.IO(putStrLn)
import Debug.Trace
data Placeholder = Placeholder data Placeholder = Placeholder
data CommandMap = CommandMap (M.Map T.Text Placeholder) data CommandMap = CommandMap (M.Map T.Text Placeholder)
data CommandWorkspace = CommandWorkspace 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 :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
lookupManholeInSewer s p = do lookupManholeInSewer s p = do
s_l <- readTMVar s 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 dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
-- broadcast ouputs from routines to all (interested) parties -- broadcast ouputs from routines to all (interested) parties
@ -70,14 +72,23 @@ runForever s =
in forever $ do in forever $ do
someGarbage <- atomically block someGarbage <- atomically block
let theAutor = show $ getSewageAutor someGarbage let theAutor = show $ getSewageAutor someGarbage
let theSewage = getSewage someGarbage
putStrLn $ (T.pack theAutor) ++ " sez:" 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 registerComms = undefined
listDirectory' = listDirectory listDirectory' = listDirectory
makeInputManhole :: TMVar(Sewer) -> String -> IO (Maybe Manhole) makeManhole :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole)
makeInputManhole s p = do makeManhole s p = do
coreManhole <- atomically $ lookupManholeInSewer s corePlugName coreManhole <- atomically $ lookupManholeInSewer s corePlugName
case coreManhole of case coreManhole of
Just cm -> do Just cm -> do
@ -86,10 +97,48 @@ makeInputManhole s p = do
return $ Just $ Manhole pluginInputChan coreInputChan return $ Just $ Manhole pluginInputChan coreInputChan
Nothing -> return Nothing 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 :: TMVar(Sewer) -> IO InitStatus
tryRegisterIOPlugin s = do tryRegisterIOPlugin s = do
let plugName = "STDIO" let plugName = "STDIO"
im <- makeInputManhole s plugName im <- makeManhole s plugName
case im of case im of
Just im' -> do Just im' -> do
stdioModuleStatus <- CPISTDIO.initPlugin im' 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 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 dumperChannel <- atomically newTChan -- uh this doesnt make any sense, every dings needs to have its own channel
newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel 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 canary <- atomically $ newTMVar False -- simple 'should I exit' canary
-- forkIO $ loadCommsPlugins canary collectorChannel -- forkIO $ loadCommsPlugins canary collectorChannel

View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 Control.Monad
import System.Plugins.Make import System.Plugins.Make
@ -78,3 +78,5 @@ inspectManhole :: Manhole -> IO Sewage
inspectManhole = atomically . readTChan . getInputChan inspectManhole = atomically . readTChan . getInputChan
regift :: Sewage -> Manhole -> IO () regift :: Sewage -> Manhole -> IO ()
regift g = atomically . (flip writeTChan g) . getOutputChan regift g = atomically . (flip writeTChan g) . getOutputChan
regift' :: Sewage -> Manhole -> IO ()
regift' g = atomically . (flip writeTChan g) . getInputChan

Binary file not shown.