pms-infra-procspawn 0.0.1.0 → 0.0.2.0
raw patch · 6 files changed
+390/−156 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +4/−0
- pms-infra-procspawn.cabal +7/−7
- src/PMS/Infra/ProcSpawn/App/Control.hs +2/−0
- src/PMS/Infra/ProcSpawn/DM/Type.hs +23/−8
- src/PMS/Infra/ProcSpawn/DS/Core.hs +245/−141
- src/PMS/Infra/ProcSpawn/DS/Utility.hs +109/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infra-procspawn +## 0.0.2.0 -- 2025-07-13++* Added serial tool.+ ## 0.0.1.0 -- 2025-06-29 * First version.
pms-infra-procspawn.cabal view
@@ -1,4 +1,4 @@-cabal-version: 3.12+cabal-version: 2.4 -- The cabal-version field refers to the version of the .cabal specification, -- and can be different from the cabal-install (the tool) version and the -- Cabal (the library) version you are using. As such, the Cabal (the library)@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.1.0+version: 0.0.2.0 -- A short (one-line) description of the package. synopsis: pms-infra-procspawn@@ -73,7 +73,7 @@ -- other-extensions: -- Other library packages from which modules are imported.- build-depends: base ^>=4.21.0.0,+ build-depends: base >= 4.18 && < 5, data-default, monad-logger, mtl,@@ -96,15 +96,15 @@ hs-source-dirs: src -- Base language which the package is written in.- default-language: GHC2021- default-extensions: LambdaCase+ default-language: Haskell2010+ -- default-extensions: LambdaCase test-suite pms-infra-procspawn-test -- Import common warning flags. ghc-options: -Wall -threaded -- Base language which the package is written in.- default-language: GHC2021+ default-language: Haskell2010 -- Modules included in this executable, other than Main. other-modules: PMS.Infra.ProcSpawn.App.ControlSpec@@ -122,7 +122,7 @@ main-is: Spec.hs -- Test dependencies.- build-depends: base ^>=4.21.0.0,+ build-depends: base >= 4.18 && < 5, hspec, hspec-discover, data-default,
src/PMS/Infra/ProcSpawn/App/Control.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ module PMS.Infra.ProcSpawn.App.Control where import System.IO
src/PMS/Infra/ProcSpawn/DM/Type.hs view
@@ -58,17 +58,17 @@ -------------------------------------------------------------------------------------------- -- | ---data StringToolParams =- StringToolParams {- _argumentsStringToolParams :: String+data ProcStringToolParams =+ ProcStringToolParams {+ _argumentsProcStringToolParams :: String } deriving (Show, Read, Eq) -$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "StringToolParams", omitNothingFields = True} ''StringToolParams)-makeLenses ''StringToolParams+$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ProcStringToolParams", omitNothingFields = True} ''ProcStringToolParams)+makeLenses ''ProcStringToolParams -instance Default StringToolParams where- def = StringToolParams {- _argumentsStringToolParams = def+instance Default ProcStringToolParams where+ def = ProcStringToolParams {+ _argumentsProcStringToolParams = def } @@ -87,4 +87,19 @@ def = ProcCommandToolParams { _commandProcCommandToolParams = def , _argumentsProcCommandToolParams = def+ }++-- |+--+data ProcStringArrayToolParams =+ ProcStringArrayToolParams {+ _argumentsProcStringArrayToolParams :: [String]+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ProcStringArrayToolParams", omitNothingFields = True} ''ProcStringArrayToolParams)+makeLenses ''ProcStringArrayToolParams++instance Default ProcStringArrayToolParams where+ def = ProcStringArrayToolParams {+ _argumentsProcStringArrayToolParams = def }
src/PMS/Infra/ProcSpawn/DS/Core.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} module PMS.Infra.ProcSpawn.DS.Core where @@ -18,11 +19,11 @@ import qualified Control.Exception.Safe as E import System.Exit import qualified Data.Text.Encoding as TE-import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import Data.Aeson import qualified System.Process as S import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy.Char8 as BL import qualified PMS.Domain.Model.DS.Utility as DM import qualified PMS.Domain.Model.DM.Type as DM@@ -71,6 +72,7 @@ errHdl :: String -> ConduitT DM.ProcSpawnCommand (IOTask ()) AppContext () errHdl msg = do $logWarnS DM._LOGTAG $ T.pack $ "cmd2task: exception occurred. skip. " ++ msg+ lift $ errorToolsCallResponse $ "cmd2task: exception occurred. skip. " ++ msg cmd2task go :: DM.ProcSpawnCommand -> AppContext (IOTask ())@@ -103,44 +105,7 @@ $logDebugS DM._LOGTAG "sink: end async." return () ------------------------------------------------------------------------------------- |----toolsCallResponse :: STM.TQueue DM.McpResponse- -> DM.JsonRpcRequest- -> ExitCode- -> String- -> String- -> IO ()-toolsCallResponse resQ jsonRpc code outStr errStr = do- let content = [ DM.McpToolsCallResponseResultContent "text" outStr- , DM.McpToolsCallResponseResultContent "text" errStr- ]- result = DM.McpToolsCallResponseResult {- DM._contentMcpToolsCallResponseResult = content- , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)- }- resDat = DM.McpToolsCallResponseData jsonRpc result- res = DM.McpToolsCallResponse resDat - STM.atomically $ STM.writeTQueue resQ res---- |----errorToolsCallResponse :: String -> AppContext ()-errorToolsCallResponse errStr = do- jsonRpc <- view jsonrpcAppData <$> ask- let content = [ DM.McpToolsCallResponseResultContent "text" errStr ]- result = DM.McpToolsCallResponseResult {- DM._contentMcpToolsCallResponseResult = content- , DM._isErrorMcpToolsCallResponseResult = True- }- resDat = DM.McpToolsCallResponseData jsonRpc result- res = DM.McpToolsCallResponse resDat-- resQ <- view DM.responseQueueDomainData <$> lift ask- liftIOE $ STM.atomically $ STM.writeTQueue resQ res- --------------------------------------------------------------------------------- -- | --@@ -159,168 +124,307 @@ echoTask resQ cmdDat val = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.echoTask run. " ++ val - response ExitSuccess val ""+ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcEchoCommandData) ExitSuccess val "" hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.echoTask end." where errHdl :: E.SomeException -> IO ()- errHdl e = response (ExitFailure 1) "" (show e)-- response :: ExitCode -> String -> String -> IO ()- response code outStr errStr = do- let jsonRpc = cmdDat^.DM.jsonrpcProcEchoCommandData- content = [ DM.McpToolsCallResponseResultContent "text" outStr- , DM.McpToolsCallResponseResultContent "text" errStr- ]- result = DM.McpToolsCallResponseResult {- DM._contentMcpToolsCallResponseResult = content- , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)- }- resDat = DM.McpToolsCallResponseData jsonRpc result- res = DM.McpToolsCallResponse resDat-- STM.atomically $ STM.writeTQueue resQ res+ errHdl e = toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcEchoCommandData) (ExitFailure 1) "" (show e) -- | -- genProcRunTask :: DM.ProcRunCommandData -> AppContext (IOTask ())-genProcRunTask dat = do- let name = dat^.DM.nameProcRunCommandData- argsBS = DM.unRawJsonByteString $ dat^.DM.argumentsProcRunCommandData- tout = 30 * 1000 * 1000+genProcRunTask cmdDat = case cmdDat^.DM.nameProcRunCommandData of+ "proc-spawn" -> genProcSpawn cmdDat+ "proc-ssh" -> genProcSpawn cmdDat+ "proc-telnet" -> genProcTelnet cmdDat+ "proc-cmd" -> genProcCMD cmdDat+ "proc-ps" -> genProcPS cmdDat+ x -> throwError $ "genProcRunTask: unsupported command. " ++ x ++-- |+-- +genProcSpawn :: DM.ProcRunCommandData -> AppContext (IOTask ())+genProcSpawn cmdDat = do+ let name = cmdDat^.DM.nameProcRunCommandData+ argsBS = DM.unRawJsonByteString $ cmdDat^.DM.argumentsProcRunCommandData+ tout = DM._TIMEOUT_MICROSEC+ prompts <- view DM.promptsDomainData <$> lift ask resQ <- view DM.responseQueueDomainData <$> lift ask procMVar <- view processAppData <$> ask lockTMVar <- view lockAppData <$> ask - (cmdTmp, argsArrayTmp) <- getCommandArgs name argsBS+ (cmdTmp, argsArrayTmp, addPrompts) <- getCommandArgs name argsBS cmd <- liftIOE $ DM.validateCommand cmdTmp argsArray <- liftIOE $ DM.validateArgs argsArrayTmp $logDebugS DM._LOGTAG $ T.pack $ "genProcRunTask: cmd. " ++ cmd ++ " " ++ show argsArray - return $ procRunTask dat resQ procMVar lockTMVar cmd argsArray prompts tout+ return $ procSpawnTask cmdDat resQ procMVar lockTMVar cmd argsArray (prompts++addPrompts) tout where -- | Get command and arguments from the given name and arguments.- getCommandArgs :: String -> BL.ByteString -> AppContext (String, [String])+ getCommandArgs :: String -> BL.ByteString -> AppContext (String, [String], [String]) getCommandArgs "proc-spawn" argsBS = do argsDat <- liftEither $ eitherDecode $ argsBS let argsArray = maybe [] id (argsDat^.argumentsProcCommandToolParams) cmd = argsDat^.commandProcCommandToolParams- return (cmd, argsArray)- getCommandArgs x _ = throwError $ "getCommand: unsupported command. " ++ x+ return (cmd, argsArray, []) + getCommandArgs "proc-ssh" argsBS = do+ argsDat <- liftEither $ eitherDecode $ argsBS+ let argsArray0 = argsDat ^. argumentsProcStringArrayToolParams+ argsArray = if "-tt" `elem` argsArray0 then argsArray0 else "-tt" : argsArray0+ return ("ssh", argsArray, [")?", "password:"]) + getCommandArgs "proc-telnet" argsBS = do+ argsDat <- liftEither $ eitherDecode $ argsBS+ let argsArray = argsDat^.argumentsProcStringArrayToolParams+ return ("telnet", argsArray, ["login:", "Password:"])++ getCommandArgs x _ = throwError $ "getCommandArgs: unsupported command. " ++ x++ -- | -- -procRunTask :: DM.ProcRunCommandData- -> STM.TQueue DM.McpResponse- -> STM.TMVar (Maybe ProcData)- -> STM.TMVar ()- -> String- -> [String]- -> [String]- -> Int- -> IOTask ()-procRunTask cmdDat resQ procVar lockTMVar cmd args prompts tout = do- hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask start. "+procSpawnTask :: DM.ProcRunCommandData+ -> STM.TQueue DM.McpResponse+ -> STM.TMVar (Maybe ProcData)+ -> STM.TMVar ()+ -> String+ -> [String]+ -> [String]+ -> Int+ -> IOTask ()+procSpawnTask cmdDat resQ procVar lockTMVar cmd args prompts tout = do+ hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.procSpawnTask start. " STM.atomically (STM.takeTMVar procVar) >>= \case Just p -> do STM.atomically $ STM.putTMVar procVar $ Just p- hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyConnectTask: pms is already connected."- response (ExitFailure 1) "" "process is already running."- Nothing -> E.catchAny runProc errHdl+ 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 STM.atomically (STM.readTMVar procVar) >>= \case Just p -> race (DM.expect lockTMVar (readProc p) prompts) (CC.threadDelay tout) >>= \case- Left res -> response ExitSuccess (maybe "Nothing" id res) ""- Right _ -> response (ExitFailure 1) "" "timeout occurred."+ 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.work.ptyConnectTask: unexpected. proc not found."- response (ExitFailure 1) "" "unexpected. proc not found."+ hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.procSpawnTask: unexpected. proc not found."+ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "unexpected. proc not found." - hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask end."+ hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procSpawnTask end." where errHdl :: E.SomeException -> IO () errHdl e = do STM.atomically $ STM.putTMVar procVar Nothing- hPutStrLn stderr $ "[ERROR] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc: exception occurred. " ++ show e- response (ExitFailure 1) "" (show e)+ hPutStrLn stderr $ "[ERROR] PMS.Infra.ProcSpawn.DS.Core.procRunTask: exception occurred. " ++ show e+ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" (show e) - runProc :: IO ()- runProc = do- hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc start."- (fromPmsHandle, toProcHandle) <- S.createPipe- (fromProcHandle, toPmsHandle) <- S.createPipe- let cwd = Nothing- runEnvs = Nothing-{-- osEnc <- mkTextEncoding "UTF-8//TRANSLIT" - let runEnvs = Nothing- bufMode = S.NoBuffering- --let bufMode = S.BlockBuffering $ Just 1024+-- |+-- +genProcCMD :: DM.ProcRunCommandData -> AppContext (IOTask ())+genProcCMD cmdDat = do+ $logDebugS DM._LOGTAG $ T.pack $ "genProcCMD: called. " - S.hSetBuffering toPhoityneHandle bufMode- S.hSetEncoding toPhoityneHandle osEnc- S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF- --S.hSetBinaryMode toPhoityneHandle True+ let tout = DM._TIMEOUT_MICROSEC - S.hSetBuffering fromPhoityneHandle bufMode- S.hSetEncoding fromPhoityneHandle S.utf8- S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF- --S.hSetBinaryMode fromPhoityneHandle True+ prompts <- view DM.promptsDomainData <$> lift ask+ resQ <- view DM.responseQueueDomainData <$> lift ask+ procMVar <- view processAppData <$> ask+ lockTMVar <- view lockAppData <$> ask+ + return $ genProcCMDTask cmdDat resQ procMVar lockTMVar prompts tout - S.hSetBuffering toGHCiHandle bufMode- S.hSetEncoding toGHCiHandle S.utf8- S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF- --S.hSetBinaryMode toGHCiHandle True+-- |+-- +genProcCMDTask :: DM.ProcRunCommandData+ -> STM.TQueue DM.McpResponse+ -> STM.TMVar (Maybe ProcData)+ -> STM.TMVar ()+ -> [String]+ -> Int+ -> IOTask ()+genProcCMDTask cmdDat resQ procVar lockTMVar prompts tout = flip E.catchAny errHdl $ do+ hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask start. " - S.hSetBuffering fromGHCiHandle bufMode- S.hSetEncoding fromGHCiHandle osEnc- 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)+ STM.atomically (STM.takeTMVar procVar) >>= \case+ Just p -> do+ 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" [] - hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc end."+ STM.atomically (STM.readTMVar procVar) >>= \case+ Nothing -> do+ hPutStrLn stderr "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask: process is not started."+ E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask: process is not started."+ Just procDat -> do+ let wHdl = procDat^.wHdLProcData+ msg = "chcp 65001 & prompt $P$G$G$G"+ cmd = TE.encodeUtf8 $ T.pack $ msg ++ DM._LF+ + hPutStrLn stderr $ "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask writeProc : " ++ BS8.unpack cmd+ BS.hPut wHdl cmd+ hFlush wHdl - response :: ExitCode -> String -> String -> IO ()- response code outStr errStr = do- let jsonRpc = cmdDat^.DM.jsonrpcProcRunCommandData- content = [ DM.McpToolsCallResponseResultContent "text" outStr- , DM.McpToolsCallResponseResultContent "text" errStr- ]- result = DM.McpToolsCallResponseResult {- DM._contentMcpToolsCallResponseResult = content- , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)- }- resDat = DM.McpToolsCallResponseData jsonRpc result- res = DM.McpToolsCallResponse resDat+ 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.genProcCMDTask: unexpected. proc not found."+ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "unexpected. proc not found." - STM.atomically $ STM.writeTQueue resQ res+ hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask end." + where+ errHdl :: E.SomeException -> IO ()+ errHdl e = do+ STM.atomically $ STM.putTMVar procVar Nothing+ hPutStrLn stderr $ "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcCMDTask: exception occurred. " ++ show e+ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" (show e)+++ -- | -- -readProc :: ProcData -> IO BS.ByteString-readProc dat = do- let hdl = dat^.rHdlProcData- BS.hGetSome hdl 4096+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. "++ 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 $ genProcPSTask cmdDat resQ procMVar lockTMVar prompts tout++-- |+-- +genProcPSTask :: DM.ProcRunCommandData+ -> STM.TQueue DM.McpResponse+ -> STM.TMVar (Maybe ProcData)+ -> STM.TMVar ()+ -> [String]+ -> Int+ -> IOTask ()+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)>>>\" }"++ 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."+ E.throwString "[ERROR] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask: process is already running."+ 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+ 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.genProcPSTask: unexpected. proc not found."+ toolsCallResponse resQ (cmdDat^.DM.jsonrpcProcRunCommandData) (ExitFailure 1) "" "unexpected. proc not found."++ hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.genProcPSTask end."++ where+ errHdl :: E.SomeException -> IO ()+ errHdl e = do+ 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)++-- | -- genProcTerminateTask :: DM.ProcTerminateCommandData -> AppContext (IOTask ()) genProcTerminateTask dat = do@@ -370,7 +474,7 @@ procTMVar <- view processAppData <$> ask lockTMVar <- view lockAppData <$> ask argsDat <- liftEither $ eitherDecode $ argsBS- let args = argsDat^.argumentsStringToolParams+ let args = argsDat^.argumentsProcStringToolParams $logDebugS DM._LOGTAG $ T.pack $ "genProcMessageTask: args. " ++ args return $ procMessageTask cmdData resQ procTMVar lockTMVar args prompts tout
src/PMS/Infra/ProcSpawn/DS/Utility.hs view
@@ -2,11 +2,19 @@ module PMS.Infra.ProcSpawn.DS.Utility where +import System.IO+import Control.Lens+import System.Exit import System.Log.FastLogger import qualified Control.Exception.Safe as E import Control.Monad.IO.Class import Control.Monad.Except 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 PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DS.Utility as DM@@ -32,3 +40,104 @@ errHdl :: E.SomeException -> IO (Either String a) errHdl = return . Left . show++---------------------------------------------------------------------------------+-- |+--+toolsCallResponse :: STM.TQueue DM.McpResponse+ -> DM.JsonRpcRequest+ -> ExitCode+ -> String+ -> String+ -> IO ()+toolsCallResponse resQ jsonRpc code outStr errStr = do+ let content = [ DM.McpToolsCallResponseResultContent "text" outStr+ , DM.McpToolsCallResponseResultContent "text" errStr+ ]+ result = DM.McpToolsCallResponseResult {+ DM._contentMcpToolsCallResponseResult = content+ , DM._isErrorMcpToolsCallResponseResult = (ExitSuccess /= code)+ }+ resDat = DM.McpToolsCallResponseData jsonRpc result+ res = DM.McpToolsCallResponse resDat++ STM.atomically $ STM.writeTQueue resQ res++-- |+--+errorToolsCallResponse :: String -> AppContext ()+errorToolsCallResponse errStr = do+ jsonRpc <- view jsonrpcAppData <$> ask+ let content = [ DM.McpToolsCallResponseResultContent "text" errStr ]+ result = DM.McpToolsCallResponseResult {+ DM._contentMcpToolsCallResponseResult = content+ , DM._isErrorMcpToolsCallResponseResult = True+ }+ resDat = DM.McpToolsCallResponseData jsonRpc result+ res = DM.McpToolsCallResponse resDat++ resQ <- view DM.responseQueueDomainData <$> lift ask+ liftIOE $ STM.atomically $ STM.writeTQueue resQ res++-- |+--+runProc :: STM.TMVar (Maybe ProcData) -> String -> [String]-> IO ()+runProc procVar cmd args = do+ hPutStrLn stderr "[INFO] PMS.Infra.ProcSpawn.DS.Core.procRunTask.runProc start."+ (fromPmsHandle, toProcHandle) <- S.createPipe+ (fromProcHandle, toPmsHandle) <- S.createPipe+ let cwd = Nothing+ runEnvs = Nothing++-- osEnc <- mkTextEncoding "UTF-8//TRANSLIT"+-- S.hSetEncoding toPmsHandle osEnc+-- S.hSetEncoding fromPmsHandle S.utf8+-- S.hSetEncoding toProcHandle S.utf8+-- S.hSetEncoding fromProcHandle osEnc++{-+ osEnc <- mkTextEncoding "UTF-8//TRANSLIT"++ let runEnvs = Nothing+ bufMode = S.NoBuffering+ --let bufMode = S.BlockBuffering $ Just 1024++ S.hSetBuffering toPhoityneHandle bufMode+ S.hSetEncoding toPhoityneHandle osEnc+ S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF+ --S.hSetBinaryMode toPhoityneHandle True++ S.hSetBuffering fromPhoityneHandle bufMode+ S.hSetEncoding fromPhoityneHandle S.utf8+ S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF+ --S.hSetBinaryMode fromPhoityneHandle True++ S.hSetBuffering toGHCiHandle bufMode+ S.hSetEncoding toGHCiHandle S.utf8+ S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF+ --S.hSetBinaryMode toGHCiHandle True++ S.hSetBuffering fromGHCiHandle bufMode+ S.hSetEncoding fromGHCiHandle osEnc+ 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