clean up
This commit is contained in:
Jon Doe
Maciej Bonin
parent
f874b97291
commit
3a85db15d3
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -49,21 +65,18 @@ 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"
|
||||
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'
|
||||
|
||||
|
||||
registerComms = undefined
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user