pms-infra-procspawn 0.0.7.0 → 0.0.8.0
raw patch · 4 files changed
+83/−6 lines, 4 files
Files
- CHANGELOG.md +4/−0
- pms-infra-procspawn.cabal +1/−1
- src/PMS/Infra/ProcSpawn/DS/Core.hs +12/−2
- src/PMS/Infra/ProcSpawn/DS/Utility.hs +66/−3
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infra-procspawn +## 0.0.8.0 -- 2025-12-31++* Add file system tools.+ ## 0.0.7.0 -- 2025-09-07 * Support invalidChars configs.
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.7.0+version: 0.0.8.0 -- A short (one-line) description of the package. synopsis: pms-infra-procspawn
src/PMS/Infra/ProcSpawn/DS/Core.hs view
@@ -5,6 +5,7 @@ module PMS.Infra.ProcSpawn.DS.Core where import System.IO+import System.Environment import Control.Monad.Logger import Control.Monad.IO.Class import Control.Monad.Trans.Class@@ -21,6 +22,7 @@ import qualified Data.Text.Encoding as TE import qualified Data.ByteString as BS import Data.Aeson +import Data.List import qualified System.Process as S import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BL@@ -346,13 +348,13 @@ genProcPSTask cmdDat resQ procVar lockTMVar prompts tout = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask start. " let initCmd = "chcp 65001; $OutputEncoding = [Console]::OutputEncoding = New-Object System.Text.UTF8Encoding $false; function prompt { \"PS $((Get-Location).Path)>>>\" }"-+ env <- addPathsToEnv ["C:\\Windows\\System32"] STM.atomically (STM.takeTMVar procVar) >>= \case Just p -> do STM.atomically $ STM.putTMVar procVar $ Just p hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask: process is already running." toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "process is already running."- Nothing -> runProc procVar "powershell" ["-NoLogo", "-NoExit", "-Command", initCmd] []+ 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@@ -370,6 +372,14 @@ STM.atomically $ STM.putTMVar procVar Nothing hPutStrLn stderr $ "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask: exception occurred. " ++ show e toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" (show e)++ addPathsToEnv :: [FilePath] -> IO [(String, String)]+ addPathsToEnv extraPaths = do+ env <- getEnvironment+ let sep = ";" -- Windows用。Unix系なら ":"+ oldPath = maybe "" id (lookup "PATH" env)+ newPath = intercalate sep extraPaths ++ (if null oldPath then "" else sep ++ oldPath)+ return $ ("PATH", newPath) : filter ((/= "PATH") . fst) env -- | --
src/PMS/Infra/ProcSpawn/DS/Utility.hs view
@@ -15,6 +15,8 @@ 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@@ -87,6 +89,7 @@ (fromPtyHandle, toProcHandle) <- S.createPipe (fromProcHandle, toPtyHandle) <- S.createPipe+ -- (fromProcEHandle, toPtyEHandle) <- S.createPipe baseEnv <- Env.getEnvironment let cwd = Nothing@@ -97,10 +100,12 @@ hPutStrLn stderr $ "[INFO] args = " ++ show args pHdl <- S.runProcess cmd args cwd runEnvs (Just fromPtyHandle) (Just toPtyHandle) (Just toPtyHandle)+ -- pHdl <- S.runProcess cmd args cwd runEnvs (Just fromPtyHandle) (Just toPtyHandle) (Just toPtyEHandle) let procData = ProcData { _wHdLProcData = toProcHandle , _rHdlProcData = fromProcHandle , _eHdlProcData = fromProcHandle+-- , _eHdlProcData = fromProcEHandle , _pHdlProcData = pHdl } @@ -114,9 +119,67 @@ readProc :: ProcData -> IO BS.ByteString readProc dat = do let hdl = dat^.rHdlProcData- timeoutMillis = 5000+ timeoutMillis = 25000 ready <- hWaitForInput hdl timeoutMillis if ready then BS.hGetSome hdl 1024- else E.throwString $ "readProc: timeout waiting for input"- + 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"+++-- |+-- +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+