diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for pms-infra-cmdrun +## 0.1.0.0 -- 2026-06-15 + +* Added pms-infra-agent-server: TCP server listen/accept functionality for AI agents. + ## 0.0.9.0 -- 2026-04-30 * Support timeout configuration. diff --git a/pms-infra-cmdrun.cabal b/pms-infra-cmdrun.cabal --- a/pms-infra-cmdrun.cabal +++ b/pms-infra-cmdrun.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.9.0 +version: 0.1.0.0 -- A short (one-line) description of the package. synopsis: pms-infra-cmdrun @@ -129,8 +129,10 @@ stm, monad-logger, async, - unix, lens, + aeson, + filepath, + directory, pms-domain-model, pms-infra-cmdrun diff --git a/src/PMS/Infra/CmdRun/DS/Core.hs b/src/PMS/Infra/CmdRun/DS/Core.hs --- a/src/PMS/Infra/CmdRun/DS/Core.hs +++ b/src/PMS/Infra/CmdRun/DS/Core.hs @@ -13,17 +13,15 @@ import Control.Monad.Reader import qualified Control.Concurrent.STM as STM import Data.Conduit -import qualified Control.Concurrent as CC import Control.Concurrent.Async import qualified Data.Text as T import Control.Monad.Except import System.FilePath -import Data.Aeson import qualified Control.Exception.Safe as E import System.Exit +import Data.Aeson (eitherDecode) import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TEE -import qualified Data.ByteString as BS import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM @@ -118,29 +116,12 @@ echoTask :: STM.TQueue DM.McpResponse -> DM.EchoCmdRunCommandData -> String -> IOTask () echoTask resQ cmdDat val = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.CmdRun.DS.Core.work.echoTask run. " ++ val - - response ExitSuccess val "" - + DM.toolsCallResponse resQ jsonRpc ExitSuccess val "" hPutStrLn stderr "[INFO] PMS.Infra.CmdRun.DS.Core.work.echoTask end." - where + jsonRpc = cmdDat^.DM.jsonrpcEchoCmdRunCommandData errHdl :: E.SomeException -> IO () - errHdl e = response (ExitFailure 1) "" (show e) - - response :: ExitCode -> String -> String -> IO () - response code outStr errStr = do - let jsonRpc = cmdDat^.DM.jsonrpcEchoCmdRunCommandData - 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 + errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) -- | @@ -176,38 +157,13 @@ cmdRunTask :: STM.TQueue DM.McpResponse -> DM.DefaultCmdRunCommandData -> String -> Int -> IO () cmdRunTask resQ cmdDat cmd tout = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.CmdRun.DS.Core.work.cmdRunTask.run cmd: " ++ cmd - - race (runCommandBS cmd) (CC.threadDelay tout) >>= \case - Left (code, out, err) -> response code out err - Right _ -> E.throwString "timeout occurred." - + runCommandBSWithTimeout tout cmd >>= \case + (code, out, err) -> do + let outStr = T.unpack $ TE.decodeUtf8With TEE.lenientDecode out + errStr = T.unpack $ TE.decodeUtf8With TEE.lenientDecode err + DM.toolsCallResponse resQ jsonRpc code outStr errStr hPutStrLn stderr "[INFO] PMS.Infra.CmdRun.DS.Core.work.cmdRunTask end." - where + jsonRpc = cmdDat^.DM.jsonrpcDefaultCmdRunCommandData errHdl :: E.SomeException -> IO () - errHdl e = response (ExitFailure 1) "" $ TE.encodeUtf8 . T.pack $ show e - - response :: ExitCode -> BS.ByteString -> BS.ByteString -> IO () - response code outBS errBS = do - let outStr = T.unpack $ TE.decodeUtf8With TEE.lenientDecode outBS - errStr = T.unpack $ TE.decodeUtf8With TEE.lenientDecode errBS - jsonRpc = cmdDat^.DM.jsonrpcDefaultCmdRunCommandData - content = - case (decodeStrict' outBS) of - Just val -> [ - val - , DM.McpToolsCallResponseResultContent "text" errStr - ] - Nothing -> [ - 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 + errHdl e = DM.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) diff --git a/src/PMS/Infra/CmdRun/DS/Utility.hs b/src/PMS/Infra/CmdRun/DS/Utility.hs --- a/src/PMS/Infra/CmdRun/DS/Utility.hs +++ b/src/PMS/Infra/CmdRun/DS/Utility.hs @@ -4,6 +4,7 @@ import System.Log.FastLogger import qualified Control.Exception.Safe as E +import qualified Control.Concurrent as CC import Control.Monad.IO.Class import Control.Monad.Except import Control.Monad.Reader @@ -12,6 +13,7 @@ import Control.Lens import System.Process import System.IO +import Control.Concurrent.Async (async, cancel, concurrently, wait) import qualified Data.ByteString as BS import qualified PMS.Domain.Model.DM.Type as DM @@ -78,13 +80,79 @@ liftIOE $ STM.atomically $ STM.writeTQueue resQ res --- | --- +-- | Run a shell command and collect stdout and stderr concurrently. +-- Reading stdout and stderr sequentially risks a deadlock when the child +-- process produces large stderr output: the OS pipe buffer fills up, +-- blocking the process before it can write to stdout, which in turn +-- prevents hGetContents hout from returning. +-- Using 'concurrently' drains both handles in separate threads so neither +-- pipe can stall the other. runCommandBS :: String -> IO (ExitCode, BS.ByteString, BS.ByteString) runCommandBS cmd = do - (hin, hout, herr, ph) <- runInteractiveCommand cmd - hClose hin - out <- BS.hGetContents hout - err <- BS.hGetContents herr + (hout, herr, ph) <- openCommandPipes cmd + (out, err) <- concurrently + (BS.hGetContents hout) -- read stdout in one thread + (BS.hGetContents herr) -- read stderr concurrently exitCode <- waitForProcess ph return (exitCode, out, err) + + +-- | Run a shell command with a timeout and collect stdout and stderr concurrently. +-- The timeout is handled while the ProcessHandle is still available, so the +-- child process and pipe readers can be released immediately. +runCommandBSWithTimeout :: Int -> String -> IO (ExitCode, BS.ByteString, BS.ByteString) +runCommandBSWithTimeout tout cmd = do + (hout, herr, ph) <- openCommandPipes cmd + aOut <- async (BS.hGetContents hout) + aErr <- async (BS.hGetContents herr) + ret <- waitForProcessOrTimeout tout ph + case ret of + Just exitCode -> do + out <- wait aOut + err <- wait aErr + return (exitCode, out, err) + Nothing -> do + terminateProcess ph + cancel aOut + cancel aErr + return (ExitFailure 1, BS.empty, "timeout occurred.") + where + waitForProcessOrTimeout :: Int -> ProcessHandle -> IO (Maybe ExitCode) + waitForProcessOrTimeout timeoutMicrosec ph = go timeoutMicrosec + where + pollIntervalMicrosec :: Int + pollIntervalMicrosec = 100 * 1000 + + go :: Int -> IO (Maybe ExitCode) + go remaining + | remaining <= 0 = return Nothing + | otherwise = do + mExitCode <- getProcessExitCode ph + case mExitCode of + Just exitCode -> return $ Just exitCode + Nothing -> do + let waitMicrosec = min pollIntervalMicrosec remaining + CC.threadDelay waitMicrosec + go (remaining - waitMicrosec) + + +openCommandPipes :: String -> IO (Handle, Handle, ProcessHandle) +openCommandPipes cmd = do + (hin, hout, herr, ph) <- createShellProcess cmd + hClose hin + hSetBinaryMode hout True -- disable newline translation (important on Windows) + hSetBinaryMode herr True -- disable newline translation (important on Windows) + return (hout, herr, ph) + + +createShellProcess :: String -> IO (Handle, Handle, Handle, ProcessHandle) +createShellProcess cmd = do + (mHin, mHout, mHerr, ph) <- createProcess (shell cmd) { + std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + , use_process_jobs = True + } + case (mHin, mHout, mHerr) of + (Just hin, Just hout, Just herr) -> return (hin, hout, herr, ph) + _ -> E.throwString "createShellProcess: failed to create process pipes." diff --git a/test/PMS/Infra/CmdRun/App/ControlSpec.hs b/test/PMS/Infra/CmdRun/App/ControlSpec.hs --- a/test/PMS/Infra/CmdRun/App/ControlSpec.hs +++ b/test/PMS/Infra/CmdRun/App/ControlSpec.hs @@ -8,6 +8,9 @@ import qualified Control.Concurrent.STM as STM import Control.Lens import Data.Default +import Data.Aeson (encode) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Infra.CmdRun.App.Control as SUT @@ -17,7 +20,7 @@ -- data SpecContext = SpecContext { _domainDataSpecContext :: DM.DomainData - , _appDataSpecContext :: SUT.AppData + , _appDataSpecContext :: SUT.AppData } makeLenses ''SpecContext @@ -36,9 +39,9 @@ spec :: Spec spec = do runIO $ putStrLn "Start Spec." - beforeAll setUpOnce $ - afterAll tearDownOnce . - beforeWith setUp . + beforeAll setUpOnce $ + afterAll tearDownOnce . + beforeWith setUp . after tearDown $ run -- | @@ -59,7 +62,6 @@ setUp :: SpecContext -> IO SpecContext setUp ctx = do putStrLn "[INFO] EXECUTED BEFORE EACH TEST STARTS." - domDat <- DM.defaultDomainData appDat <- SUT.defaultAppData return ctx { @@ -73,14 +75,68 @@ tearDown _ = do putStrLn "[INFO] EXECUTED AFTER EACH TEST FINISHES." +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +-- | Script directory used by TC-02 to TC-04. +-- Uses an absolute path so shells do not interpret the leading "test" segment +-- as the POSIX test command. +testScriptsDir :: IO String +testScriptsDir = do + cwd <- getCurrentDirectory + return $ cwd "test" "scripts" + +-- | Build a RawJsonByteString that wraps StringToolParams. +mkArgs :: String -> DM.RawJsonByteString +mkArgs s = DM.RawJsonByteString $ encode + (SUT.StringToolParams { SUT._argumentsStringToolParams = s }) + +-- | Send a DefaultCmdRunCommand and wait for one MCP response. +sendCmdRun :: DM.DomainData -> SUT.AppData -> String -> String -> IO DM.McpToolsCallResponseData +sendCmdRun domDat appDat name argsStr = do + let cmdQ = domDat^.DM.cmdRunQueueDomainData + resQ = domDat^.DM.responseQueueDomainData + jsonR = def { DM._methodJsonRpcRequest = name } + dat = DM.DefaultCmdRunCommandData jsonR name (mkArgs argsStr) + cmd = DM.DefaultCmdRunCommand dat + thId <- async $ SUT.runWithAppData appDat domDat + STM.atomically $ STM.writeTQueue cmdQ cmd + (DM.McpToolsCallResponse res) <- STM.atomically $ STM.readTQueue resQ + cancel thId + return res + +-- | Extract the isError flag from a response. +isError :: DM.McpToolsCallResponseData -> Bool +isError dat = + dat^.DM.resultMcpToolsCallResponseData^.DM.isErrorMcpToolsCallResponseResult + +-- | Extract text of the first content entry (stdout). +firstText :: DM.McpToolsCallResponseData -> String +firstText dat = + let cs = dat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult + in DM._textMcpToolsCallResponseResultContent (head cs) + +-- | Extract text of the second content entry (stderr). +secondText :: DM.McpToolsCallResponseData -> String +secondText dat = + let cs = dat^.DM.resultMcpToolsCallResponseData^.DM.contentMcpToolsCallResponseResult + in DM._textMcpToolsCallResponseResultContent (cs !! 1) + +-- --------------------------------------------------------------------------- +-- Test suite +-- --------------------------------------------------------------------------- + -- | -- run :: SpecWith SpecContext run = do - describe "runWithAppData" $ do + + -- TC-01: echo command (regression check) + describe "TC-01: echo command" $ do context "when echo command issued." $ do - it "should call callback" $ \ctx -> do - putStrLn "[INFO] EXECUTING THE FIRST TEST." + it "should call callback" $ \ctx -> do + putStrLn "[INFO] TC-01: EXECUTING ECHO TEST." let domDat = ctx^.domainDataSpecContext appDat = ctx^.appDataSpecContext @@ -90,7 +146,7 @@ jsonR = def {DM._jsonrpcJsonRpcRequest = expect} argDat = DM.EchoCmdRunCommandData jsonR "" args = DM.EchoCmdRunCommand argDat - + thId <- async $ SUT.runWithAppData appDat domDat STM.atomically $ STM.writeTQueue cmdQ args @@ -101,3 +157,70 @@ actual `shouldBe` expect cancel thId + + -- TC-02: stdout-only command + -- Verifies that stdout is correctly captured after the concurrent-read fix. + describe "TC-02: stdout-only command" $ do + context "when a command writes only to stdout" $ do + it "should return isError=False and capture stdout" $ \ctx -> do + putStrLn "[INFO] TC-02: EXECUTING STDOUT-ONLY TEST." + + let domDat = ctx^.domainDataSpecContext + appDat = ctx^.appDataSpecContext + token = "hellostdout" + scriptsDir <- testScriptsDir + let domDat' = domDat { DM._toolsDirDomainData = scriptsDir } + + res <- sendCmdRun domDat' appDat "echo_stdout" token + + -- debug: print actual response for diagnosis + putStrLn $ "[DEBUG] TC-02 isError: " ++ show (isError res) + putStrLn $ "[DEBUG] TC-02 firstText: " ++ firstText res + putStrLn $ "[DEBUG] TC-02 secondText: " ++ secondText res + + isError res `shouldBe` False + firstText res `shouldContain` token + + -- TC-03: stderr-only command + -- Verifies that stderr is correctly captured via the concurrent read thread. + describe "TC-03: stderr-only command" $ do + context "when a command writes only to stderr" $ do + it "should return isError=False and capture stderr" $ \ctx -> do + putStrLn "[INFO] TC-03: EXECUTING STDERR-ONLY TEST." + + let domDat = ctx^.domainDataSpecContext + appDat = ctx^.appDataSpecContext + token = "hellostderr" + scriptsDir <- testScriptsDir + let domDat' = domDat { DM._toolsDirDomainData = scriptsDir } + + res <- sendCmdRun domDat' appDat "echo_stderr" token + + isError res `shouldBe` False + secondText res `shouldContain` token + + -- TC-04: timeout + -- Verifies that a long-running command is terminated within timeoutMicrosec + -- and returns an error response containing "timeout occurred.". + describe "TC-04: timeout" $ do + context "when a command exceeds the timeout" $ do + it "should return isError=True with 'timeout occurred.'" $ \ctx -> do + putStrLn "[INFO] TC-04: EXECUTING TIMEOUT TEST." + + let domDat = ctx^.domainDataSpecContext + appDat = ctx^.appDataSpecContext + scriptsDir <- testScriptsDir + let domDat' = domDat + { DM._toolsDirDomainData = scriptsDir + , DM._timeoutMicrosecDomainData = 3 * 1000 * 1000 + } + + -- sleep.bat sleeps for 60 s, which exceeds the 3-second timeout. + res <- sendCmdRun domDat' appDat "sleep" "" + + -- debug: print actual response for diagnosis + putStrLn $ "[DEBUG] TC-04 isError: " ++ show (isError res) + putStrLn $ "[DEBUG] TC-04 firstText: " ++ firstText res + + isError res `shouldBe` True + secondText res `shouldContain` "timeout occurred."