diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/pms-infra-procspawn.cabal b/pms-infra-procspawn.cabal --- a/pms-infra-procspawn.cabal +++ b/pms-infra-procspawn.cabal @@ -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 diff --git a/src/PMS/Infra/ProcSpawn/DS/Core.hs b/src/PMS/Infra/ProcSpawn/DS/Core.hs --- a/src/PMS/Infra/ProcSpawn/DS/Core.hs +++ b/src/PMS/Infra/ProcSpawn/DS/Core.hs @@ -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 -- | -- diff --git a/src/PMS/Infra/ProcSpawn/DS/Utility.hs b/src/PMS/Infra/ProcSpawn/DS/Utility.hs --- a/src/PMS/Infra/ProcSpawn/DS/Utility.hs +++ b/src/PMS/Infra/ProcSpawn/DS/Utility.hs @@ -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 +