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
|
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
|
||||||
|
@ -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 ()
|
||||||
|
@ -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
|
||||||
|
@ -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.
Loading…
x
Reference in New Issue
Block a user