clean up, use typeclass for interface, fix some nonsense, remove hardcoded values for the routing logic

exquisiterobot.conf.example

@@ -2,3 +2,4 @@
 hostname= chat.freenode.org
 port= 6697
 channels = ##politics !docking #noshower
+nickname = ExquisiteTest

src/Carrion/Plugin/IO/IRC/Client.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Carrion.Plugin.IO.IRC.Client
-  (initPlugin,tellCommands)
+  (initPlugin,tellCommands,myPlugName)
 where
 import GypsFulvus.PluginStuff(Manhole(..),Sewage(..), InitStatus(..),SewageAutorInfo(..),genericAutorToNSAutor,inspectManhole,regift, stripCommandPrefix')
 import Network.IRC.Client
@@ -26,20 +26,33 @@ import Network.IRC.CTCP(CTCPByteString(..))
 import Control.Applicative ((<$>), (<|>))
 import Data.List(nub,(\\))
 import Data.Ini
+import Data.Maybe(fromMaybe)
 import qualified Data.Text.IO as TIO
 type MyNicknames = M.Map (T.Text) ([T.Text])
 
 
+(♯) :: T.Text -> T.Text -> T.Text
 a ♯ b = T.append a b
+
+unpack :: T.Text -> String
 unpack = T.unpack
+
 myPlugName :: T.Text
 myPlugName = T.pack "IRC-Simple"
+
 lOCAL :: T.Text 
 lOCAL = T.pack "local"
 
-mySignature = GenericStyleAutor myPlugName lOCAL lOCAL
+mySignature :: SewageAutorInfo
+mySignature = GenericStyleAutor myPlugName myPlugName lOCAL
+
+tellCommands :: [T.Text]
 tellCommands = ["tcl"]
+
+privateBotCommands :: [T.Text]
 privateBotCommands = ["!join","!part","!kick","!op","!cycle","!reconnect","!ostracise","tcl"]
+
+myOwners :: [[Char]]
 myOwners = ["hastur"]
 
 --myChannels :: [T.Text]
@@ -72,8 +85,26 @@ replaceNNS nns theChan theNicknames= do
 
 otherJoinHandler :: EventHandler s
 otherJoinHandler = huntAlligators (matchType _Join) $ \_ c -> sendNAMES c
-otherPartHandler :: EventHandler s
+
-otherPartHandler = huntAlligators (matchType _Part) $ \_ (c,_) -> sendNAMES c
+otherPartHandler
+  :: TMVar (M.Map (NickName T.Text) [ChannelName T.Text])
+     -> EventHandler s
+otherPartHandler nns = huntAlligators (matchType' _Part nns) $ \src (nns, (c,r)) -> do
+  case src of
+    Channel n c -> do
+      liftIO . atomically $ removeFromNNS nns c n
+      return ()
+    _ -> return ()
+
+otherQuitHandler
+  :: TMVar (M.Map (NickName T.Text) [ChannelName T.Text])
+     -> EventHandler s
+otherQuitHandler nns = huntAlligators (matchType' _Quit nns) $ \src (nns, r) -> do
+  case src of
+    Channel n c -> do
+      liftIO . atomically $ removeFromNNS nns c n
+      return ()
+    _ -> return ()
 
 removeFromNNS
   :: (Ord k, Eq a) =>
@@ -91,7 +122,7 @@ namesReplyHandler
   :: a -> TMVar (M.Map T.Text [T.Text]) -> EventHandler s
 namesReplyHandler mh nns = huntAlligators (matchNumeric' rPL_NAMREPLY (mh,nns)) $
   \src ((mh,nns), (meirl:theEqualsSignAsASeparateElementWhyTheFuckNot:theChan:theNicknames:[])) ->
-    (liftIO . atomically $ replaceNNS nns theChan theNicknames) >>= (liftIO . putStrLn . show)
+    (liftIO . atomically $ replaceNNS nns theChan theNicknames) >> return () -- >>= (liftIO . putStrLn . show)
      
 
 matchNumeric'
@@ -117,6 +148,7 @@ huntAlligators
 huntAlligators mf cf = EventHandler mf cf
 
 
+fYourKickHandler :: TMVar (M.Map T.Text [T.Text]) -> EventHandler s
 fYourKickHandler nns = huntAlligators (matchType' _Kick nns) $ \src (nns, (channame, nickname, reason)) -> do
         tvarI <- get instanceConfig <$> getIRCState
         iGotBooted <- liftIO . atomically $ do
@@ -134,9 +166,16 @@ fYourKickHandler nns = huntAlligators (matchType' _Kick nns) $ \src (nns, (chann
 
 spamCoordinator :: Manhole -> T.Text -> IO ()
 spamCoordinator mh msg = regift (Sewage mySignature msg) mh
-spamFromIRC mh msg thenick thechan = regift (Sewage (GenericStyleAutor myPlugName "local" thechan) msg) mh
+
+spamFromIRC :: Manhole -> T.Text -> T.Text -> T.Text -> IO ()
+spamFromIRC mh msg thenick thechan = regift (Sewage (GenericStyleAutor thenick myPlugName thechan) msg) mh
+
+stripDangerousNickname :: p -> T.Text -> T.Text
 stripDangerousNickname n = T.filter (\c -> (not . (c `elem`)) ['[',']','{','}'])
 
+detectCommandHandler
+  :: (TMVar (M.Map (ChannelName T.Text) [T.Text]), Manhole)
+     -> EventHandler s
 detectCommandHandler (nns,mh) = huntAlligators (matchType' _Privmsg (nns,mh)) $ \src ((nns,mh),(tgt,blergh)) -> do
               tvarI <- get instanceConfig <$> getIRCState
               case blergh of
@@ -150,68 +189,77 @@ detectCommandHandler (nns,mh) = huntAlligators (matchType' _Privmsg (nns,mh)) $
                       Just c -> do
                         case src of
                           Channel thechannelname thenickname -> do
-                            liftIO $ putStrLn $ "what the fuck: " ++ T.unpack thenickname ++ " " ++ T.unpack thechannelname
+--                            liftIO $ putStrLn $ "what the fuck: " ++ T.unpack thenickname ++ " " ++ T.unpack thechannelname
                             lnns <- liftIO . atomically $ readTMVar nns
-                            let thenames = foldr1 (++) $ M.elems lnns -- fuck it all nicks
+                            let thenames = (fromMaybe [T.pack ""]) $ M.lookup thechannelname lnns
                             liftIO $ spamCoordinator mh $ T.pack "tcl cache put irc chanlist [list " ♯ (foldr1 (\a b -> a ♯ " " ♯ b) $ (map (stripDangerousNickname $ T.pack)) $ thenames) ♯ "]"
                             liftIO $ spamFromIRC mh body thenickname thechannelname -- actually process the commands here
                           _ -> return () -- no secret commands fuck it
                   else return ()
                 Left _ -> return ()
+
 stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
 stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
 
+data IRCConfig = IRCConfig {getIRCHost:: T.Text, getIRCPort :: Int, getIRCChannels :: [T.Text], getIRCNickname :: T.Text} | FuckedIRCConfig T.Text
+
+getIRCConfig :: IO IRCConfig
 getIRCConfig = do
   c <- TIO.readFile "./exquisiterobot.conf" >>= return . parseIni
   case c of
-    Left _ -> return (T.pack "",0,T.pack "")
+    Left _ -> return $ FuckedIRCConfig "Couldn't read the configuration file."
     Right i -> do
       let host = lookupValue "Server" "hostname" i
           port = lookupValue "Server" "port" i
           channels = lookupValue "Server" "channels" i
-      case (host,port,channels) of
+          myNickname = lookupValue "Server" "nickname" i
-        (Right h, Right p, Right cs) -> return (h,(read . T.unpack $ p),cs)
+      case (host,port,channels,myNickname) of
-        _ -> return ("",0,"")
+        (Right h, Right p, Right cs, Right n) -> return $ IRCConfig h (read . T.unpack $ p) (T.splitOn " " cs) n
+        (h,p,cs,n) -> return $ FuckedIRCConfig $ foldr1 (♯) . map (T.pack . show) $ [h,p,cs,n]
+
 initPlugin :: Manhole -> IO InitStatus
 initPlugin mh = do
-  (myHost,myPort,myChannels') <- getIRCConfig
+  ircConfig <- getIRCConfig
-  let myChannels = T.splitOn " " myChannels'
+  case ircConfig of
-  let myNickname = "ExquisiteRobot"
+    IRCConfig myHost myPort myChannels myNickname -> do
-      cpara = defaultParamsClient (unpack myHost) ""
+      let cpara = defaultParamsClient (unpack myHost) ""
-      validate cs vc sid cc = do
+          validate cs vc sid cc = do
-         -- First validate with the standard function
+            -- First validate with the standard function
-         res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
+            res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
-         -- Then strip out non-issues
+          -- Then strip out non-issues
-         return $ filter (`notElem` [UnknownCA, SelfSigned]) res
+            return $ filter (`notElem` [UnknownCA, SelfSigned]) res
-      myClientConfig = (tlsClientConfig myPort (encodeUtf8 myHost)) { tlsClientTLSSettings = TLSSettings cpara
+          myClientConfig = (tlsClientConfig myPort (encodeUtf8 myHost)) { tlsClientTLSSettings = TLSSettings cpara
-    { clientHooks = (clientHooks cpara)
+                                                                          { clientHooks = (clientHooks cpara)
-      { onServerCertificate = validate }
+                                                                            { onServerCertificate = validate }
-    , clientSupported = (clientSupported cpara)
+                                                                          , clientSupported = (clientSupported cpara)
-      { supportedVersions = [TLS12, TLS11, TLS10]
+                                                                            { supportedVersions = [TLS12, TLS11, TLS10]
-      , supportedCiphers = ciphersuite_strong
+                                                                            , supportedCiphers = ciphersuite_strong
-      }
+                                                                            }
-    }
+                                                                          }
-  }
+                                                                        }
-      conn = (tlsConnection $ WithClientConfig myClientConfig) & flood .~ 0
+          conn = (tlsConnection $ WithClientConfig myClientConfig) & flood .~ 0
-  myNNS <- atomically $ newTMVar M.empty
+      myNNS <- atomically $ newTMVar M.empty
-  let namesReplyHandler' = namesReplyHandler mh myNNS
+      let namesReplyHandler' = namesReplyHandler mh myNNS
-      rejoinOnKickHandler = fYourKickHandler myNNS
+          rejoinOnKickHandler = fYourKickHandler myNNS
-      mySpecialHandlers = [rejoinOnKickHandler,detectCommandHandler',joinHandler',namesReplyHandler',otherJoinHandler,otherPartHandler]
+          mySpecialHandlers = [rejoinOnKickHandler,detectCommandHandler',joinHandler',namesReplyHandler',otherJoinHandler,otherPartHandler myNNS, otherQuitHandler myNNS]
-      cfg  = defaultInstanceConfig myNickname & channels %~ (myChannels ++) & handlers %~ (++ mySpecialHandlers)
+          cfg  = defaultInstanceConfig myNickname & channels %~ (myChannels ++) & handlers %~ (++ mySpecialHandlers)
-      detectCommandHandler' = detectCommandHandler (myNNS,mh)
+          detectCommandHandler' = detectCommandHandler (myNNS,mh)
-  myIRCState <- newIRCState conn cfg ()
+      myIRCState <- newIRCState conn cfg ()
-  forkIO $ runClientWith myIRCState
+      forkIO $ runClientWith myIRCState
-  forkIO $ acceptExternalComms myIRCState mh
+      forkIO $ acceptExternalComms myIRCState mh
-  return GoodInitStatus
+      return GoodInitStatus
-
+    FuckedIRCConfig err -> return $ BadInitStatus err
+    
+acceptExternalComms :: MonadIO f => IRCState s -> Manhole -> f b
 acceptExternalComms myIRCState manhole =
   let inspectManhole = atomically . readTChan . getInputChan
       regift g = atomically . (flip writeTChan g) . getOutputChan in
   forever $ do
     newGift <- liftIO $ inspectManhole manhole
-    putStrLn $ "trying to maybe send to " ++ (T.unpack .getChannel . genericAutorToNSAutor . getSewageAutor $ newGift)
+--    putStrLn $ "trying to maybe send to " ++ (T.unpack .getChannel . genericAutorToNSAutor . getSewageAutor $ newGift)
     runIRCAction (mapM (\fff -> send $ Privmsg (getChannel . genericAutorToNSAutor . getSewageAutor $ newGift) $ Right fff) (nlSplit $ getSewage newGift)) myIRCState
 
 
 
+nlSplit :: T.Text -> [T.Text]
 nlSplit = T.splitOn "\n"

src/Carrion/Plugin/IO/STDIO.hs

@@ -1,9 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Carrion.Plugin.IO.STDIO
     ( initPlugin,
-      processCommand,
-      testThing,
       tellCommands,
+      myPlugName
     ) where
 import Control.Monad.IO.Class
 import Control.Monad
@@ -27,7 +26,8 @@ testThing = runInputT defaultSettings loop
                Just "quit" -> return ()
                Just input -> do outputStrLn $ T.unpack ("Input was: " ++ T.pack input)
                                 loop
-mySignature = GenericStyleAutor "STDIO haskeline" "local" "local"
+myPlugName = "STDIO haskeline"
+mySignature = GenericStyleAutor myPlugName myPlugName "local"
 tellCommands = [""]
 
 stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature

src/Carrion/Plugin/TCL.hs

@@ -2,8 +2,8 @@
 
 module Carrion.Plugin.TCL
     ( initPlugin,
-      processCommand,
+      tellCommands,
-      tellCommands
+      myPlugName
     ) where
 import Control.Monad
 import Control.Concurrent(forkIO, threadDelay, killThread)
@@ -53,27 +53,34 @@ foreign import ccall "dynamic" mkTcl_EvalEx :: FunPtr (Tcl_Interp_Ptr -> TclScri
 
 tu :: T.Text -> String
 tu = T.unpack
+
 tellCommands :: [T.Text]
 tellCommands = map T.pack ["tcl","tclAdmin"]
+
+privilegedAutors :: [T.Text]
 privilegedAutors = map T.pack ["core","STDIO haskeline","hastur","IRC-Simple"]
+
+myPluginName :: T.Text
 myPluginName = T.pack "TCL-Simple"
-tl :: T.Text
+myPlugName = myPluginName
-tl = T.pack "local"
+lOCAL :: T.Text
+lOCAL = T.pack "local"
+
 mySignature :: SewageAutorInfo
-mySignature = GenericStyleAutor myPluginName tl tl
+mySignature = GenericStyleAutor myPluginName myPluginName lOCAL
-sigWithChan ch = GenericStyleAutor myPluginName tl ch
+
+sigWithChan :: T.Text -> SewageAutorInfo
+sigWithChan ch = GenericStyleAutor myPluginName myPluginName ch
+
 stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
 stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
-fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
-  :: SewageAutorInfo -> String -> TCLCommand
-fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson b = case b of
-  GenericStyleAutor a b c -> fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson . genericAutorToNSAutor $ GenericStyleAutor a b c
-  NetworkIdentStyleAutor a b c -> TCLCommand (tu a) (show b) "" (tu c)
 
 
 mkTCLCommandFromAIAndMsg :: SewageAutorInfo -> String -> TCLCommand
-mkTCLCommandFromAIAndMsg = fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
+mkTCLCommandFromAIAndMsg b = case b of
-
+  GenericStyleAutor a b c -> mkTCLCommandFromAIAndMsg . genericAutorToNSAutor $ GenericStyleAutor a b c
+  NetworkIdentStyleAutor a b c -> TCLCommand (tu a) (show b) "" (tu c)
+  
 data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Interp_Ptr),
                                                     getEvalFile :: Tcl_EvalFile_Sig,
                                                     getEvalEx :: Tcl_EvalEx_Sig,
@@ -84,9 +91,11 @@ data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Inter
 
 lEN_AUTO :: Int
 lEN_AUTO = -1
+
 eVAL_FLAGS_CLEAR :: Int
 eVAL_FLAGS_CLEAR = 0
 
+dumpDebug :: Monad m => p -> m ()
 dumpDebug _ = return ()
 
 initPlugin :: Manhole -> IO InitStatus
@@ -146,25 +155,20 @@ processCommand wi s ip = do
   let runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
       runTclCommand s = newCString s >>= runscript
       errorInfo = runTclCommand "return $errorInfo"
-      
       doTheTCL c = runTclCommand c >>= \st ->
         case st of
           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 $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
       performAdminLevel = doTheTCL sewCmd
---  harvester <- forkIO $ do
---    threadDelay 15000000
---    putStrLn "cancelling thread!!!"
---    fff <- tcl_CancelEval interp nullPtr nullPtr 0x100000
---    putStrLn $ "cancel status " ++ (show fff)
---    hngggg <- tcl_AsyncInvoke interp 0
---    putStrLn $ "asyncinvoke returned " ++ (show hngggg)
   res <- if (ip) then performAdminLevel else performFromIRC
---  putStrLn "putting back the interp"
   atomically $ putTMVar i interp
   return $ T.pack res
 
+sigWithChan' :: T.Text -> T.Text -> SewageAutorInfo
+sigWithChan' thechannel originallocation = GenericStyleAutor originallocation myPluginName thechannel
+
+rEPL :: TCLInterpreterWrapper -> Manhole -> IO b
 rEPL wrappedtclinterp manhole =
   let inspectManhole = atomically . readTChan . getInputChan
       regift g = atomically . (flip writeTChan g) . getOutputChan in
@@ -178,16 +182,13 @@ rEPL wrappedtclinterp manhole =
         case hmm of
           Nothing -> do
             let theOriginalChannel = getContext . nsAutorToGenericAutor . getSewageAutor $ newGift
+                theOriginalPlugin = getLocation . nsAutorToGenericAutor . getSewageAutor $ newGift
             let isPrivileged = if T.pack "tclAdmin " `T.isPrefixOf` (getSewage newGift) && ( getNick . genericAutorToNSAutor . getSewageAutor $ newGift) `elem` privilegedAutors then True else False
             processedGift <- processCommand wrappedtclinterp giftStripped isPrivileged
-            regift (Sewage (sigWithChan theOriginalChannel) processedGift) manhole
+            regift (Sewage (sigWithChan' theOriginalChannel theOriginalPlugin) processedGift) manhole
           Just berror -> regift (Sewage mySignature (T.pack berror)) manhole
       Nothing -> return ()
 
--- stolen from the internet and adapted for tcl
--- Return whether a string contains balanced brackets.  Nothing indicates a
--- balanced string, while (Just i) means an imbalance was found at, or just
--- after, the i'th bracket.  We assume the string contains only brackets.
 isBalanced :: Char -> Char -> String -> Maybe String
 isBalanced openc closec = bal (-1) 0
   where
@@ -202,9 +203,12 @@ isBalanced openc closec = bal (-1) 0
           (sc:rs) -> if sc == openc || sc == closec then bal (i+2) n rs else bal (i+1) n rs 
       | otherwise = bal (i+1) n bs    
 
+gnarlyBalanced :: String -> Maybe String
 gnarlyBalanced = isBalanced '{' '}'
 -- it's better not to check for double quotes and square brackets I think since they can be escaped and not used internally for pub:tcl:perform...
 
+squareBalanced :: String -> Maybe String
 squareBalanced = isBalanced '[' ']'
 
+dquoteBalanced :: String -> Maybe String
 dquoteBalanced = isBalanced '"' '"'

src/GypsFulvus.hs

@@ -68,12 +68,15 @@ lookupManholeInSewer s p = do
 
 corePlugName :: T.Text
 corePlugName = "core"
+
+mySignature :: SewageAutorInfo
 mySignature = GenericStyleAutor corePlugName "local" "local"
 
 isIOPlugin :: Sewage -> TMVar IOPIDS -> IO Bool
-isIOPlugin sewage iopids = let pname = (hash . getName .nsAutorToGenericAutor . getSewageAutor $ sewage)
+isIOPlugin sewage iopids = let pname = (hash . getLocation .nsAutorToGenericAutor . getSewageAutor $ sewage)
                     in do
   IOPIDS iop <- atomically $ readTMVar iopids
+
   return $ pname `elem` iop
 
 runForever :: TMVar Sewer -> TMVar(CommandMap) -> TMVar(IOPIDS) -> IO ()
@@ -91,7 +94,7 @@ runForever s cmap iopids =
        if (amIIO) then
          trySendToWorker s someGarbage cmap
        else do
-         pm <- atomically $ lookupManholeInSewer s "IRC-Simple"
+         pm <- atomically $ lookupManholeInSewer s (getName . nsAutorToGenericAutor . getSewageAutor $ someGarbage)
          case pm of
            Just pm -> regiftToWorker someGarbage pm
            Nothing -> return ()
@@ -125,24 +128,42 @@ makeManhole s p = do
     Nothing -> return Nothing
 
 
-tryRegisterPlugin :: TMVar(Sewer) -> T.Text -> (Manhole -> IO InitStatus) -> [T.Text] -> IO InitStatus
+
-tryRegisterPlugin s plugName initFunc tellCommandsFunc = do
+registerPlugin_
-  im <- makeManhole s plugName
+  :: TMVar Sewer
-  case im of
+     -> T.Text -> (Manhole -> IO InitStatus) -> IO InitStatus
-    Just im' -> do
+registerPlugin_ s plugName initFunc = do
-      moduleInitStatus <- initFunc im'
+      im <- makeManhole s plugName
-      case moduleInitStatus of
+      case im of
-        GoodInitStatus -> do
+        Just im' -> do
-          atomically $ assCallbackWithManholeInSewer s plugName im'
+          moduleInitStatus <- initFunc im'
-          return GoodInitStatus
+          case moduleInitStatus of
-        BadInitStatus errs -> return $ BadInitStatus $ "couldn't load the " ++ plugName ++ " plugin: " ++ errs
+            GoodInitStatus -> do
-    Nothing -> return $ BadInitStatus $ T.pack "Catastrophic failure - core ejected."
+              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."
 
 
+tryRegisterPlugin
+  :: TMVar Sewer
+     -> TMVar IOPIDS -> TMVar CommandMap -> CarrionPlugin -> IO InitStatus
+tryRegisterPlugin s iopids commandMap plugin = do
+  let plugName = tellPlugName plugin
+  let initFunc = initPlugin plugin
+  let tellFunc = tellCommands plugin
+  theStatus <- registerPlugin_ s plugName initFunc
+  atomically $ registerCommands commandMap plugName tellFunc
+  case plugin of
+    InputPlugin initFunc tellFunc plugName -> do
+      atomically $ regiop plugName iopids
+      return ()
+    WorkerPlugin _ _ _ -> return ()
+  return theStatus
 makeNewSewer :: Manhole -> IO (TMVar Sewer)
 makeNewSewer coreManhole = do
   let
-    plugName = "core"
+    plugName = corePlugName
   emptySewer <- atomically $ newTMVar $ Sewer M.empty
   atomically $ assCallbackWithManholeInSewer (emptySewer) corePlugName coreManhole
 
@@ -156,24 +177,28 @@ stdioPlugName = "STDIO haskeline"
 
 tclPlugName :: T.Text
 tclPlugName = "TCL-Simple"
+
 ircPlugName :: T.Text
 ircPlugName = "IRC-Simple"
 
+statusBad s = case s of
+  GoodInitStatus -> False
+  BadInitStatus _ -> True
+
 execMain :: IO ()
 execMain = do
+  let cpstdio = InputPlugin CPISTDIO.initPlugin CPISTDIO.tellCommands CPISTDIO.myPlugName
+      ircsimp = InputPlugin IRCSIMP.initPlugin IRCSIMP.tellCommands IRCSIMP.myPlugName
+      tclsimp = WorkerPlugin TCLSIMP.initPlugin TCLSIMP.tellCommands TCLSIMP.myPlugName
+      myPlugins = [cpstdio,ircsimp,tclsimp]
   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 stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands
+  initStatuses <- Par.mapM (tryRegisterPlugin newSewer iopids commandMap ) myPlugins
-  atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands
+  let badstatuses = filter (statusBad) initStatuses
-  atomically $ regiop stdioPlugName iopids
+  if (not . null $ badstatuses) then mapM_ (putStrLn . T.pack . show) initStatuses >> error (T.unpack "Plugin load failed, see above.") else return ()
-  tryRegisterPlugin newSewer ircPlugName IRCSIMP.initPlugin IRCSIMP.tellCommands
-  atomically $ registerCommands commandMap ircPlugName IRCSIMP.tellCommands
-  atomically $ regiop ircPlugName iopids
-  tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands
-  atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands
   let myTIDs  = []
   runForever newSewer commandMap iopids
   mapM_ killThread myTIDs

src/GypsFulvus/PluginStuff.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regiftToWorker) where
+module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix', regiftToWorker, Carrion(..),CarrionPlugin(..)) where
 import Control.Monad
 
 
@@ -78,7 +78,7 @@ data Sewage = Sewage {
 data Manhole = Manhole {
                        getInputChan :: TChan Sewage,
                        getOutputChan :: TChan Sewage}
-data InitStatus = GoodInitStatus | BadInitStatus T.Text
+data InitStatus = GoodInitStatus | BadInitStatus T.Text deriving Show
 
 inspectManhole :: Manhole -> IO Sewage
 inspectManhole = atomically . readTChan . getInputChan
@@ -88,3 +88,14 @@ regift g = atomically . (flip writeTChan g) . getOutputChan
 
 regiftToWorker :: Sewage -> Manhole -> IO ()
 regiftToWorker g = atomically . (flip writeTChan g) . getInputChan
+
+data CarrionPlugin = InputPlugin {getInitPlugin :: (Manhole -> IO InitStatus), getTellCommands :: [T.Text], getMyPlugName :: T.Text} | WorkerPlugin {getInitPlugin :: (Manhole -> IO InitStatus), getTellCommands :: [T.Text], getMyPlugName :: T.Text}
+
+class Carrion a where
+  initPlugin :: a -> Manhole -> IO InitStatus
+  tellCommands :: a -> [T.Text]
+  tellPlugName :: a -> T.Text
+instance Carrion CarrionPlugin where
+  initPlugin = getInitPlugin
+  tellCommands = getTellCommands
+  tellPlugName = getMyPlugName