pms-infra-agent-process 0.0.1.0 → 0.0.2.0
raw patch · 6 files changed
+259/−113 lines, 6 files
Files
- CHANGELOG.md +5/−1
- pms-infra-agent-process.cabal +1/−1
- src/PMS/Infra/Agent/Process/DM/Type.hs +13/−10
- src/PMS/Infra/Agent/Process/DS/Core.hs +39/−30
- src/PMS/Infra/Agent/Process/DS/Utility.hs +0/−57
- test/PMS/Infra/Agent/Process/App/ControlSpec.hs +201/−14
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infra-agent-process -## 0.0.1.0 -- 2025-05-05+## 0.0.2.0 -- 2026-05-31++* Added pms-infra-agent-socket, pms-infra-agent-serial.++## 0.0.1.0 -- 2026-05-05 * First version.
pms-infra-agent-process.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.1.0+version: 0.0.2.0 -- A short (one-line) description of the package. synopsis: pms-infra-agent-process
src/PMS/Infra/Agent/Process/DM/Type.hs view
@@ -89,17 +89,20 @@ } -- |--- agent-proc-write の arguments----data ProcStringToolParams =- ProcStringToolParams {- _argumentsProcStringToolParams :: String+-- agent-proc-write data.+-- appendNewline: Nothing or Just True (default) -> apply appendCRLF (auto-append newline).+-- Just False -> send string as-is without any modification.+data ProcWriteToolParams =+ ProcWriteToolParams {+ _dataProcWriteToolParams :: String+ , _appendNewlineProcWriteToolParams :: Maybe Bool } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ProcStringToolParams", omitNothingFields = True} ''ProcStringToolParams)-makeLenses ''ProcStringToolParams+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ProcWriteToolParams", omitNothingFields = True} ''ProcWriteToolParams)+makeLenses ''ProcWriteToolParams -instance Default ProcStringToolParams where- def = ProcStringToolParams {- _argumentsProcStringToolParams = def+instance Default ProcWriteToolParams where+ def = ProcWriteToolParams {+ _dataProcWriteToolParams = def+ , _appendNewlineProcWriteToolParams = def }
src/PMS/Infra/Agent/Process/DS/Core.hs view
@@ -18,13 +18,13 @@ import Control.Monad (when) import qualified Control.Exception.Safe as E import System.Exit-import qualified Data.ByteString as BS import Data.Aeson import qualified System.Process as S import qualified Data.Map.Strict as Map import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM+import qualified PMS.Domain.Model.DS.Utility as DM import PMS.Infra.Agent.Process.DM.Type import qualified PMS.Infra.Agent.Process.DM.Constant as DM_CONST@@ -121,12 +121,12 @@ echoTask :: STM.TQueue DM.McpResponse -> DM.AgentProcessEchoCommandData -> String -> IOTask () echoTask resQ cmdDat val = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.Agent.Process.DS.Core.echoTask run. " ++ val- toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentProcessEchoCommandData) ExitSuccess val ""+ DM.toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentProcessEchoCommandData) ExitSuccess val "" hPutStrLn stderr "[INFO] PMS.Infra.Agent.Process.DS.Core.echoTask end." where errHdl :: E.SomeException -> IO ()- errHdl e = toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentProcessEchoCommandData) (ExitFailure 1) "" (show e)+ errHdl e = DM.toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentProcessEchoCommandData) (ExitFailure 1) "" (show e) ---------------------------------------------------------------------------------@@ -164,13 +164,13 @@ Just p -> do STM.atomically $ STM.putTMVar procTMVar (Just p) hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Process.DS.Core.procRunTask: process is already running."- toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is already running."+ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is already running." Nothing -> do runProc procTMVar cmd argsArray addEnv let payload = "command: " ++ truncate10 cmd ++ ", arguments: " ++ truncate10 (show argsArray) ++ ", environment: " ++ truncate10 (show addEnv)- toolsCallResponse resQ jsonRpc ExitSuccess payload ""+ DM.toolsCallResponse resQ jsonRpc ExitSuccess payload "" hPutStrLn stderr "[INFO] PMS.Infra.Agent.Process.DS.Core.procRunTask end." where jsonRpc = cmdDat^.DM.jsonrpcAgentProcessRunCommandData@@ -178,7 +178,7 @@ errHdl e = do _ <- STM.atomically $ STM.tryTakeTMVar procTMVar STM.atomically $ STM.putTMVar procTMVar Nothing- toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)+ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) -- | -- Truncate a string to at most 10 characters, appending "..." if truncated.@@ -213,19 +213,19 @@ STM.atomically (STM.swapTMVar procTMVar Nothing) >>= \case Nothing -> do hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Process.DS.Core.procTerminateTask: process is not started."- toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started."+ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started." Just procDat -> do let pHdl = procDat^.pHdlProcData S.terminateProcess pHdl exitCode <- S.waitForProcess pHdl hPutStrLn stderr $ "[INFO] PMS.Infra.Agent.Process.DS.Core.procTerminateTask closeProc : " ++ show exitCode- toolsCallResponse resQ jsonRpc ExitSuccess "" "process is terminated."+ DM.toolsCallResponse resQ jsonRpc ExitSuccess "" "process is terminated." hPutStrLn stderr "[INFO] PMS.Infra.Agent.Process.DS.Core.procTerminateTask end." where errHdl :: E.SomeException -> IO ()- errHdl e = toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentProcessTerminateCommandData) (ExitFailure 1) "" (show e)+ errHdl e = DM.toolsCallResponse resQ (cmdDat^.DM.jsonrpcAgentProcessTerminateCommandData) (ExitFailure 1) "" (show e) ---------------------------------------------------------------------------------@@ -256,28 +256,36 @@ STM.atomically (STM.readTMVar procTMVar) >>= \case Nothing -> do hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Process.DS.Core.procReadTask: process is not started."- toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started."+ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started." Just p -> do- output <- readProc p tout actualSize- let result = bs2strUTF8 output- toolsCallResponse resQ jsonRpc ExitSuccess result ""+ output <- DM.readHandle (p^.rHdlProcData) tout actualSize+ let result = DM.bs2strUTF8Strip output+ DM.toolsCallResponse resQ jsonRpc ExitSuccess result "" where jsonRpc = cmdDat^.DM.jsonrpcAgentProcessReadCommandData- errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)+ errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) ------------------------------------------------------------------------------------ |---+-- | CR-12: agent-proc-write with invalidPatterns check.+-- The invalidPatterns check is performed here in the gen function (AppContext),+-- consistent with how genProcRunTask performs the allowedCmds check. genProcWriteTask :: DM.AgentProcessWriteCommandData -> AppContext (IOTask ()) genProcWriteTask cmdData = do let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsAgentProcessWriteCommandData- resQ <- view DM.responseQueueDomainData <$> lift ask- procTMVar <- view processAppData <$> ask- argsDat <- liftEither $ eitherDecode $ argsBS- let args = argsDat^.argumentsProcStringToolParams- return $ procWriteTask cmdData resQ procTMVar args+ resQ <- view DM.responseQueueDomainData <$> lift ask+ procTMVar <- view processAppData <$> ask+ invalidPatterns <- view DM.invalidPatternsDomainData <$> lift ask+ argsDat <- liftEither $ eitherDecode $ argsBS+ let args = argsDat^.dataProcWriteToolParams+ appendNewline = argsDat^.appendNewlineProcWriteToolParams+ -- CR-12: invalidPatterns check (pure check, consistent with genProcRunTask allowedCmds check)+ case DM.checkInvalidPatterns invalidPatterns args of+ Just pat -> throwError $+ "agent-proc-write: rejected. input matches invalidPatterns: " ++ show pat+ Nothing -> return ()+ return $ procWriteTask cmdData resQ procTMVar args appendNewline -- | --@@ -285,22 +293,23 @@ -> STM.TQueue DM.McpResponse -> STM.TMVar (Maybe ProcData) -> String+ -> Maybe Bool -> IOTask ()-procWriteTask cmdDat resQ procTMVar args = flip E.catchAny errHdl $ do+procWriteTask cmdDat resQ procTMVar args appendNewline = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.Agent.Process.DS.Core.procWriteTask run. " ++ args STM.atomically (STM.readTMVar procTMVar) >>= \case Nothing -> do hPutStrLn stderr "[ERROR] PMS.Infra.Agent.Process.DS.Core.procWriteTask: process is not started."- toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started."+ DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started." Just p -> do- let wHdl = p^.wHdLProcData- cmd = str2bsUTF8 $ appendLF args- BS.hPut wHdl cmd- hFlush wHdl- toolsCallResponse resQ jsonRpc ExitSuccess "success" ""+ -- Apply appendCRLF (auto-append newline) unless appendNewline is explicitly False.+ let payload = if appendNewline == Just False+ then args+ else DM.appendCRLF args+ DM.writeHandle (p^.wHdLProcData) (DM.str2bsUTF8 payload)+ DM.toolsCallResponse resQ jsonRpc ExitSuccess "success" "" where jsonRpc = cmdDat^.DM.jsonrpcAgentProcessWriteCommandData- errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)-+ errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)
src/PMS/Infra/Agent/Process/DS/Utility.hs view
@@ -5,7 +5,6 @@ import System.IO import Control.Lens-import System.Exit import System.Log.FastLogger import qualified Control.Exception.Safe as E import Control.Monad.IO.Class@@ -13,15 +12,9 @@ import Control.Monad.Reader import qualified Control.Concurrent.STM as STM import qualified System.Process as S-import qualified Data.ByteString as BS-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as TEE-import qualified Data.String.AnsiEscapeCodes.Strip.Text as ANSI import qualified System.Environment as Env import qualified PMS.Domain.Model.DM.Type as DM-import qualified PMS.Domain.Model.DM.Constant as DM import qualified PMS.Domain.Model.DS.Utility as DM import PMS.Infra.Agent.Process.DM.Type @@ -46,30 +39,8 @@ errHdl :: E.SomeException -> IO (Either String a) errHdl = return . Left . show ---------------------------------------------------------------------------------- -- | ---toolsCallResponse :: STM.TQueue DM.McpResponse- -> DM.JsonRpcRequest- -> ExitCode- -> String- -> String- -> IO ()-toolsCallResponse resQ jsonRpc code outStr errStr = do- let content = [ DM.McpToolsCallResponseResultContent "text" outStr- , DM.McpToolsCallResponseResultContent "text" errStr- ]- result = DM.McpToolsCallResponseResult {- DM._contentMcpToolsCallResponseResult = content- , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)- }- resDat = DM.McpToolsCallResponseData jsonRpc result- res = DM.McpToolsCallResponse resDat-- STM.atomically $ STM.writeTQueue resQ res---- |--- errorToolsCallResponse :: DM.JsonRpcRequest -> String -> AppContext () errorToolsCallResponse jsonRpc errStr = do let content = [ DM.McpToolsCallResponseResultContent "text" errStr ]@@ -121,32 +92,4 @@ hPutStrLn stderr "[INFO] PMS.Infra.Agent.Process.DS.Core.procRunTask.runProc end." --- |--- If no data is available (timeout), return an empty ByteString instead of an error.-readProc :: ProcData -> Int -> Int -> IO BS.ByteString-readProc dat tout size = do- let hdl = dat^.rHdlProcData- ready <- hWaitForInput hdl tout- if ready- then BS.hGetSome hdl size- else return BS.empty ------------------------------------------------------------------------------------- |--- Append LF to the end of the string only if it does not already end with '\n'.--- If the string is empty, return LF only to avoid exception from 'last'.-appendLF :: String -> String-appendLF str- | null str = DM._LF- | last str /= '\n' = str ++ DM._LF- | otherwise = str---- |--- Encode a String to a UTF-8 encoded ByteString.-str2bsUTF8 :: String -> BS.ByteString-str2bsUTF8 = TE.encodeUtf8 . T.pack---- |--- Decode a ByteString to a String using UTF-8 (lenient) and strip ANSI escape sequences.-bs2strUTF8 :: BS.ByteString -> String-bs2strUTF8 = T.unpack . ANSI.stripAnsiEscapeCodes . TE.decodeUtf8With TEE.lenientDecode
test/PMS/Infra/Agent/Process/App/ControlSpec.hs view
@@ -10,7 +10,6 @@ import Control.Lens import Data.Default import Data.Aeson (encode)-import qualified Data.ByteString.Lazy.Char8 as BL import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Infra.Agent.Process.App.Control as SUT@@ -20,7 +19,6 @@ -- data SpecContext = SpecContext { _domainDataSpecContext :: DM.DomainData- , _appDataSpecContext :: SUT.AppData , _threadIdSpecContext :: Maybe (Async ()) } @@ -29,10 +27,8 @@ defaultSpecContext :: IO SpecContext defaultSpecContext = do domDat <- DM.defaultDomainData- appDat <- SUT.defaultAppData return SpecContext { _domainDataSpecContext = domDat- , _appDataSpecContext = appDat , _threadIdSpecContext = Nothing } @@ -72,7 +68,6 @@ thId <- async $ SUT.runWithAppData appDat domDat' return ctx { _domainDataSpecContext = domDat'- , _appDataSpecContext = appDat , _threadIdSpecContext = Just thId } @@ -87,7 +82,6 @@ thId <- async $ SUT.runWithAppData appDat domDat' return ctx { _domainDataSpecContext = domDat'- , _appDataSpecContext = appDat , _threadIdSpecContext = Just thId } @@ -144,20 +138,47 @@ { SUT._argumentsProcIntToolParams = size } -- |--- Encode ProcStringToolParams (write payload) to RawJsonByteString.+-- Encode ProcWriteToolParams (write payload) to RawJsonByteString. -- mkWriteArgs :: String -> DM.RawJsonByteString-mkWriteArgs s =- DM.RawJsonByteString $ encode $ SUT.ProcStringToolParams- { SUT._argumentsProcStringToolParams = s }+mkWriteArgs s = mkWriteArgsWithAppendNewline s Nothing -- |+-- Encode ProcWriteToolParams with explicit appendNewline.+--+mkWriteArgsWithAppendNewline :: String -> Maybe Bool -> DM.RawJsonByteString+mkWriteArgsWithAppendNewline s appendNewline =+ DM.RawJsonByteString $ encode $ SUT.ProcWriteToolParams+ { SUT._dataProcWriteToolParams = s+ , SUT._appendNewlineProcWriteToolParams = appendNewline+ }++-- | -- Extract the isError flag from a response. -- isError :: DM.McpToolsCallResponseData -> Bool isError dat = dat^.DM.resultMcpToolsCallResponseData^.DM.isErrorMcpToolsCallResponseResult +-- |+-- Extract the first text content from a response.+--+firstContentText :: DM.McpToolsCallResponseData -> String+firstContentText dat =+ let contents = dat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult+ in DM._textMcpToolsCallResponseResultContent (head contents)++-- |+-- Terminate the running process via agent-proc-terminate.+--+terminateProc :: DM.DomainData -> IO ()+terminateProc domDat = do+ _ <- sendAndReceive domDat $+ DM.AgentProcessTerminateCommand $ DM.AgentProcessTerminateCommandData+ { DM._jsonrpcAgentProcessTerminateCommandData = mkJsonRpc "agent-proc-terminate"+ }+ return ()+ -- --------------------------------------------------------------------------- -- Test suite -- ---------------------------------------------------------------------------@@ -283,10 +304,7 @@ runDat <- sendAndReceive domDat runCmd isError runDat `shouldBe` False -- cleanup- let termCmd = DM.AgentProcessTerminateCommand $ DM.AgentProcessTerminateCommandData- { DM._jsonrpcAgentProcessTerminateCommandData = mkJsonRpc "agent-proc-terminate"- }- _ <- sendAndReceive domDat termCmd+ terminateProc domDat tearDown ctx' -- TC-06: Whitelist - denied command returns error message@@ -325,4 +343,173 @@ let contents = runDat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult errText = DM._textMcpToolsCallResponseResultContent (head contents) errText `shouldBe` "cmd2task: exception occurred. skip. command not allowed: cmd.exe"+ tearDown ctx'++ -- ---------------------------------------------------------------------------+ -- CR-11: appendNewline tests+ -- ---------------------------------------------------------------------------++ -- TC-A: appendNewline omitted -> newline is appended and cmd.exe executes input+ describe "TC-A: agent-proc-write appendNewline default appends newline" $ do+ context "when appendNewline is omitted and input has no trailing newline" $ do+ it "should execute the command because newline is appended" $ \ctx -> do+ putStrLn "[INFO] TC-A start."+ let domDat = ctx^.domainDataSpecContext+ token = "pms-cr11-default-newline"++ let runCmd = DM.AgentProcessRunCommand $ DM.AgentProcessRunCommandData+ { DM._jsonrpcAgentProcessRunCommandData = mkJsonRpc "agent-proc-run"+ , DM._nameAgentProcessRunCommandData = "agent-proc-run"+ , DM._argumentsAgentProcessRunCommandData = mkRunArgs "cmd.exe" []+ }+ runDat <- sendAndReceive domDat runCmd+ isError runDat `shouldBe` False++ threadDelay (500 * 1000)+ let readCmd = DM.AgentProcessReadCommand $ DM.AgentProcessReadCommandData+ { DM._jsonrpcAgentProcessReadCommandData = mkJsonRpc "agent-proc-read"+ , DM._argumentsAgentProcessReadCommandData = mkReadArgs 4096+ }+ _ <- sendAndReceive domDat readCmd++ let writeCmd = DM.AgentProcessWriteCommand $ DM.AgentProcessWriteCommandData+ { DM._jsonrpcAgentProcessWriteCommandData = mkJsonRpc "agent-proc-write"+ , DM._argumentsAgentProcessWriteCommandData = mkWriteArgs ("echo " ++ token)+ }+ writeDat <- sendAndReceive domDat writeCmd+ isError writeDat `shouldBe` False++ threadDelay (500 * 1000)+ readDat <- sendAndReceive domDat readCmd+ isError readDat `shouldBe` False+ firstContentText readDat `shouldContain` token++ terminateProc domDat++ -- TC-B: appendNewline False -> no newline is appended and cmd.exe keeps input pending+ describe "TC-B: agent-proc-write appendNewline=False suppresses newline" $ do+ context "when appendNewline is Just False" $ do+ it "should not execute the command because newline is not appended" $ \ctx -> do+ putStrLn "[INFO] TC-B start."+ let domDat = ctx^.domainDataSpecContext+ token = "pms-cr11-no-newline"++ let runCmd = DM.AgentProcessRunCommand $ DM.AgentProcessRunCommandData+ { DM._jsonrpcAgentProcessRunCommandData = mkJsonRpc "agent-proc-run"+ , DM._nameAgentProcessRunCommandData = "agent-proc-run"+ , DM._argumentsAgentProcessRunCommandData = mkRunArgs "cmd.exe" []+ }+ runDat <- sendAndReceive domDat runCmd+ isError runDat `shouldBe` False++ threadDelay (500 * 1000)+ let readCmd = DM.AgentProcessReadCommand $ DM.AgentProcessReadCommandData+ { DM._jsonrpcAgentProcessReadCommandData = mkJsonRpc "agent-proc-read"+ , DM._argumentsAgentProcessReadCommandData = mkReadArgs 4096+ }+ _ <- sendAndReceive domDat readCmd++ let writeCmd = DM.AgentProcessWriteCommand $ DM.AgentProcessWriteCommandData+ { DM._jsonrpcAgentProcessWriteCommandData = mkJsonRpc "agent-proc-write"+ , DM._argumentsAgentProcessWriteCommandData =+ mkWriteArgsWithAppendNewline ("echo " ++ token) (Just False)+ }+ writeDat <- sendAndReceive domDat writeCmd+ isError writeDat `shouldBe` False++ threadDelay (500 * 1000)+ readDat <- sendAndReceive domDat readCmd+ isError readDat `shouldBe` False+ firstContentText readDat `shouldNotContain` token++ terminateProc domDat++ -- ---------------------------------------------------------------------------+ -- CR-12: invalidPatterns tests+ -- ---------------------------------------------------------------------------++ -- TC-08: invalidPatterns - matching input -> isError=True+ describe "TC-08: invalidPatterns - matching input is rejected" $ do+ context "when agent-proc-write input matches an invalidPatterns entry" $ do+ it "should return isError=True" $ \ctx -> do+ putStrLn "[INFO] TC-08 start."+ domDat <- DM.defaultDomainData+ let domDat' = domDat+ { DM._allowedAgentCmdsDomainData = ["cmd.exe"]+ , DM._invalidPatternsDomainData = ["rm", "shutdown"]+ }+ appDat <- SUT.defaultAppData+ thId <- async $ SUT.runWithAppData appDat domDat'+ let ctx' = ctx { _domainDataSpecContext = domDat'+ , _threadIdSpecContext = Just thId+ }+ dat <- sendAndReceive domDat' $+ DM.AgentProcessWriteCommand $ DM.AgentProcessWriteCommandData+ { DM._jsonrpcAgentProcessWriteCommandData = mkJsonRpc "agent-proc-write"+ , DM._argumentsAgentProcessWriteCommandData = mkWriteArgs "rm -rf /"+ }+ isError dat `shouldBe` True+ -- No process was started, just cancel the SUT thread.+ tearDown ctx'++ -- TC-09: invalidPatterns - non-matching input -> normal processing+ describe "TC-09: invalidPatterns - non-matching input is allowed" $ do+ context "when agent-proc-write input does NOT match any invalidPatterns entry" $ do+ it "should return isError=False when process is running" $ \ctx -> do+ putStrLn "[INFO] TC-09 start."+ domDat <- DM.defaultDomainData+ let domDat' = domDat+ { DM._allowedAgentCmdsDomainData = ["cmd.exe"]+ , DM._invalidPatternsDomainData = ["rm", "shutdown"]+ }+ appDat <- SUT.defaultAppData+ thId <- async $ SUT.runWithAppData appDat domDat'+ let ctx' = ctx { _domainDataSpecContext = domDat'+ , _threadIdSpecContext = Just thId+ }+ _ <- sendAndReceive domDat' $+ DM.AgentProcessRunCommand $ DM.AgentProcessRunCommandData+ { DM._jsonrpcAgentProcessRunCommandData = mkJsonRpc "agent-proc-run"+ , DM._nameAgentProcessRunCommandData = "agent-proc-run"+ , DM._argumentsAgentProcessRunCommandData = mkRunArgs "cmd.exe" []+ }+ dat <- sendAndReceive domDat' $+ DM.AgentProcessWriteCommand $ DM.AgentProcessWriteCommandData+ { DM._jsonrpcAgentProcessWriteCommandData = mkJsonRpc "agent-proc-write"+ , DM._argumentsAgentProcessWriteCommandData = mkWriteArgs "echo hello"+ }+ isError dat `shouldBe` False+ -- cleanup: terminate cmd.exe before cancelling SUT thread+ terminateProc domDat'+ tearDown ctx'++ -- TC-10: invalidPatterns - empty list -> allow all+ describe "TC-10: invalidPatterns - empty list allows all input" $ do+ context "when invalidPatterns is empty" $ do+ it "should not reject any write input" $ \ctx -> do+ putStrLn "[INFO] TC-10 start."+ domDat <- DM.defaultDomainData+ let domDat' = domDat+ { DM._allowedAgentCmdsDomainData = ["cmd.exe"]+ , DM._invalidPatternsDomainData = []+ }+ appDat <- SUT.defaultAppData+ thId <- async $ SUT.runWithAppData appDat domDat'+ let ctx' = ctx { _domainDataSpecContext = domDat'+ , _threadIdSpecContext = Just thId+ }+ _ <- sendAndReceive domDat' $+ DM.AgentProcessRunCommand $ DM.AgentProcessRunCommandData+ { DM._jsonrpcAgentProcessRunCommandData = mkJsonRpc "agent-proc-run"+ , DM._nameAgentProcessRunCommandData = "agent-proc-run"+ , DM._argumentsAgentProcessRunCommandData = mkRunArgs "cmd.exe" []+ }+ dat <- sendAndReceive domDat' $+ DM.AgentProcessWriteCommand $ DM.AgentProcessWriteCommandData+ { DM._jsonrpcAgentProcessWriteCommandData = mkJsonRpc "agent-proc-write"+ , DM._argumentsAgentProcessWriteCommandData = mkWriteArgs "rm -rf /"+ }+ isError dat `shouldBe` False+ -- cleanup: terminate cmd.exe before cancelling SUT thread+ terminateProc domDat' tearDown ctx'