{-# LANGUAGE OverloadedStrings #-}

module PMS.Infra.CmdRun.DS.Utility where

import System.Log.FastLogger
import qualified Control.Exception.Safe as E
import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Concurrent.STM as STM
import System.Exit
import Control.Lens

import qualified PMS.Domain.Model.DM.Type as DM
import qualified PMS.Domain.Model.DS.Utility as DM
import PMS.Infra.CmdRun.DM.Type

-- |
--
runApp :: DM.DomainData -> AppData -> TimedFastLogger -> AppContext a -> IO (Either DM.ErrorData a)
runApp :: forall a.
DomainData
-> AppData
-> TimedFastLogger
-> AppContext a
-> IO (Either ErrorData a)
runApp DomainData
domDat AppData
appDat TimedFastLogger
logger AppContext a
ctx =
  DomainData
-> TimedFastLogger
-> LoggingT IO (Either ErrorData a)
-> IO (Either ErrorData a)
forall a. DomainData -> TimedFastLogger -> LoggingT IO a -> IO a
DM.runFastLoggerT DomainData
domDat TimedFastLogger
logger
    (LoggingT IO (Either ErrorData a) -> IO (Either ErrorData a))
-> LoggingT IO (Either ErrorData a) -> IO (Either ErrorData a)
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorData (LoggingT IO) a
-> LoggingT IO (Either ErrorData a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (ExceptT ErrorData (LoggingT IO) a
 -> LoggingT IO (Either ErrorData a))
-> ExceptT ErrorData (LoggingT IO) a
-> LoggingT IO (Either ErrorData a)
forall a b. (a -> b) -> a -> b
$ (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) a
 -> DomainData -> ExceptT ErrorData (LoggingT IO) a)
-> DomainData
-> ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) a
-> ExceptT ErrorData (LoggingT IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) a
-> DomainData -> ExceptT ErrorData (LoggingT IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DomainData
domDat
    (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) a
 -> ExceptT ErrorData (LoggingT IO) a)
-> ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) a
-> ExceptT ErrorData (LoggingT IO) a
forall a b. (a -> b) -> a -> b
$ AppContext a
-> AppData
-> ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT AppContext a
ctx AppData
appDat


-- |
--
liftIOE :: IO a -> AppContext a
liftIOE :: forall a. IO a -> AppContext a
liftIOE IO a
f = IO (Either ErrorData a)
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)))
     (Either ErrorData a)
forall a. IO a -> AppContext a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either ErrorData a)
forall b. IO b -> IO (Either ErrorData b)
go IO a
f) ReaderT
  AppData
  (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)))
  (Either ErrorData a)
-> (Either ErrorData a
    -> ReaderT
         AppData (ReaderT DomainData (ExceptT ErrorData (LoggingT IO))) a)
-> ReaderT
     AppData (ReaderT DomainData (ExceptT ErrorData (LoggingT IO))) a
forall a b.
ReaderT
  AppData (ReaderT DomainData (ExceptT ErrorData (LoggingT IO))) a
-> (a
    -> ReaderT
         AppData (ReaderT DomainData (ExceptT ErrorData (LoggingT IO))) b)
-> ReaderT
     AppData (ReaderT DomainData (ExceptT ErrorData (LoggingT IO))) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either ErrorData a
-> ReaderT
     AppData (ReaderT DomainData (ExceptT ErrorData (LoggingT IO))) a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
  where
    go :: IO b -> IO (Either String b)
    go :: forall b. IO b -> IO (Either ErrorData b)
