diff --git a/src/Carrion/Plugin/TCL.hs b/src/Carrion/Plugin/TCL.hs index 6fc362d..a33a479 100644 --- a/src/Carrion/Plugin/TCL.hs +++ b/src/Carrion/Plugin/TCL.hs @@ -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 - processedGift <- processCommand wrappedtclinterp giftStripped - regift (Sewage (GenericStyleAutor (T.pack "TCL Intepreter") (T.pack "local") (T.pack "local")) processedGift) manhole + let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped + case hmm of + Nothing -> do + processedGift <- processCommand wrappedtclinterp giftStripped + 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 '"' '"' diff --git a/src/GypsFulvus.hs b/src/GypsFulvus.hs index bb6b8bd..02a3670 100644 --- a/src/GypsFulvus.hs +++ b/src/GypsFulvus.hs @@ -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 diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 index 0000000..fd3222b --- /dev/null +++ b/src/Test.hs @@ -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 '(' ')') )) diff --git a/src/smeggdrop/smeggdrop/interpx.tcl b/src/smeggdrop/smeggdrop/interpx.tcl index 23f450c..20c1866 100644 --- a/src/smeggdrop/smeggdrop/interpx.tcl +++ b/src/smeggdrop/smeggdrop/interpx.tcl @@ -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 { diff --git a/src/smeggdrop/smeggdrop/smeggdrop.tcl b/src/smeggdrop/smeggdrop/smeggdrop.tcl index 72d248e..f7f7f48 100644 --- a/src/smeggdrop/smeggdrop/smeggdrop.tcl +++ b/src/smeggdrop/smeggdrop/smeggdrop.tcl @@ -163,13 +163,12 @@ proc pub:tcl:perform {nick mask hand channel line} { commands::configure nick mask hand channel line commands::increment_eval_count - - set author "$nick on $channel <$mask>" + set author "$nick on $channel <$mask>" + if [catch {$versioned_interpreter eval $line $author} output] { set output "error: $output" } - putlog $output return $output }