update API again.. provide utils
This commit is contained in:
parent
f97c57d773
commit
bf46dd0be3
@ -24,7 +24,8 @@ library
|
|||||||
containers,
|
containers,
|
||||||
text,
|
text,
|
||||||
plugins >= 1.6.0,
|
plugins >= 1.6.0,
|
||||||
directory
|
directory,
|
||||||
|
hashable
|
||||||
ghc-options:
|
ghc-options:
|
||||||
-O2
|
-O2
|
||||||
-threaded
|
-threaded
|
||||||
@ -38,7 +39,8 @@ executable GypsFulvus
|
|||||||
containers,
|
containers,
|
||||||
text,
|
text,
|
||||||
plugins >= 1.6.0,
|
plugins >= 1.6.0,
|
||||||
directory
|
directory,
|
||||||
|
hashable
|
||||||
ghc-options:
|
ghc-options:
|
||||||
-O2
|
-O2
|
||||||
-threaded
|
-threaded
|
||||||
|
@ -1,23 +1,51 @@
|
|||||||
module GypsFulvus(execMain, Manhole(..), Sewage(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor) where
|
module GypsFulvus(execMain, Manhole(..), Sewage(..), InitStatus(..), SewageAutorInfo(..), IrcMask(..), genericAutorToNSAutor, nsAutorToGenericAutor, regift,stripCommandPrefix',inspectManhole) where
|
||||||
import Control.Concurrent.STM (atomically, retry)
|
import Control.Concurrent.STM
|
||||||
import Control.Concurrent.STM.TMVar
|
import Control.Concurrent.STM.TMVar
|
||||||
import Control.Concurrent.STM.TChan
|
import Control.Concurrent.STM.TChan
|
||||||
import qualified Data.Map as M
|
import System.Directory
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Control.Concurrent(ThreadId, forkIO, killThread)
|
import Control.Concurrent(ThreadId, forkIO, killThread)
|
||||||
import GypsFulvus.PluginStuff
|
import GypsFulvus.PluginStuff
|
||||||
import Control.Monad(liftM)
|
import Control.Monad(liftM)
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
|
import Data.Hashable
|
||||||
data Placeholder = Placeholder
|
data Placeholder = Placeholder
|
||||||
data CommandMap = CommandMap (M.Map T.Text Placeholder)
|
data CommandMap = CommandMap (M.Map T.Text Placeholder)
|
||||||
data CommandWorkspace = CommandWorkspace 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
|
dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
|
||||||
-- broadcast ouputs from routines to all (interested) parties
|
-- broadcast ouputs from routines to all (interested) parties
|
||||||
broadcastToConsumers consumerBroadcastChannel sharedCommandWorkspace sharedTaskQueue = undefined
|
broadcastToConsumers consumerBroadcastChannel sharedCommandWorkspace sharedTaskQueue = undefined
|
||||||
-- collect all input from all comms plugins and queue for dispatch
|
-- collect all input from all comms plugins and queue for dispatch
|
||||||
collectInputs collectorChannel availableCommandMap sharedCommandWorkspace sharedTaskQueue = undefined
|
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 :: TMVar Bool -> IO ()
|
||||||
runForever diediedie =
|
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
|
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
|
registerComms = undefined
|
||||||
|
|
||||||
|
loadIOBackends sewer = undefined
|
||||||
|
loadCoreCommands = undefined
|
||||||
|
|
||||||
execMain :: IO ()
|
execMain :: IO ()
|
||||||
execMain = do
|
execMain = do
|
||||||
collectorChannel <- atomically newTChan -- normal channel for dumping any user input
|
collectorChannel <- atomically newTChan -- normal channel for dumping any user input, this is the output channel for all plugins
|
||||||
consumerBroadcastChannel <- atomically newBroadcastTChan
|
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
|
canary <- atomically $ newTMVar False -- simple 'should I exit' canary
|
||||||
forkIO $ loadCommsPlugins canary collectorChannel
|
|
||||||
|
-- forkIO $ loadCommsPlugins canary collectorChannel
|
||||||
|
|
||||||
-- availableCommandMap <- atomically $ newTMVar CommandMap
|
-- availableCommandMap <- atomically $ newTMVar CommandMap
|
||||||
-- loadLabourPlugins availableCommandMap
|
-- loadLabourPlugins availableCommandMap
|
||||||
-- sharedCommandWorkspace <- atomically $ newTMVar CommandWorkspace
|
-- sharedCommandWorkspace <- atomically $ newTMVar CommandWorkspace
|
||||||
@ -50,3 +82,26 @@ execMain = do
|
|||||||
let myTIDs = []
|
let myTIDs = []
|
||||||
runForever canary
|
runForever canary
|
||||||
mapM_ killThread myTIDs
|
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,11 +1,12 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# 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 Control.Monad
|
||||||
import System.Directory
|
|
||||||
import System.Plugins.Make
|
import System.Plugins.Make
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Concurrent.STM.TMVar
|
import Control.Concurrent.STM.TMVar
|
||||||
|
import qualified Data.List as L
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
(♯) :: T.Text -> T.Text -> T.Text
|
(♯) :: T.Text -> T.Text -> T.Text
|
||||||
@ -13,7 +14,18 @@ a ♯ b = (T.append) a b
|
|||||||
|
|
||||||
tooTeToSt :: T.Text -> T.Text -> String
|
tooTeToSt :: T.Text -> T.Text -> String
|
||||||
tooTeToSt a b = tup $ a ♯ "@" ♯ b
|
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 :: String -> T.Text
|
||||||
tp = T.pack
|
tp = T.pack
|
||||||
tup :: T.Text -> String
|
tup :: T.Text -> String
|
||||||
@ -62,40 +74,7 @@ data Manhole = Manhole {
|
|||||||
getOutputChan :: TChan Sewage}
|
getOutputChan :: TChan Sewage}
|
||||||
data InitStatus = GoodInitStatus | BadInitStatus T.Text
|
data InitStatus = GoodInitStatus | BadInitStatus T.Text
|
||||||
|
|
||||||
srcPluginPath :: IO FilePath
|
inspectManhole :: Manhole -> IO Sewage
|
||||||
srcPluginPath = getXdgDirectory XdgData "gypsfulvus/srcplugins" >>= makeAbsolute
|
inspectManhole = atomically . readTChan . getInputChan
|
||||||
|
regift :: Sewage -> Manhole -> IO ()
|
||||||
|
regift g = atomically . (flip writeTChan g) . getOutputChan
|
||||||
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
|
|
||||||
|
Loading…
x
Reference in New Issue
Block a user