pms-infra-cmdrun 0.0.9.0 → 0.1.0.0

raw patch · 5 files changed

+225/−72 lines, 5 filesdep −unixPVP ok

version bump matches the API change (PVP)

Dependencies removed: unix

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• pms-infra-cmdrun.cabal +4/−2
• src/PMS/Infra/CmdRun/DS/Core.hs +11/−55
• src/PMS/Infra/CmdRun/DS/Utility.hs +74/−6
• test/PMS/Infra/CmdRun/App/ControlSpec.hs +132/−9

@@ -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.

@@ -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 

@@ -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)

@@ -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."

@@ -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."