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.3.0 -- 2025-07-20 + +* Added proc tool. + ## 0.0.2.0 -- 2025-07-13 * Added serial tool. 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.2.0 +version: 0.0.3.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 @@ -62,17 +62,18 @@ -- cmd2task :: ConduitT DM.ProcSpawnCommand (IOTask ()) AppContext () cmd2task = await >>= \case - Just cmd -> flip catchError errHdl $ do + Just cmd -> flip catchError (errHdl cmd) $ do lift (go cmd) >>= yield >> cmd2task Nothing -> do $logWarnS DM._LOGTAG "cmd2task: await returns nothing. skip." cmd2task where - errHdl :: String -> ConduitT DM.ProcSpawnCommand (IOTask ()) AppContext () - errHdl msg = do + errHdl :: DM.ProcSpawnCommand -> String -> ConduitT DM.ProcSpawnCommand (IOTask ()) AppContext () + errHdl procCmd msg = do + let jsonrpc = DM.getJsonRpcProcSpawnCommand procCmd $logWarnS DM._LOGTAG $ T.pack $ "cmd2task: exception occurred. skip. " ++ msg - lift $ errorToolsCallResponse $ "cmd2task: exception occurred. skip. " ++ msg + lift $ errorToolsCallResponse jsonrpc $ "cmd2task: exception occurred. skip. " ++ msg cmd2task go :: DM.ProcSpawnCommand -> AppContext (IOTask ()) @@ -138,7 +139,9 @@ genProcRunTask cmdDat = case cmdDat^.DM.nameProcRunCommandData of "proc-spawn" -> genProcSpawn cmdDat "proc-ssh" -> genProcSpawn cmdDat - "proc-telnet" -> genProcTelnet cmdDat + "proc-telnet" -> genProcSpawn cmdDat + "proc-winpty" -> genProcSpawn cmdDat + "proc-plink" -> genProcSpawn cmdDat "proc-cmd" -> genProcCMD cmdDat "proc-ps" -> genProcPS cmdDat x -> throwError $ "genProcRunTask: unsupported command. " ++ x @@ -151,10 +154,11 @@ 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. - prompts <- view DM.promptsDomainData <$> lift ask - resQ <- view DM.responseQueueDomainData <$> lift ask - procMVar <- view processAppData <$> ask + prompts <- view DM.promptsDomainData <$> lift ask + resQ <- view DM.responseQueueDomainData <$> lift ask + procMVar <- view processAppData <$> ask lockTMVar <- view lockAppData <$> ask (cmdTmp, argsArrayTmp, addPrompts) <- getCommandArgs name argsBS @@ -163,10 +167,11 @@ $logDebugS DM._LOGTAG $ T.pack $ "genProcRunTask: cmd. " ++ cmd ++ " " ++ show argsArray - return $ procSpawnTask cmdDat resQ procMVar lockTMVar cmd argsArray (prompts++addPrompts) tout + return $ procSpawnTask cmdDat resQ procMVar lockTMVar cmd argsArray addEnv (prompts++addPrompts) tout where - -- | Get command and arguments from the given name and arguments. + -- | + -- getCommandArgs :: String -> BL.ByteString -> AppContext (String, [String], [String]) getCommandArgs "proc-spawn" argsBS = do argsDat <- liftEither $ eitherDecode $ argsBS @@ -177,14 +182,31 @@ getCommandArgs "proc-ssh" argsBS = do argsDat <- liftEither $ eitherDecode $ argsBS let argsArray0 = argsDat ^. argumentsProcStringArrayToolParams - argsArray = if "-tt" `elem` argsArray0 then argsArray0 else "-tt" : argsArray0 + argsArray = if "-tt" `elem` argsArray0 then argsArray0 else "-tt" : argsArray0 return ("ssh", argsArray, [")?", "password:"]) + -- return ("ssh", ["-o", "LogLevel=DEBUG", "-v"] ++ argsArray, [")?", "password:"]) getCommandArgs "proc-telnet" argsBS = do argsDat <- liftEither $ eitherDecode $ argsBS let argsArray = argsDat^.argumentsProcStringArrayToolParams - return ("telnet", argsArray, ["login:", "Password:"]) + winpty = "plink" +-- winpty = "C:\\Progra~1\\Git\\usr\\bin\\winpty.exe" + return (winpty, "-telnet":argsArray, ["login:", "Password:"]) + getCommandArgs "proc-winpty" argsBS = do + argsDat <- liftEither $ eitherDecode $ argsBS + let argsArray = argsDat^.argumentsProcStringArrayToolParams + winpty = "winpty" + -- winpty = "C:\\Progra~1\\Git\\usr\\bin\\winpty.exe" + return (winpty, argsArray, ["login:", "Password:", ")?", "password:"]) + + getCommandArgs "proc-plink" argsBS = do + argsDat <- liftEither $ eitherDecode $ argsBS + let argsArray = argsDat^.argumentsProcStringArrayToolParams + plink = "plink" + -- plink = "C:\\Progra~1\\PuTTY\\plink.exe" + return (plink, argsArray, ["login:", "Password:", ")?", "password:"]) + getCommandArgs x _ = throwError $ "getCommandArgs: unsupported command. " ++ x @@ -196,10 +218,11 @@ -> STM.TMVar () -> String -> [String] + -> [(String, String)] -> [String] -> Int -> IOTask () -procSpawnTask cmdDat resQ procVar lockTMVar cmd args prompts tout = do +procSpawnTask cmdDat resQ procVar lockTMVar cmd args addEnv prompts tout = do hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.procSpawnTask start. " STM.atomically (STM.takeTMVar procVar) >>= \case @@ -207,12 +230,14 @@ STM.atomically $ STM.putTMVar procVar $ Just p hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.procSpawnTask: pms is already connected." toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "process is already running." - Nothing -> flip E.catchAny errHdl $ runProc procVar cmd args + Nothing -> do + flip E.catchAny errHdl $ runProc procVar cmd args addEnv STM.atomically (STM.readTMVar procVar) >>= \case - Just p -> race (DM.expect lockTMVar (readProc p) 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." + Just p -> do + race (DM.expect lockTMVar (readProc p) 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 hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.procSpawnTask: unexpected. proc not found." toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "unexpected. proc not found." @@ -259,7 +284,7 @@ STM.atomically $ STM.putTMVar procVar $ Just p hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask: process is already running." E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask: process is already running." - Nothing -> runProc procVar "cmd" [] + Nothing -> runProc procVar "cmd" [] [] STM.atomically (STM.readTMVar procVar) >>= \case Nothing -> do @@ -292,88 +317,8 @@ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" (show e) - -- | -- -genProcTelnet :: DM.ProcRunCommandData -> AppContext (IOTask ()) -genProcTelnet cmdDat = do - $logDebugS DM._LOGTAG $ T.pack $ "genProcTelnet: called. " - - let tout = DM._TIMEOUT_MICROSEC - - prompts <- view DM.promptsDomainData <$> lift ask - resQ <- view DM.responseQueueDomainData <$> lift ask - procMVar <- view processAppData <$> ask - lockTMVar <- view lockAppData <$> ask - - return $ genProcTelnetTask cmdDat resQ procMVar lockTMVar prompts tout - - --- | --- -genProcTelnetTask :: DM.ProcRunCommandData - -> STM.TQueue DM.McpResponse - -> STM.TMVar (Maybe ProcData) - -> STM.TMVar () - -> [String] - -> Int - -> IOTask () -genProcTelnetTask cmdDat resQ procVar lockTMVar prompts tout = flip E.catchAny errHdl $ do - hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask start. " - - STM.atomically (STM.takeTMVar procVar) >>= \case - Just p -> do - STM.atomically $ STM.putTMVar procVar $ Just p - hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: process is already running." - E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: process is already running." - Nothing -> runProc procVar "telnet" ["172.16.0.18"] - - STM.atomically (STM.readTMVar procVar) >>= \case - Nothing -> do - hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: process is not started." - E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: process is not started." - Just procDat -> do - let wHdl = procDat^.wHdLProcData - msg = "phoityne" - cmd = TE.encodeUtf8 $ T.pack $ msg ++ DM._LF - - hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask username : " ++ BS8.unpack cmd - BS.hPut wHdl cmd - hFlush wHdl - - STM.atomically (STM.readTMVar procVar) >>= \case - Nothing -> do - hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: process is not started." - E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: process is not started." - Just procDat -> do - let wHdl = procDat^.wHdLProcData - msg = "1qaz2wsx" - cmd = TE.encodeUtf8 $ T.pack $ msg ++ DM._LF - - hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask password : " ++ BS8.unpack cmd - BS.hPut wHdl cmd - hFlush wHdl - - STM.atomically (STM.readTMVar procVar) >>= \case - Just p -> race (DM.expect lockTMVar (readProc p) 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 - hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.genProcTelnetTask: unexpected. proc not found." - toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "unexpected. proc not found." - - hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask end." - - where - errHdl :: E.SomeException -> IO () - errHdl e = do - STM.atomically $ STM.putTMVar procVar Nothing - hPutStrLn stderr $ "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcTelnetTask: exception occurred. " ++ show e - toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" (show e) - - --- | --- genProcPS :: DM.ProcRunCommandData -> AppContext (IOTask ()) genProcPS cmdDat = do $logDebugS DM._LOGTAG $ T.pack $ "genProcPS: called. " @@ -405,7 +350,7 @@ STM.atomically $ STM.putTMVar procVar $ Just p hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask: process is already running." E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask: process is already running." - Nothing -> runProc procVar "powershell" ["-NoLogo", "-NoExit", "-Command", initCmd] + Nothing -> runProc procVar "powershell" ["-NoLogo", "-NoExit", "-Command", initCmd] [] STM.atomically (STM.readTMVar procVar) >>= \case Just p -> race (DM.expect lockTMVar (readProc p) prompts) (CC.threadDelay tout) >>= \case 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 @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module PMS.Infra.ProcSpawn.DS.Utility where @@ -12,9 +13,8 @@ import Control.Monad.Reader import qualified Control.Concurrent.STM as STM import qualified System.Process as S --- import qualified System.IO as S --- import qualified System.Environment as S import qualified Data.ByteString as BS +import qualified System.Environment as Env import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DS.Utility as DM @@ -65,9 +65,8 @@ -- | -- -errorToolsCallResponse :: String -> AppContext () -errorToolsCallResponse errStr = do - jsonRpc <- view jsonrpcAppData <$> ask +errorToolsCallResponse :: DM.JsonRpcRequest -> String -> AppContext () +errorToolsCallResponse jsonRpc errStr = do let content = [ DM.McpToolsCallResponseResultContent "text" errStr ] result = DM.McpToolsCallResponseResult { DM._contentMcpToolsCallResponseResult = content @@ -81,22 +80,85 @@ -- | -- -runProc :: STM.TMVar (Maybe ProcData) -> String -> [String]-> IO () -runProc procVar cmd args = do +runProc :: STM.TMVar (Maybe ProcData) -> String -> [String] -> [(String, String)] -> IO () +runProc procVar cmd args addEnv = do + hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc start." - (fromPmsHandle, toProcHandle) <- S.createPipe - (fromProcHandle, toPmsHandle) <- S.createPipe + + (fromPtyHandle, toProcHandle) <- S.createPipe + (fromProcHandle, toPtyHandle) <- S.createPipe + + baseEnv <- Env.getEnvironment let cwd = Nothing - runEnvs = Nothing + runEnvs = Just $ baseEnv ++ addEnv --- osEnc <- mkTextEncoding "UTF-8//TRANSLIT" --- S.hSetEncoding toPmsHandle osEnc --- S.hSetEncoding fromPmsHandle S.utf8 --- S.hSetEncoding toProcHandle S.utf8 --- S.hSetEncoding fromProcHandle osEnc + hPutStrLn stderr $ "[INFO] env = " ++ show runEnvs + hPutStrLn stderr $ "[INFO] cmd = " ++ cmd + hPutStrLn stderr $ "[INFO] args = " ++ show args + pHdl <- S.runProcess cmd args cwd runEnvs (Just fromPtyHandle) (Just toPtyHandle) (Just toPtyHandle) + let procData = ProcData { + _wHdLProcData = toProcHandle + , _rHdlProcData = fromProcHandle + , _eHdlProcData = fromProcHandle + , _pHdlProcData = pHdl + } + + STM.atomically $ STM.putTMVar procVar (Just procData) + + hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc end." + + + +-- | +-- +readProc :: ProcData -> IO BS.ByteString +readProc dat = do + let hdl = dat^.rHdlProcData + BS.hGetSome hdl 1024 {- + out <- BS.hGetNonBlocking (dat^.rHdlProcData) 1024 + err <- BS.hGetNonBlocking (dat^.eHdlProcData) 1024 + let combined = out <> err + let text = TE.decodeUtf8With (\_ _ -> Just '?') combined + hPutStrLn stderr $ "[DEBUG readProc] received: " ++ T.unpack text + return combined +-} +{- + S.hSetBuffering fromPtyHandle NoBuffering + S.hSetBuffering toPtyHandle NoBuffering + S.hSetBuffering fromProcHandle NoBuffering + S.hSetBuffering toProcHandle NoBuffering + S.hSetBuffering fromProcEHandle NoBuffering + S.hSetBuffering toPtyEHandle NoBuffering + + + mp <- findExecutable "ssh" + hPutStrLn stderr $ "[INFO] findExecutable = " ++ show mp + + let pathKey = "PATH" + openSSH = "C:\\Windows\\System32\\OpenSSH" + updatedEnv = case lookup pathKey baseEnv of + Just oldPath -> (pathKey, openSSH ++ ";" ++ oldPath) : filter ((/= pathKey) . fst) baseEnv + Nothing -> (pathKey, openSSH) : baseEnv + + hPutStrLn stderr $ "[INFO] updatedEnv = " ++ show updatedEnv +-} + +{- + S.hSetBuffering fromPtyHandle NoBuffering + S.hSetBuffering toPtyHandle NoBuffering + S.hSetBuffering fromProcHandle NoBuffering + S.hSetBuffering toProcHandle NoBuffering + osEnc <- mkTextEncoding "UTF-8//TRANSLIT" + S.hSetEncoding toPtyHandle osEnc + S.hSetEncoding fromPtyHandle S.utf8 + S.hSetEncoding toProcHandle S.utf8 + S.hSetEncoding fromProcHandle osEnc +-} +{- + osEnc <- mkTextEncoding "UTF-8//TRANSLIT" let runEnvs = Nothing bufMode = S.NoBuffering @@ -122,22 +184,33 @@ S.hSetNewlineMode fromGHCiHandle $ S.NewlineMode S.CRLF S.LF --S.hSetBinaryMode fromGHCiHandle True -} - pHdl <- S.runProcess cmd args cwd runEnvs (Just fromPmsHandle) (Just toPmsHandle) (Just toPmsHandle) - let procData = ProcData { - _wHdLProcData = toProcHandle - , _rHdlProcData = fromProcHandle - , _eHdlProcData = fromProcHandle - , _pHdlProcData = pHdl - } - STM.atomically $ STM.putTMVar procVar (Just procData) - - hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc end." - - - --- | --- -readProc :: ProcData -> IO BS.ByteString -readProc dat = do - let hdl = dat^.rHdlProcData - BS.hGetSome hdl 4096 +{- +envall :: [(String, String)] +envall = + [ ("Path", "C:\\Windows\\system32;C:\\Windows;C:\\Windows\\System32\\Wbem;C:\\Windows\\System32\\WindowsPowerShell\\v1.0\\;C:\\Windows\\System32\\OpenSSH\\;C:\\Program Files\\dotnet\\;C:\\Program Files (x86)\\NVIDIA Corporation\\PhysX\\Common;C:\\Program Files\\NVIDIA Corporation\\NVIDIA app\\NvDLISR;C:\\Program Files\\Git\\cmd;C:\\Program Files\\TortoiseGit\\bin;C:\\Program Files (x86)\\Windows Kits\\10\\Windows Performance Toolkit\\;C:\\Users\\phoityne\\AppData\\Local\\Microsoft\\WindowsApps;C:\\Users\\phoityne\\AppData\\Local\\Programs\\Microsoft VS Code\\bin;C:\\ghcup\\bin;C:\\Users\\phoityne\\.dotnet\\tools;c:\\tools\\ghcup\\bin;C:\\Users\\phoityne\\AppData\\Local\\Programs\\Microsoft VS Code Insiders\\bin;c:\\tools\\cabal\\bin;;C:\\Users\\phoityne\\.lmstudio\\bin") +-- , ("PATHEXT", ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC") +-- , ("PROCESSOR_ARCHITECTURE", "AMD64") +-- , ("PROCESSOR_IDENTIFIER", "Intel64 Family 6 Model 183 Stepping 1, GenuineIntel") +-- , ("PROCESSOR_LEVEL", "6") +-- , ("PROCESSOR_REVISION", "b701") + , ("ProgramData", "C:\\ProgramData") -- required for ssh. +------- , ("ProgramFiles", "C:\\Program Files") +------- , ("ProgramFiles(x86)", "C:\\Program Files (x86)") +------- , ("ProgramW6432", "C:\\Program Files") +-- , ("PROMPT", "$P$G") +------- , ("PSModulePath", "C:\\Program Files\\WindowsPowerShell\\Modules;C:\\Windows\\system32\\WindowsPowerShell\\v1.0\\Modules") +-- , ("PUBLIC", "C:\\Users\\Public") +-- , ("SESSIONNAME", "Console") +------ , ("SystemDrive", "C:") + , ("SystemRoot", "C:\\Windows") -- required for ssh. +------ , ("TEMP", "C:\\Users\\phoityne\\AppData\\Local\\Temp") +------ , ("TMP", "C:\\Users\\phoityne\\AppData\\Local\\Temp") +------ , ("USERDOMAIN", "GameNote") +------ , ("USERDOMAIN_ROAMINGPROFILE", "GameNote") +------ , ("USERNAME", "phoityne") +------ , ("USERPROFILE", "C:\\Users\\phoityne") +------ , ("windir", "C:\\Windows") +-- , ("ZES_ENABLE_SYSMAN", "1") + ] + -} +