shaniqua-core/src/Carrion/Plugin/TCL.hs

{-# LANGUAGE ForeignFunctionInterface #-}

module Carrion.Plugin.TCL
    ( initPlugin,
      tellCommands,
      myPlugName
    ) where
import Control.Monad
import Control.Concurrent(forkIO, threadDelay, killThread)
import Control.Concurrent.STM
import System.Posix.DynamicLinker
import System.Environment
import Foreign.Ptr
import Foreign.C.String
import qualified Data.Text as T
import GypsFulvus.PluginStuff(Manhole(..),Sewage(..), InitStatus(..),SewageAutorInfo(..),genericAutorToNSAutor, stripCommandPrefix', regift, nsAutorToGenericAutor)
data Tcl_Interp = Tcl_Interp deriving Show
type Tcl_Interp_Ptr = Ptr Tcl_Interp
type TCL_Actual_Version = CString
type TCL_Wanted_Version = CString
type TclScriptString = CString
type TclScriptStringByteLen = Int
type TclEvalFlags = Int
type WantExact = Int
type TclScriptFilename = CString
data TCLCommand = TCLCommand {getTCLCNick :: String,
                              getTCLCMask :: String,
                              getTCLCHandle_o_O:: String,
                              getTCLCChannel :: 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_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)

tu :: T.Text -> String
tu = T.unpack

tellCommands :: [T.Text]
tellCommands = map T.pack ["tcl","tclAdmin"]

privilegedAutors :: [T.Text]
privilegedAutors = map T.pack ["core","STDIO haskeline","hastur","IRC-Simple"]

myPluginName :: T.Text
myPluginName = T.pack "TCL-Simple"
myPlugName = myPluginName
lOCAL :: T.Text
lOCAL = T.pack "local"

mySignature :: SewageAutorInfo
mySignature = GenericStyleAutor myPluginName myPluginName lOCAL

sigWithChan :: T.Text -> SewageAutorInfo
sigWithChan ch = GenericStyleAutor myPluginName myPluginName ch

stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature


mkTCLCommandFromAIAndMsg :: SewageAutorInfo -> String -> TCLCommand
mkTCLCommandFromAIAndMsg b = case b of
  GenericStyleAutor a b c -> mkTCLCommandFromAIAndMsg . genericAutorToNSAutor $ GenericStyleAutor a b c
  NetworkIdentStyleAutor a b c -> TCLCommand (tu a) (show b) "" (tu c)
  
data TCLInterpreterWrapper = TCLInterpreterWrapper {getInterp :: TMVar(Tcl_Interp_Ptr),
                                                    getEvalFile :: Tcl_EvalFile_Sig,
                                                    getEvalEx :: Tcl_EvalEx_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

--dumpDebug :: Monad m => p -> m ()
--dumpDebug _ = return ()
dumpDebug = putStrLn
initPlugin :: Manhole -> IO InitStatus
initPlugin manhole = do
  myFakeArg0 <- getExecutablePath >>= newCString
  myTCLDl <- dlopen "libtcl8.6.so" [RTLD_NOW]
  let bless name convf = dlsym myTCLDl name >>= \fp -> return $ convf $ fp
  tcl_CreateInterp <- bless "Tcl_CreateInterp" mkTcl_CreateInterp
  interp <- tcl_CreateInterp
  let tcl_InitStubs' = mkTcl_InitStubs tcl_InitStubs
  wanted_interp_version <- newCString "8.6"
  actual_version <- tcl_InitStubs' interp wanted_interp_version 0 >>= peekCString
  dumpDebug actual_version
  tcl_FindExecutable <- bless "Tcl_FindExecutable" mkTcl_FindExecutable
  theComputedExecutablePath <- tcl_FindExecutable $ myFakeArg0
  if nullPtr == theComputedExecutablePath then
    dumpDebug "Couldn't Tcl_FindExecutable()"
  else
    peekCString theComputedExecutablePath >>= dumpDebug
  tcl_InitMemory <- bless "Tcl_InitMemory" mkTcl_InitMemory
  tcl_InitMemory interp
  tcl_Init <- bless "Tcl_Init" mkTcl_Init
  tcl_Init_status <- tcl_Init interp
  dumpDebug $ show tcl_Init_status
  if (tcl_Init_status /= 0) then
    return $ BadInitStatus $ T.pack "non-zero return"
  else 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
    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




processCommand :: TCLInterpreterWrapper -> Sewage -> Bool -> IO T.Text
processCommand wi s ip = do
  let tcl_EvalEx = getEvalEx wi
      tcl_GetStringResult = getGetStringResult wi
      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 $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
      performAdminLevel = doTheTCL sewCmd
  res <- if (ip) then performAdminLevel else performFromIRC
  atomically $ putTMVar i interp
  return $ T.pack res

sigWithChan' :: T.Text -> T.Text -> SewageAutorInfo
sigWithChan' thechannel originallocation = GenericStyleAutor originallocation myPluginName thechannel

rEPL :: TCLInterpreterWrapper -> Manhole -> IO b
rEPL wrappedtclinterp manhole =
  let inspectManhole = atomically . readTChan . getInputChan
      regift g = atomically . (flip writeTChan g) . getOutputChan in
  forever $ do
    newGift <- inspectManhole manhole
    strippedCmd <- stripCommandLocal (getSewage newGift) manhole
    case strippedCmd of
      Just cmdBodyStripped -> do
        let giftStripped = Sewage (getSewageAutor newGift) cmdBodyStripped
        let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped
        case hmm of
          Nothing -> do
            let theOriginalChannel = getContext . nsAutorToGenericAutor . getSewageAutor $ newGift
                theOriginalPlugin = getLocation . nsAutorToGenericAutor . getSewageAutor $ newGift
            let isPrivileged = if T.pack "tclAdmin " `T.isPrefixOf` (getSewage newGift) && ( getNick . genericAutorToNSAutor . getSewageAutor $ newGift) `elem` privilegedAutors then True else False
            processedGift <- processCommand wrappedtclinterp giftStripped isPrivileged
            regift (Sewage (sigWithChan' theOriginalChannel theOriginalPlugin) processedGift) manhole
          Just berror -> regift (Sewage mySignature (T.pack berror)) manhole
      Nothing -> return ()

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 :: String -> Maybe String
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 :: String -> Maybe String
squareBalanced = isBalanced '[' ']'

dquoteBalanced :: String -> Maybe String
dquoteBalanced = isBalanced '"' '"'