clean up

GypsFulvus.cabal

@@ -14,8 +14,8 @@ cabal-version:       >=1.10
 extra-source-files:  README.md
 
 library
-         exposed-modules: GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL
-         other-modules:   GypsFulvus.PluginStuff
+         exposed-modules: GypsFulvus, GypsFulvus.PluginStuff, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL
+         other-modules:
          default-language:    Haskell2010
          hs-source-dirs:      src
          build-depends:
@@ -23,7 +23,6 @@ library
                        stm,
                        containers,
                        text,
-                       plugins >= 1.6.0,
                        directory,
                        hashable,
                        monad-parallel,
@@ -46,7 +45,6 @@ executable GypsFulvus
                        stm,
                        containers,
                        text,
-                       plugins >= 1.6.0,
                        directory,
                        hashable,
                        monad-parallel,

src/Carrion/Plugin/TCL.hs

@@ -55,7 +55,7 @@ tu :: T.Text -> String
 tu = T.unpack
 tellCommands :: [T.Text]
 tellCommands = map T.pack ["tcl"]
-myPluginName = T.pack "TCL smeggdrop"
+myPluginName = T.pack "TCL-Simple"
 tl :: T.Text
 tl = T.pack "local"
 mySignature :: SewageAutorInfo

src/GypsFulvus.hs

@@ -12,19 +12,35 @@ import Control.Monad.IO.Class
 import qualified Data.Map.Strict as M
 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 Prelude hiding ((++),putStrLn,putStr)
+import Data.Text.IO(putStrLn, putStr)
 import Debug.Trace
 data Placeholder = Placeholder
-data CommandMap = CommandMap (M.Map T.Text Placeholder)
+data CommandMap = CommandMap {getCommandMap :: M.Map Int T.Text}
 data CommandWorkspace = CommandWorkspace Placeholder
 data Sewer = Sewer {getSewerMap :: M.Map Int Manhole}
+data IOPIDS = IOPIDS [Int]
+
+(++) :: T.Text -> T.Text -> T.Text
 a ++ b = T.append a b
 
 
