wrath/shaniqua-core
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add stuff

Browse Source
This commit is contained in:
Jon Doe 2020-09-23 20:17:56 +02:00 committed by Maciej Bonin
parent 912a88004b
commit 90996dfcb6
5 changed files with 116 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

138
src/Carrion/Plugin/TCL.hs
View File

@ -6,7 +6,7 @@ module Carrion.Plugin.TCL
tellCommands
) where
import Control.Monad
import Control.Concurrent(forkIO)
import Control.Concurrent(forkIO, threadDelay, killThread)
import Control.Concurrent.STM
import System.Posix.DynamicLinker
import System.Environment
@ -30,21 +30,27 @@ data TCLCommand = TCLCommand {getTCLCNick :: String,
getTCLCActualCommand :: String
}
type Tcl_EvalFile_Sig = (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int)
type Tcl_EvalEx_Sig = (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int)
type Tcl_GetStringResult_Sig = (Tcl_Interp_Ptr -> IO CString)
type Tcl_CancelEval_Sig = (Tcl_Interp_Ptr -> Ptr Tcl_Obj_Dummy -> Ptr Tcl_ClientData_Dummy -> Int -> IO Int)
type Tcl_AsyncInvoke_Sig = (Tcl_Interp_Ptr -> Int -> IO Int)
foreign import ccall "dynamic" mkTcl_CreateInterp :: FunPtr (IO Tcl_Interp_Ptr) -> IO (Tcl_Interp_Ptr)
data Tcl_Obj_Dummy = Tcl_Obj_Dummy
data Tcl_ClientData_Dummy = Tcl_ClientData_Dummy
foreign import ccall "&Tcl_InitStubs_wrap" tcl_InitStubs :: FunPtr (Tcl_Interp_Ptr -> TCL_Wanted_Version -> WantExact -> IO TCL_Actual_Version)
foreign import ccall "dynamic" mkTcl_InitStubs :: FunPtr (Tcl_Interp_Ptr -> TCL_Wanted_Version -> WantExact -> IO TCL_Actual_Version) -> (Tcl_Interp_Ptr -> TCL_Wanted_Version -> WantExact -> IO TCL_Actual_Version)
foreign import ccall "dynamic" mkTcl_FindExecutable :: FunPtr (CString -> IO CString) -> (CString -> IO CString)
foreign import ccall "dynamic" mkTcl_InitMemory :: FunPtr (Tcl_Interp_Ptr -> IO ()) -> (Tcl_Interp_Ptr -> IO ())
foreign import ccall "dynamic" mkTcl_Init :: FunPtr (Tcl_Interp_Ptr -> IO Int) -> (Tcl_Interp_Ptr -> IO Int)
foreign import ccall "dynamic" mkTcl_EvalFile :: FunPtr (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int) -> (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int)
foreign import ccall "dynamic" mkTcl_GetStringResult :: FunPtr (Tcl_Interp_Ptr -> IO CString) -> (Tcl_Interp_Ptr -> IO CString)
foreign import ccall "dynamic" mkTcl_CancelEval :: FunPtr Tcl_CancelEval_Sig -> Tcl_CancelEval_Sig
foreign import ccall "dynamic" mkTcl_AsyncInvoke :: FunPtr Tcl_AsyncInvoke_Sig -> Tcl_AsyncInvoke_Sig
foreign import ccall "dynamic" mkTcl_EvalFile :: FunPtr Tcl_EvalFile_Sig -> Tcl_EvalFile_Sig
foreign import ccall "dynamic" mkTcl_GetStringResult :: FunPtr Tcl_GetStringResult_Sig -> Tcl_GetStringResult_Sig
foreign import ccall "dynamic" mkTcl_EvalEx :: FunPtr (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int) -> (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int)
type Tcl_EvalFile_Sig = (Tcl_Interp_Ptr -> TclScriptFilename -> IO Int)
type Tcl_EvalEx_Sig = (Tcl_Interp_Ptr -> TclScriptString -> TclScriptStringByteLen -> TclEvalFlags -> IO Int)
type Tcl_GetStringResult_Sig = (Tcl_Interp_Ptr -> IO CString)
tu :: T.Text -> String
tu = T.unpack
tellCommands :: [T.Text]
@ -66,65 +72,18 @@ fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson b = case b of
mkTCLCommandFromAIAndMsg :: SewageAutorInfo -> String -> TCLCommand
mkTCLCommandFromAIAndMsg = fuckingSewageAutorToFuckingTCLCommandFormatFuckYouSamStephenson
data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: Tcl_Interp_Ptr,
data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Interp_Ptr),
getEvalFile :: Tcl_EvalFile_Sig,
getEvalEx :: Tcl_EvalEx_Sig,
getGetStringResult :: Tcl_GetStringResult_Sig
getGetStringResult :: Tcl_GetStringResult_Sig,
getCancelEval :: Tcl_CancelEval_Sig,
getAsyncInvoke :: Tcl_AsyncInvoke_Sig
}
lEN_AUTO :: Int
lEN_AUTO = -1
eVAL_FLAGS_CLEAR :: Int
eVAL_FLAGS_CLEAR = 0
testThing :: IO ()
testThing = do
myFakeArg0 <- getExecutablePath >>= newCString
myTCLDl <- dlopen "/usr/lib/libtcl8.6.so" [RTLD_NOW]
myFunTcl_CreateInterp <- dlsym myTCLDl "Tcl_CreateInterp"
let tcl_CreateInterp = mkTcl_CreateInterp myFunTcl_CreateInterp
interp <- tcl_CreateInterp
let tcl_InitStubs' = mkTcl_InitStubs tcl_InitStubs
wanted_interp_version <- newCString "8.6"
actual_version_c <- tcl_InitStubs' interp wanted_interp_version 0
actual_version <- peekCString actual_version_c
putStrLn actual_version
myFunTcl_FindExecutable <- dlsym myTCLDl "Tcl_FindExecutable"
let tcl_FindExecutable = mkTcl_FindExecutable myFunTcl_FindExecutable
theComputedExecutablePath <- tcl_FindExecutable $ myFakeArg0
if nullPtr == theComputedExecutablePath then
putStrLn "Couldn't Tcl_FindExecutable()"
else
peekCString theComputedExecutablePath >>= putStrLn
myFunTcl_InitMemory <- dlsym myTCLDl "Tcl_InitMemory"
let tcl_InitMemory = mkTcl_InitMemory myFunTcl_InitMemory
tcl_InitMemory interp
myFunTcl_Init <- dlsym myTCLDl "Tcl_Init"
let tcl_Init = mkTcl_Init myFunTcl_Init
tcl_Init_status <- tcl_Init interp
myFunTcl_EvalEx <- dlsym myTCLDl "Tcl_EvalEx"
let tcl_EvalEx = mkTcl_EvalEx myFunTcl_EvalEx
testScript <- newCString "set a [expr 2 + 2]; puts $a;"
let runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
let runTclCommand s = newCString s >>= runscript
testScriptStatus <- runscript testScript
putStrLn $ show testScriptStatus
newCString "puts \"test persistence [expr $a +2]\";" >>= runscript >>= putStrLn . show
let bless name convf = dlsym myTCLDl name >>= \fp -> return . convf $ fp
tcl_GetStringResult <- bless "Tcl_GetStringResult" mkTcl_GetStringResult
let errorInfo = runTclCommand "puts $errorInfo"
doTheTCL c = runTclCommand c >>= \st ->
case st of
0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then putStrLn ("Command: " ++ c ++" ; returned a null pointer result.") else peekCString rs >>= \nrs -> putStrLn ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";")
_ -> errorInfo>> return ()
fakeFromIRC c = doTheTCL $ "return [pub:tcl:perform root test!test@test.org test #test {" ++ c ++ "}]"
tcl_EvalFile <- bless "Tcl_EvalFile" mkTcl_EvalFile
smeginitstatus <- newCString "/home/pszczola/Carrion-Plugin-TCL/src/smeggdrop/smeggdrop.tcl" >>= \fn -> tcl_EvalFile interp fn
--newCString "puts $errorInfo;" >>= runscript >>= putStrLn . show
errorInfo
runTclCommand "puts $SMEGGDROP_ROOT"
putStrLn $ show $ smeginitstatus
-- fakeFromIRC "proc testo4444 args {return \"booboo\n\"}"
dumpDebug _ = return ()
@ -156,8 +115,12 @@ initPlugin manhole = do
tcl_EvalEx <- bless "Tcl_EvalEx" mkTcl_EvalEx
tcl_GetStringResult <- bless "Tcl_GetStringResult" mkTcl_GetStringResult
tcl_EvalFile <- bless "Tcl_EvalFile" mkTcl_EvalFile
tcl_CancelEval <- bless "Tcl_CancelEval" mkTcl_CancelEval
tcl_AsyncInvoke <- bless "Tcl_AsyncInvoke" mkTcl_AsyncInvoke
smeginitstatus <- newCString "./src/smeggdrop/smeggdrop.tcl" >>= \fn -> tcl_EvalFile interp fn
let wrappedinterp = TCLInterpreterWrapper interp tcl_EvalFile tcl_EvalEx tcl_GetStringResult
threadsafe_interp_duh <- atomically $ newTMVar interp
let wrappedinterp = TCLInterpreterWrapper threadsafe_interp_duh tcl_EvalFile tcl_EvalEx tcl_GetStringResult tcl_CancelEval tcl_AsyncInvoke
forkIO $ rEPL wrappedinterp manhole
return GoodInitStatus
@ -168,22 +131,36 @@ processCommand :: TCLInterpreterWrapper -> Sewage -> IO T.Text
processCommand wi s = do
let tcl_EvalEx = getEvalEx wi
tcl_GetStringResult = getGetStringResult wi
interp = getInterp wi
runscript s = tcl_EvalEx interp s lEN_AUTO eVAL_FLAGS_CLEAR
runTclCommand s = newCString s >>= runscript
errorInfo = runTclCommand "return $errorInfo"
tcl_CancelEval = getCancelEval wi
tcl_AsyncInvoke = getAsyncInvoke wi
i = getInterp wi
autInfo = getSewageAutor s
sewCmd = T.unpack $ getSewage s
autDefNS = genericAutorToNSAutor autInfo
sewNick = T.unpack $ getNick autDefNS
sewMask = show $ getMask autDefNS
sewChan = T.unpack $ getChannel autDefNS
interp <- atomically $ takeTMVar i
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 $ "return [pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}]"
performFromIRC >>= return . T.pack
performFromIRC = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ 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 <- performFromIRC
-- putStrLn "putting back the interp"
atomically $ putTMVar i interp
return $ T.pack res
rEPL wrappedtclinterp manhole =
let inspectManhole = atomically . readTChan . getInputChan
@ -194,6 +171,35 @@ rEPL wrappedtclinterp manhole =
case strippedCmd of
Just cmdBodyStripped -> do
let giftStripped = Sewage (getSewageAutor newGift) cmdBodyStripped
let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped
case hmm of
Nothing -> do
processedGift <- processCommand wrappedtclinterp giftStripped
regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) processedGift) manhole
regift (Sewage mySignature 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
bal :: Int -> Int -> String -> Maybe String
bal _ 0 [] = Nothing
bal i _ [] = Just $ "Opening bracket unmatched until end of command." -- unmatched opening
bal i (-1) _ = Just $ "Unmatched closing bracket at position " ++ show i -- unmatched close
bal i n (singlec:bs)
| singlec == openc = bal (i + 1) (n + 1) bs
| singlec == closec = bal (i + 1) (n - 1) bs
| singlec == '\\' = case bs of
(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 = 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 = isBalanced '[' ']'
dquoteBalanced = isBalanced '"' '"'

15
src/GypsFulvus.hs
View File

@ -47,7 +47,7 @@ assCallbackWithManholeInSewer sewer callback_name callback_manhole = do
lookupManholeInSewer :: TMVar(Sewer) -> T.Text -> STM (Maybe Manhole)
lookupManholeInSewer s p = do
s_l <- readTMVar s
return $ traceShow (hash p) $ M.lookup (hash p) (getSewerMap s_l)
return $ M.lookup (hash p) (getSewerMap s_l)
dispatchCommands sharedCommandWorkspace sharedTaskQueue = undefined
-- broadcast ouputs from routines to all (interested) parties
@ -73,14 +73,19 @@ runForever s =
someGarbage <- atomically block
let theAutor = show $ getSewageAutor someGarbage
let theSewage = getSewage someGarbage
putStrLn $ (T.pack theAutor) ++ " sez:"
putStrLn $ theSewage
threadDelay 1000000
if (theAutor == "local:STDIO haskeline@local" && ("tcl " `T.isPrefixOf` theSewage)) then sendToTCL s someGarbage else return ()
if (theAutor == "local:STDIO haskeline@local") then
if ("tcl " `T.isPrefixOf` theSewage) then
sendToTCL s someGarbage
else
return ()
else do
putStrLn $ T.pack theAutor ++ " sez:"
putStrLn theSewage
sendToTCL sewer sewage = do
m <- atomically $ lookupManholeInSewer sewer "TCL-Simple"
case m of
Just m -> traceShow (getSewageAutor sewage,getSewage sewage) regift' sewage m
Just m -> regift' sewage m
Nothing -> putStrLn "couldn't find TCL submodule"
registerComms = undefined

29
src/Test.hs Normal file
View File

@ -0,0 +1,29 @@
import System.Environment
import Control.Monad
import Data.Maybe
-- 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
bal :: Int -> Int -> String -> Maybe String
bal _ 0 [] = Nothing
bal i _ [] = Just $ "Opening bracket unmatched until end of command." -- unmatched opening
bal i (-1) _ = Just $ "Unmatched closing bracket at position " ++ show i -- unmatched close
bal i n (singlec:bs)
| singlec == openc = bal (i + 1) (n + 1) bs
| singlec == closec = bal (i + 1) (n - 1) bs
| singlec == '\\' = case bs of
(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 = 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 = isBalanced '[' ']'
dquoteBalanced = isBalanced '"' '"'
main = getArgs >>= (mapM (putStrLn . show . (isBalanced '(' ')') ))

6
src/smeggdrop/smeggdrop/interpx.tcl
View File

@ -135,9 +135,9 @@ method {inspect proc} proc {
signal trap SIGALRM [list ::interpx::timeout $self $private_key]
alarm [expr {[$self cget -timeout] / 1000.0}]
}
interp limit $interp time -seconds [clock add [clock seconds] 5 seconds]
set code [catch {$interp eval $script} result]
interp limit $interp time -seconds {}
if $timeout {
alarm 0
if $timed_out {
@ -329,7 +329,6 @@ method {inspect proc} proc {
$self unset_internal_vars
$self initialize_private_namespace
puts "initialize_interpreter inside interpx finished"
}
method unset_internal_vars {} {
@ -344,7 +343,6 @@ method {inspect proc} proc {
$interp alias ::interpx::timeout ::interpx::timeout
$self expose {did touch var} ::interpx::touched_var
puts "finished initialize_private_namespace inside interpx"
}
method hide command {

1
src/smeggdrop/smeggdrop/smeggdrop.tcl
View File

@ -169,7 +169,6 @@ proc pub:tcl:perform {nick mask hand channel line} {
if [catch {$versioned_interpreter eval $line $author} output] {
set output "error: $output"
}
putlog $output
return $output
}