diff --git a/GypsFulvus.cabal b/GypsFulvus.cabal index b008be9..04c1b4e 100644 --- a/GypsFulvus.cabal +++ b/GypsFulvus.cabal @@ -24,7 +24,8 @@ library containers, text, plugins >= 1.6.0, - directory + directory, + hashable ghc-options: -O2 -threaded @@ -38,7 +39,8 @@ executable GypsFulvus containers, text, plugins >= 1.6.0, - directory + directory, + hashable ghc-options: -O2 -threaded diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index 64b5447..c84f859 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -1,23 +1,51 @@ -module GypsFulvus(execMain, Manhole(..), Sewage(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor) where -import Control.Concurrent.STM (atomically, retry) +module GypsFulvus(execMain, Manhole(..), Sewage(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, regift,stripCommandPrefix',inspectManhole) where +import Control.Concurrent.STM import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TChan -import qualified Data.Map as M +import System.Directory import qualified Data.Text as T import Control.Concurrent(ThreadId, forkIO, killThread) import GypsFulvus.PluginStuff import Control.Monad(liftM) +import qualified Data.Map.Strict as M +import Data.Hashable data Placeholder = Placeholder data CommandMap = CommandMap (M.Map T.Text Placeholder) data CommandWorkspace = CommandWorkspace Placeholder +data Sewer = Sewer (M.Map Int Manhole) +srcPluginPath :: IO FilePath +srcPluginPath = getXdgDirectory XdgData "gypsfulvus/srcplugins" >>= makeAbsolute +binPluginPath :: IO FilePath +binPluginPath = getXdgDirectory XdgData "gypsfulvus/srcplugins" >>= makeAbsolute + + +configPath :: IO FilePath +configPath = getXdgDirectory XdgConfig "gypsfulvus" + + + +assCallbackWithManholeInSewer + :: Hashable a1 => + TMVar (M.Map Int a2 -> M.Map Int a2) + -> a1 -> a2 -> STM () +assCallbackWithManholeInSewer sewer callback_name callback_manhole = do + sewer_old <- takeTMVar sewer + h_cname <- return $ hash callback_name + putTMVar sewer $ M.insert h_cname callback_manhole + 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 + runForever :: TMVar Bool -> IO () runForever diediedie = @@ -31,14 +59,18 @@ runForever diediedie = if (isDone) then putStrLn "Exiting cleanly." else error "I escaped my eternal prison somehow." -- it shouldn't be possible for the else to be reached unless something melts down registerComms = undefined - +loadIOBackends sewer = undefined +loadCoreCommands = undefined execMain :: IO () execMain = do - collectorChannel <- atomically newTChan -- normal channel for dumping any user input - consumerBroadcastChannel <- atomically newBroadcastTChan + 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 + canary <- atomically $ newTMVar False -- simple 'should I exit' canary - forkIO $ loadCommsPlugins canary collectorChannel + +-- forkIO $ loadCommsPlugins canary collectorChannel + -- availableCommandMap <- atomically $ newTMVar CommandMap -- loadLabourPlugins availableCommandMap -- sharedCommandWorkspace <- atomically $ newTMVar CommandWorkspace @@ -50,3 +82,26 @@ execMain = do let myTIDs = [] runForever canary 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 diff --git a/src/GypsFulvus/PluginStuff.hs b/src/GypsFulvus/PluginStuff.hs index 6f6e5e4..5681a13 100644 --- a/src/GypsFulvus/PluginStuff.hs +++ b/src/GypsFulvus/PluginStuff.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module GypsFulvus.PluginStuff(loadCommsPlugins, Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor) where +module GypsFulvus.PluginStuff(Sewage(..), Manhole(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, inspectManhole, regift, stripCommandPrefix') where import Control.Monad -import System.Directory + import System.Plugins.Make import Data.Maybe import Control.Concurrent.STM import Control.Concurrent.STM.TMVar +import qualified Data.List as L import qualified Data.Text as T (♯) :: T.Text -> T.Text -> T.Text @@ -13,7 +14,18 @@ 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 + Right c -> return c + 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 @@ -62,40 +74,7 @@ data Manhole = Manhole { getOutputChan :: TChan Sewage} data InitStatus = GoodInitStatus | BadInitStatus T.Text -srcPluginPath :: IO FilePath -srcPluginPath = getXdgDirectory XdgData "gypsfulvus/srcplugins" >>= makeAbsolute - - -configPath :: IO FilePath -configPath = getXdgDirectory XdgConfig "gypsfulvus" - - - - --- load all the plugins for IO (e.g. IRC, stdio, maybe matrix procol, telnet, whatever) - - - -loadCommsPlugins 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 () - - --- 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 +inspectManhole :: Manhole -> IO Sewage +inspectManhole = atomically . readTChan . getInputChan +regift :: Sewage -> Manhole -> IO () +regift g = atomically . (flip writeTChan g) . getOutputChan