From 393f52bf1c72568173d1a2ff781696ed33451173 Mon Sep 17 00:00:00 2001 From: Jon Doe Date: Tue, 22 Sep 2020 22:09:59 +0200 Subject: [PATCH] smash all this shit together --- GypsFulvus.cabal | 102 +++++++++++++++++---------------- src/Carrion/Plugin/TCL.hs | 23 ++++++-- src/GypsFulvus.hs | 64 ++++++++++++++++++--- src/GypsFulvus/PluginStuff.hs | 4 +- src/tclstubswrapper/tclstubs.o | Bin 1440 -> 0 bytes 5 files changed, 131 insertions(+), 62 deletions(-) delete mode 100644 src/tclstubswrapper/tclstubs.o diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index 9b87bed..0ff4572 100644 --- a/GypsFulvus.cabal +++ b/GypsFulvus.cabal @@ -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 diff --git a/src/Carrion/Plugin/TCL.hs b/src/Carrion/Plugin/TCL.hs index b62f619..6fc362d 100644 --- a/src/Carrion/Plugin/TCL.hs +++ b/src/Carrion/Plugin/TCL.hs @@ -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 () diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index cc339a8..bb6b8bd 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -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 diff --git a/src/GypsFulvus/PluginStuff.hs b/src/GypsFulvus/PluginStuff.hs index 5681a13..233da3b 100644 --- a/src/GypsFulvus/PluginStuff.hs +++ b/src/GypsFulvus/PluginStuff.hs @@ -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 diff --git a/src/tclstubswrapper/tclstubs.o b/src/tclstubswrapper/tclstubs.o deleted file mode 100644 index fdd316b48acf40b36320b2c53cc450b6ba19f6be..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1440 zcmbtT&1(};5T8x7Uq(r_he8Y8i&9Y^Z9$M8WYdsj)o8>f2T#jp-8Q93D%n^10sVkN zVadfm!9T;J;6ZxvzbN#OL%n$r>dfwY$#eU1(O;N1Gr!Eo+u7NpLb;eS43IG3ISf3> z0(?#lY%4M?$iOYA+2Of;(lhPw;Fle4Uxu|_x7M?}uP^Ox0hu3m`2B+7&%Qw^pIfm!592#@H<-N~M&^0!CUFo66apu69I zpI5rS)7mEkNaIh3G*;3f4I?@ltBeleZ(idw$lO)#6Fnnxb12zs(Ev|}@W8!hz_;rG z^PuWAofqv5zDmBc({Vq7Qz}^gP*h~a5T*q=j+*+& z-IV+T!6!FNj9X+66xC4i7#*tlulb9ZOEu|RQz84`Q%SUCf2o%hP7OU&9mSS;lB%FV z++RC`{xJ&SS*-e}oS!6KqM@7ryk`FN^~roWe_d~?{e=$1n7AAfarj}&|r Zd9TP(Am~0biIy(k68C@KkBp6E{vS}+Y!v_i