pms-infra-procspawn 0.0.2.0 → 0.0.3.0

raw patch · 4 files changed

+156/−134 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• pms-infra-procspawn.cabal +1/−1
• src/PMS/Infra/ProcSpawn/DS/Core.hs +44/−99
• src/PMS/Infra/ProcSpawn/DS/Utility.hs +107/−34

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

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

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

@@ -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")+  ]+  -}+