+lookupPluginNameByCommand
+  :: TMVar CommandMap -> T.Text -> STM (Maybe T.Text)
+lookupPluginNameByCommand m c = do
+  m <- readTMVar m
+  case T.breakOn " " c of
+    (sic,_) -> return $ M.lookup (hash sic) (getCommandMap m)
+
+registerCommands :: TMVar(CommandMap) -> T.Text -> [T.Text] -> STM ()
+registerCommands m pn tellFunc = do
+  m' <- takeTMVar m
+  let ncm = M.unions (map (\com -> M.insert (hash com) pn (getCommandMap m')) $ tellFunc)
+  putTMVar m (CommandMap ncm)
+
+  
 sharedDataPath :: IO FilePath
 sharedDataPath = getXdgDirectory XdgData "gypsfulvus" >>= makeAbsolute
 
@@ -48,22 +64,19 @@ lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
 lookupManholeInSewer s p = do
   s_l <- readTMVar s
   return $ M.lookup (hash p) (getSewerMap s_l)
-  
-dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
--- broadcast ouputs from routines to all (interested) parties
-broadcastToConsumers consumerBroadcastChannel sharedCommandWorkspace sharedTaskQueue = undefined
--- collect all input from all comms plugins and queue for dispatch
-collectInputs collectorChannel availableCommandMap sharedCommandWorkspace sharedTaskQueue = undefined
 
-        
--- load all the routines that the bot can run (e.g. run tcl code, calculator, youtube, etc.)
-loadLabourPlugins availableCommandMap = undefined
--- thread to pass any work to be done
 corePlugName :: T.Text
 corePlugName = "core"
 
-runForever :: TMVar Sewer -> IO ()
-runForever s =
+
+isIOPlugin :: Sewage -> TMVar IOPIDS -> IO Bool
+isIOPlugin sewage iopids = let pname = (hash . getName .nsAutorToGenericAutor . getSewageAutor $ sewage)
+                    in do
+  IOPIDS iop <- atomically $ readTMVar iopids
+  return $ pname `elem` iop
+
+runForever :: TMVar Sewer -> TMVar(CommandMap) -> TMVar(IOPIDS) -> IO ()
+runForever s cmap iopids =
   let block = do
                 mh <- lookupManholeInSewer s corePlugName
                 case mh of
@@ -73,24 +86,28 @@ runForever s =
        someGarbage <- atomically block
        let theAutor = show $ getSewageAutor someGarbage
        let theSewage = getSewage someGarbage
-       threadDelay 1000000
-       if (theAutor == "local:STDIO haskeline@local") then
-         if ("tcl " `T.isPrefixOf` theSewage) then
-           sendToTCL s someGarbage
-         else
-           return ()
+       amIIO <- isIOPlugin someGarbage iopids
+       if (amIIO) then
+         trySendToWorker s someGarbage cmap
        else do
          putStrLn $ T.pack theAutor ++ " sez:"
-         putStrLn theSewage
-sendToTCL sewer sewage = do
-  m <- atomically $ lookupManholeInSewer sewer "TCL-Simple"
-  case m of
-    Just m -> regift' sewage m
-    Nothing -> putStrLn "couldn't find TCL submodule"
-    
-registerComms = undefined
+         putStrLn $ theSewage
+
+trySendToWorker
+  :: TMVar Sewer -> Sewage -> TMVar CommandMap -> IO ()
+trySendToWorker sewer sewage cmap = do
+  let sewage' = getSewage sewage
+  pn <- atomically $ lookupPluginNameByCommand cmap sewage'
+  case pn of
+    Just pn' -> do
+      pm <- atomically $ lookupManholeInSewer sewer pn'
+      case pm of
+        Just m -> regiftToWorker sewage m
+        Nothing -> putStrLn $ "couldn't find channel to " ++ pn'
+    Nothing -> putStrLn $ "Couldn't find plugin for command " ++ sewage'    
+
+
 
-listDirectory' = listDirectory
   
 makeManhole :: TMVar(Sewer) -> T.Text -> IO (Maybe Manhole)
 makeManhole s p = do
@@ -102,16 +119,6 @@ makeManhole 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
@@ -126,84 +133,37 @@ tryRegisterPlugin s plugName initFunc tellCommandsFunc = do
         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 <- makeManhole s plugName
-  case im of
-    Just im' -> do
-      stdioModuleStatus <- CPISTDIO.initPlugin im'
-      case stdioModuleStatus of
-        GoodInitStatus -> do
-          atomically $ assCallbackWithManholeInSewer s plugName im'
-          return GoodInitStatus
-        BadInitStatus errs -> return $ BadInitStatus $ "couldn't load stdio plugin: " ++ errs
-    Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected."
-loadCoreCommands = undefined
 
+makeNewSewer :: Manhole -> IO (TMVar Sewer)
 makeNewSewer coreManhole = do
   let
     plugName = "core"
   emptySewer <- atomically $ newTMVar $ Sewer M.empty
   atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole
+
+regiop :: Hashable a => a -> TMVar IOPIDS -> STM ()
+regiop pn iopids = do
+  IOPIDS iopids' <- takeTMVar iopids
+  putTMVar iopids (IOPIDS $ (hash pn):iopids')
   
+stdioPlugName :: T.Text
+stdioPlugName = "STDIO haskeline"
+
+tclPlugName :: T.Text
+tclPlugName = "TCL-Simple"
 
 execMain :: IO ()
 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
+  commandMap <- atomically $ newTMVar $ CommandMap M.empty
+  iopids <- atomically $ newTMVar $ IOPIDS []
   newSewer <- makeNewSewer $ Manhole collectorChannel dumperChannel
-  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
-  
---  availableCommandMap <- atomically $ newTMVar CommandMap
---  loadLabourPlugins availableCommandMap
---  sharedCommandWorkspace <- atomically $ newTMVar CommandWorkspace
---  sharedTaskQueue <- atomically $ newTChan
---  dispatchTID <- forkIO $ dispatchCommands sharedCommandWorkspace sharedTaskQueue
---  broadcastTID <- forkIO $ broadcastToConsumers consumerBroadcastChannel sharedCommandWorkspace sharedTaskQueue
---  collectorTID <- forkIO $ collectInputs collectorChannel availableCommandMap sharedCommandWorkspace sharedTaskQueue
---  myTIDs = [dispatchTID,broadcastTID,collectorTID] 
+  tryRegisterPlugin newSewer stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands
+  atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands
+  atomically $ regiop stdioPlugName iopids
+  tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands
+  atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands
   let myTIDs  = []
-  runForever newSewer
+  runForever newSewer commandMap iopids
   mapM_ killThread myTIDs
-
-
-
-
---makePluginsForgetThis canary collectorChannel =
---  let potentialPlugins = srcPluginPath >>= \pp -> listDirectory pp >>= filterM (\fuku -> doesDirectoryExist (pp ++ "/" ++ fuku)) >>= mapM (\fuku -> return (pp ++ "/" ++ fuku))
---  in do
---    srcPluginPath >>= putStrLn
---    srcPluginPath >>= listDirectory >>= mapM putStrLn
---    srcPluginPath >>= \pp -> listDirectory pp >>= filterM (\fuku -> putStrLn (pp ++ "/" ++ fuku) >> doesDirectoryExist (pp ++ "/" ++ fuku)) 
---    pp <- potentialPlugins
---    mapM_ putStrLn pp
---    ff <- mapM (\d -> findFile [d] "Plugin.hs") pp
---    let rff = map (fromMaybe "") $ filter (/= Nothing) ff
---    s <- mapM (\hng -> makeAll hng ["-v","-dynamic"]) rff
---    mapM (\s' -> case s' of
---                   MakeSuccess _ p -> putStrLn p
---                   MakeFailure e -> putStrLn $ show e) s
---    _ <- atomically $ swapTMVar canary True
-    -- I don't actually want to quit here but I don't like errors from STM heuristics when the canary is GCed
-    
---    return ()
--- end makePluginsForgetThis

src/GypsFulvus/PluginStuff.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
-module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regift') where
+module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regiftToWorker) where
 import Control.Monad
 
-import System.Plugins.Make
+
 import Data.Maybe
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMVar
@@ -14,11 +14,13 @@ a ♯ b = (T.append) a b
 
 tooTeToSt :: T.Text -> T.Text -> String
 tooTeToSt a b = tup $ a ♯ "@" ♯ b
+
 stripCommandPrefix
   :: T.Text -> [T.Text] -> Either [Maybe T.Text] (Maybe T.Text)
 stripCommandPrefix c = uniqueHit . filter (/= Nothing) . map (\cs -> T.stripPrefix cs (c ♯ " "))
   where
     uniqueHit cs = if (L.length cs == (1 :: Int)) then Right $ head cs else Left cs
+
 stripCommandPrefix'
   :: T.Text -> [T.Text] -> Manhole -> SewageAutorInfo -> IO (Maybe T.Text)
 stripCommandPrefix' c ccs m sig = case stripCommandPrefix c ccs of
@@ -26,10 +28,13 @@ stripCommandPrefix' c ccs m sig = case stripCommandPrefix c ccs of
   Left cs -> do
     sew <- regift (Sewage sig (if L.null cs then ("No such command: " ♯ c) else ("Found multiple matching commands: " ♯ ((L.foldr1 (\h ng  -> h ♯ ", " ♯ ng)) $ (map (fromMaybe "")) cs)))) m
     return Nothing
+
 tp :: String -> T.Text
 tp = T.pack
+
 tup :: T.Text -> String
 tup = T.unpack
+
 data IrcMask = IrcMask {
                        getIdent:: T.Text,
                        getHostname :: T.Text}
@@ -61,6 +66,7 @@ type Nickname = T.Text
 type NetworkIdent = T.Text
 type NetworkHostname = T.Text
 type NetworkChannel = T.Text
+
 makeNetworkIdentStyleAutor
   :: Nickname -> NetworkIdent -> NetworkHostname -> NetworkChannel -> SewageAutorInfo
 makeNetworkIdentStyleAutor n i h c = NetworkIdentStyleAutor n (IrcMask i h) c
@@ -76,7 +82,9 @@ data InitStatus = GoodInitStatus | BadInitStatus T.Text
 
 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
+
+regiftToWorker :: Sewage -> Manhole -> IO ()
+regiftToWorker g = atomically . (flip writeTChan g) . getInputChan