go IO b
x = IO (Either ErrorData b)
-> (SomeException -> IO (Either ErrorData b))
-> IO (Either ErrorData b)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
E.catchAny (b -> Either ErrorData b
forall a b. b -> Either a b
Right (b -> Either ErrorData b) -> IO b -> IO (Either ErrorData b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b
x) SomeException -> IO (Either ErrorData b)
forall a. SomeException -> IO (Either ErrorData a)
errHdl

    errHdl :: E.SomeException -> IO (Either String a)
    errHdl :: forall a. SomeException -> IO (Either ErrorData a)
errHdl = Either ErrorData a -> IO (Either ErrorData a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorData a -> IO (Either ErrorData a))
-> (SomeException -> Either ErrorData a)
-> SomeException
-> IO (Either ErrorData a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorData -> Either ErrorData a
forall a b. a -> Either a b
Left (ErrorData -> Either ErrorData a)
-> (SomeException -> ErrorData)
-> SomeException
-> Either ErrorData a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ErrorData
forall a. Show a => a -> ErrorData
show

{-
-- |
--
validateCommand :: String -> AppContext String
validateCommand cmd = do
  when (null cmd) $
    throwError "Command is empty."

  when (".." `T.isInfixOf` tcmd) $
    throwError "Command contains directory traversal '..'."

  when ("/" `T.isInfixOf` tcmd) $
    throwError "Command must not contain '/'."

  when ("\\" `T.isInfixOf` tcmd) $
    throwError "Command must not contain '\\'."

  when (any (not . isAllowedChar) cmd) $
    throwError $ "Command contains disallowed characters: " ++ cmd

  return cmd

  where
    tcmd = T.pack cmd
    isAllowedChar c = isAlphaNum c || c `elem` ("-._" :: String)
  

-- |
--
validateCommandArg :: String -> AppContext String
validateCommandArg arg = do
  let tArg = T.pack arg
  when (hasDangerousChars tArg) $
    throwError $ "Argument contains potentially dangerous characters: " <> arg
  return arg
  where
    hasDangerousChars :: T.Text -> Bool
    hasDangerousChars txt =
      any (`T.isInfixOf` txt) [";", "&&", "|", "$", "`", "<", ">", "\\", "\""]

-- |
--
validateCommandArgs :: [String] -> AppContext [String]
validateCommandArgs = mapM validateCommandArg


-- |
--
validateMessage :: String -> IO String
validateMessage cmd = do
  when (any (`elem` forbiddenChars) cmd) $
    E.throwString "Command contains forbidden characters."

  case words cmd of
    (firstWord : _) -> when (firstWord `elem` forbiddenCommands) $
                        E.throwString "Command is forbidden."
    _ -> return ()

  return cmd
  where
    forbiddenChars :: [Char]
    forbiddenChars = [';', '&', '|', '`']

    forbiddenCommands :: [String]
    forbiddenCommands = ["rm", "mv", "dd", "chmod", "chown", "shutdown", "reboot", "kill", "nc", "telnet", "ssh"]
-}

-- |
--
toolsCallResponse :: STM.TQueue DM.McpResponse
                  -> DM.JsonRpcRequest
                  -> ExitCode
                  -> String
                  -> String
                  -> IO ()
toolsCallResponse :: TQueue McpResponse
-> JsonRpcRequest -> ExitCode -> ErrorData -> ErrorData -> IO ()
toolsCallResponse TQueue McpResponse
resQ JsonRpcRequest
jsonRpc ExitCode
code ErrorData
outStr ErrorData
errStr = do
  let content :: [McpToolsCallResponseResultContent]
content = [ ErrorData -> ErrorData -> McpToolsCallResponseResultContent
DM.McpToolsCallResponseResultContent ErrorData
"text" ErrorData
outStr
                , ErrorData -> ErrorData -> McpToolsCallResponseResultContent
DM.McpToolsCallResponseResultContent ErrorData
"text" ErrorData
errStr
                ]
      result :: McpToolsCallResponseResult
result = DM.McpToolsCallResponseResult {
                  _contentMcpToolsCallResponseResult :: [McpToolsCallResponseResultContent]
DM._contentMcpToolsCallResponseResult = [McpToolsCallResponseResultContent]
content
                , _isErrorMcpToolsCallResponseResult :: Bool
DM._isErrorMcpToolsCallResponseResult = (ExitCode
ExitSuccess ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
code)
                }
      resDat :: McpToolsCallResponseData
resDat = JsonRpcRequest
-> McpToolsCallResponseResult -> McpToolsCallResponseData
DM.McpToolsCallResponseData JsonRpcRequest
jsonRpc McpToolsCallResponseResult
result
      res :: McpResponse
res = McpToolsCallResponseData -> McpResponse
DM.McpToolsCallResponse McpToolsCallResponseData
resDat

  STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue McpResponse -> McpResponse -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue McpResponse
resQ McpResponse
res


-- |
--
errorToolsCallResponse :: DM.JsonRpcRequest -> String -> AppContext ()
errorToolsCallResponse :: JsonRpcRequest -> ErrorData -> AppContext ()
errorToolsCallResponse JsonRpcRequest
jsonRpc ErrorData
errStr = do
  let content :: [McpToolsCallResponseResultContent]
content = [ ErrorData -> ErrorData -> McpToolsCallResponseResultContent
DM.McpToolsCallResponseResultContent ErrorData
"text" ErrorData
errStr ]
      result :: McpToolsCallResponseResult
result = DM.McpToolsCallResponseResult {
                  _contentMcpToolsCallResponseResult :: [McpToolsCallResponseResultContent]
DM._contentMcpToolsCallResponseResult = [McpToolsCallResponseResultContent]
content
                , _isErrorMcpToolsCallResponseResult :: Bool
DM._isErrorMcpToolsCallResponseResult = Bool
True
                }
      resDat :: McpToolsCallResponseData
resDat = JsonRpcRequest
-> McpToolsCallResponseResult -> McpToolsCallResponseData
DM.McpToolsCallResponseData JsonRpcRequest
jsonRpc McpToolsCallResponseResult
result
      res :: McpResponse
res = McpToolsCallResponseData -> McpResponse
DM.McpToolsCallResponse McpToolsCallResponseData
resDat

  TQueue McpResponse
resQ <- Getting (TQueue McpResponse) DomainData (TQueue McpResponse)
-> DomainData -> TQueue McpResponse
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TQueue McpResponse) DomainData (TQueue McpResponse)
Lens' DomainData (TQueue McpResponse)
DM.responseQueueDomainData (DomainData -> TQueue McpResponse)
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)))
     DomainData
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)))
     (TQueue McpResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) DomainData
-> ReaderT
     AppData
     (ReaderT DomainData (ExceptT ErrorData (LoggingT IO)))
     DomainData
forall (m :: * -> *) a. Monad m => m a -> ReaderT AppData m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT DomainData (ExceptT ErrorData (LoggingT IO)) DomainData
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> AppContext ()
forall a. IO a -> AppContext a
liftIOE (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue McpResponse -> McpResponse -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue McpResponse
resQ McpResponse
res