smash all this shit together
This commit is contained in:
parent
21aaa4f3a9
commit
393f52bf1c
102
GypsFulvus.cabal
102
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
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user