pms-infra-procspawn 0.0.8.0 → 0.0.9.0
raw patch · 6 files changed
+132/−75 lines, 6 filesdep +strip-ansi-escape
Dependencies added: strip-ansi-escape
Files
- CHANGELOG.md +4/−0
- pms-infra-procspawn.cabal +2/−1
- src/PMS/Infra/ProcSpawn/DM/Constant.hs +5/−0
- src/PMS/Infra/ProcSpawn/DM/Type.hs +16/−0
- src/PMS/Infra/ProcSpawn/DS/Core.hs +95/−8
- src/PMS/Infra/ProcSpawn/DS/Utility.hs +10/−66
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infra-procspawn +## 0.0.9.0 -- 2026-04-30++* Add async read/write tools.+ ## 0.0.8.0 -- 2025-12-31 * Add file system tools.
pms-infra-procspawn.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.8.0+version: 0.0.9.0 -- A short (one-line) description of the package. synopsis: pms-infra-procspawn@@ -90,6 +90,7 @@ filepath, aeson, directory,+ strip-ansi-escape, pms-domain-model -- Directories containing source files.
src/PMS/Infra/ProcSpawn/DM/Constant.hs view
@@ -6,4 +6,9 @@ _LOG_FILE_NAME :: String _LOG_FILE_NAME = "pms-infra-procspawn.log" +-- |+--+_READ_BUFFER_SIZE :: Int+_READ_BUFFER_SIZE = 4096+
src/PMS/Infra/ProcSpawn/DM/Type.hs view
@@ -101,3 +101,19 @@ def = ProcStringArrayToolParams { _argumentsProcStringArrayToolParams = def }++-- |+--+data ProcIntToolParams =+ ProcIntToolParams {+ _argumentsProcIntToolParams :: Int+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ProcIntToolParams", omitNothingFields = True} ''ProcIntToolParams)+makeLenses ''ProcIntToolParams++instance Default ProcIntToolParams where+ def = ProcIntToolParams {+ _argumentsProcIntToolParams = def+ }+
src/PMS/Infra/ProcSpawn/DS/Core.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-} module PMS.Infra.ProcSpawn.DS.Core where @@ -20,6 +21,9 @@ import qualified Control.Exception.Safe as E import System.Exit import qualified Data.Text.Encoding as TE+import qualified Data.String.AnsiEscapeCodes.Strip.Text as ANSI+import qualified Data.Text.Encoding.Error as TEE+ import qualified Data.ByteString as BS import Data.Aeson import Data.List@@ -32,6 +36,7 @@ import qualified PMS.Domain.Model.DM.Constant as DM import PMS.Infra.ProcSpawn.DM.Type+import qualified PMS.Infra.ProcSpawn.DM.Constant as DM_CONST import PMS.Infra.ProcSpawn.DS.Utility @@ -83,6 +88,8 @@ go (DM.ProcRunCommand dat) = genProcRunTask dat go (DM.ProcTerminateCommand dat) = genProcTerminateTask dat go (DM.ProcMessageCommand dat) = genProcMessageTask dat+ go (DM.ProcReadCommand dat) = genProcReadTask dat+ go (DM.ProcWriteCommand dat) = genProcWriteTask dat --------------------------------------------------------------------------------- -- |@@ -155,9 +162,10 @@ genProcSpawn cmdDat = do let name = cmdDat^.DM.nameProcRunCommandData argsBS = DM.unRawJsonByteString $ cmdDat^.DM.argumentsProcRunCommandData- tout = DM._TIMEOUT_MICROSEC addEnv = [("ProgramData", "C:\\ProgramData"), ("SystemRoot", "C:\\Windows")] -- for windows ssh on claude code. + tout <- view DM.timeoutMicrosecDomainData <$> lift ask+ prompts <- view DM.promptsDomainData <$> lift ask resQ <- view DM.responseQueueDomainData <$> lift ask invalidChars <- view DM.invalidCharsDomainData <$> lift ask@@ -239,7 +247,7 @@ STM.atomically (STM.readTMVar procVar) >>= \case Just p -> do- race (DM.expect lockTMVar (readProc p) prompts) (CC.threadDelay tout) >>= \case+ race (DM.expect lockTMVar (readProc p tout DM_CONST._READ_BUFFER_SIZE) prompts) (CC.threadDelay tout) >>= \case Left res -> toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) ExitSuccess (maybe "Nothing" id res) "" Right _ -> toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "timeout occurred." Nothing -> do@@ -262,7 +270,7 @@ genProcCMD cmdDat = do $logDebugS DM._LOGTAG $ T.pack $ "genProcCMD: called. " - let tout = DM._TIMEOUT_MICROSEC+ tout <- view DM.timeoutMicrosecDomainData <$> lift ask prompts <- view DM.promptsDomainData <$> lift ask resQ <- view DM.responseQueueDomainData <$> lift ask@@ -304,7 +312,7 @@ hFlush wHdl STM.atomically (STM.readTMVar procVar) >>= \case- Just p -> race (DM.expect lockTMVar (readProc p) prompts) (CC.threadDelay tout) >>= \case+ Just p -> race (DM.expect lockTMVar (readProc p tout DM_CONST._READ_BUFFER_SIZE) prompts) (CC.threadDelay tout) >>= \case Left res -> toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) ExitSuccess (maybe "Nothing" id res) "" Right _ -> toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "timeout occurred." Nothing -> do@@ -327,7 +335,7 @@ genProcPS cmdDat = do $logDebugS DM._LOGTAG $ T.pack $ "genProcPS: called. " - let tout = DM._TIMEOUT_MICROSEC+ tout <- view DM.timeoutMicrosecDomainData <$> lift ask prompts <- view DM.promptsDomainData <$> lift ask resQ <- view DM.responseQueueDomainData <$> lift ask@@ -357,7 +365,7 @@ Nothing -> runProc procVar "powershell" ["-NoLogo", "-NoExit", "-Command", initCmd] env STM.atomically (STM.readTMVar procVar) >>= \case- Just p -> race (DM.expect lockTMVar (readProc p) prompts) (CC.threadDelay tout) >>= \case+ Just p -> race (DM.expect lockTMVar (readProc p tout DM_CONST._READ_BUFFER_SIZE) prompts) (CC.threadDelay tout) >>= \case Left res -> toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) ExitSuccess (maybe "Nothing" id res) "" Right _ -> toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "timeout occurred." Nothing -> do@@ -422,10 +430,89 @@ -- | --+genProcReadTask :: DM.ProcReadCommandData -> AppContext (IOTask ())+genProcReadTask cmdData = do+ resQ <- view DM.responseQueueDomainData <$> lift ask+ procTMVar <- view processAppData <$> ask+ tout <- view DM.timeoutMicrosecDomainData <$> lift ask++ let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsProcReadCommandData+ argsDat <- liftEither $ eitherDecode $ argsBS+ let size = argsDat^.argumentsProcIntToolParams+ actualSize = min size DM_CONST._READ_BUFFER_SIZE++ return $ procReadTask cmdData resQ procTMVar tout actualSize++-- |+--+procReadTask :: DM.ProcReadCommandData+ -> STM.TQueue DM.McpResponse+ -> STM.TMVar (Maybe ProcData)+ -> Int+ -> Int+ -> IOTask ()+procReadTask cmdDat resQ procTMVar tout actualSize = flip E.catchAny errHdl $ do+ hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.procReadTask run. actualSize: " ++ show actualSize+ + STM.atomically (STM.readTMVar procTMVar) >>= \case+ Nothing -> do+ hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.procReadTask: process is not started."+ toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started."+ Just p -> do+ output <- readProc p tout actualSize + let result = T.unpack $ ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode output+ toolsCallResponse resQ jsonRpc ExitSuccess result ""++ where+ jsonRpc = cmdDat^.DM.jsonrpcProcReadCommandData+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)++-- |+--+genProcWriteTask :: DM.ProcWriteCommandData -> AppContext (IOTask ())+genProcWriteTask cmdData = do+ let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsProcWriteCommandData+ resQ <- view DM.responseQueueDomainData <$> lift ask+ procTMVar <- view processAppData <$> ask+ invalidChars <- view DM.invalidCharsDomainData <$> lift ask+ invalidCmds <- view DM.invalidCmdsDomainData <$> lift ask+ argsDat <- liftEither $ eitherDecode $ argsBS+ let args = argsDat^.argumentsProcStringToolParams+ return $ procWriteTask cmdData resQ procTMVar args invalidChars invalidCmds++-- |+--+procWriteTask :: DM.ProcWriteCommandData+ -> STM.TQueue DM.McpResponse+ -> STM.TMVar (Maybe ProcData)+ -> String+ -> [String]+ -> [String]+ -> IOTask ()+procWriteTask cmdDat resQ procTMVar args invalidChars invalidCmds = flip E.catchAny errHdl $ do+ hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.procWriteTask run. " ++ args+ + STM.atomically (STM.readTMVar procTMVar) >>= \case+ Nothing -> do+ hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.procWriteTask: process is not started."+ toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "process is not started."+ Just p -> do+ let wHdl = p^.wHdLProcData+ msg <- DM.validateMessage invalidChars invalidCmds args+ let cmd = TE.encodeUtf8 $ T.pack $ msg ++ DM._LF+ BS.hPut wHdl cmd+ hFlush wHdl+ toolsCallResponse resQ jsonRpc ExitSuccess "success" ""++ where+ jsonRpc = cmdDat^.DM.jsonrpcProcWriteCommandData+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)+-- |+-- genProcMessageTask :: DM.ProcMessageCommandData -> AppContext (IOTask ()) genProcMessageTask cmdData = do let argsBS = DM.unRawJsonByteString $ cmdData^.DM.argumentsProcMessageCommandData- tout = 30 * 1000 * 1000+ tout <- view DM.timeoutMicrosecDomainData <$> lift ask prompts <- view DM.promptsDomainData <$> lift ask resQ <- view DM.responseQueueDomainData <$> lift ask invalidChars <- view DM.invalidCharsDomainData <$> lift ask@@ -480,6 +567,6 @@ BS.hPut wHdl cmd hFlush wHdl - race (DM.expect lockTMVar (readProc pDat) prompts) (CC.threadDelay tout) >>= \case+ race (DM.expect lockTMVar (readProc pDat tout DM_CONST._READ_BUFFER_SIZE) prompts) (CC.threadDelay tout) >>= \case Left res -> toolsCallResponse resQ jsonRpc ExitSuccess (maybe "expect running. skip." id res) "" Right _ -> toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "timeout occurred."
src/PMS/Infra/ProcSpawn/DS/Utility.hs view
@@ -15,8 +15,6 @@ import qualified System.Process as S import qualified Data.ByteString as BS import qualified System.Environment as Env-import qualified Data.ByteString.Char8 as BSC-import Control.Concurrent.Async import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DS.Utility as DM@@ -91,6 +89,11 @@ (fromProcHandle, toPtyHandle) <- S.createPipe -- (fromProcEHandle, toPtyEHandle) <- S.createPipe + -- hSetBuffering toProcHandle NoBuffering+ -- hSetBuffering fromProcHandle NoBuffering+ -- hSetBuffering fromPtyHandle NoBuffering+ -- hSetBuffering toPtyHandle NoBuffering+ baseEnv <- Env.getEnvironment let cwd = Nothing runEnvs = Just $ baseEnv ++ addEnv@@ -113,73 +116,14 @@ hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc end." - -- | -- -readProc :: ProcData -> IO BS.ByteString-readProc dat = do+readProc :: ProcData -> Int -> Int -> IO BS.ByteString+readProc dat tout size = do let hdl = dat^.rHdlProcData- timeoutMillis = 25000- ready <- hWaitForInput hdl timeoutMillis+ ready <- hWaitForInput hdl tout if ready- then BS.hGetSome hdl 1024- else E.throwString $ "readProc: timeout waiting " ++ show timeoutMillis ++ " for input"----- |--- -readProc2 :: ProcData -> IO BS.ByteString-readProc2 dat = do- let rHdl = dat^.rHdlProcData- eHdl = dat^.eHdlProcData-- readProcHandle eHdl 1000 >>= \case- Just eout -> readProcHandle rHdl 500 >>= \case- Just erout -> do- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc eout,erout."- return $ erout <> BSC.pack "\n" <> eout- Nothing -> do- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc eout,none."- return eout- Nothing -> readProcHandle rHdl 20000 >>= \case- Just rout -> readProcHandle eHdl 500 >>= \case- Just reout -> do- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc none,rout,reout."- return $ rout <> BSC.pack "\n" <> reout- Nothing -> do- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc none,rout,none."- return rout- Nothing -> readProcHandle eHdl 500 >>= \case- Just out -> do- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc none,none,out"- return out- Nothing -> E.throwString $ "readProc: timeout waiting for stdout/stderr input"----- |--- -readProc3 :: ProcData -> IO BS.ByteString-readProc3 dat = do- let rHdl = dat^.rHdlProcData- eHdl = dat^.eHdlProcData-- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc start race."- res <- race (readProcHandle rHdl 25001)- (readProcHandle eHdl 25002)-- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.readProc end race."- case res of- Left (Just out) -> return out- Right (Just err) -> return err- _ -> E.throwString "readProc: timeout waiting for stdout/stderr input"-+ then BS.hGetSome hdl size+ else E.throwString $ "readProc: timeout occurred. (waited " ++ show tout ++ ".)" --- |--- -readProcHandle :: Handle -> Int -> IO (Maybe BS.ByteString)-readProcHandle hdl timeoutMillis = do- ready <- hWaitForInput hdl timeoutMillis- if ready- then Just <$> BS.hGetSome hdl 8192- else return Nothing