smash all this shit together

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
+--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

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
+    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 ()

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)
+makeManhole :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole)
-makeInputManhole s p = do
+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

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