pms-infrastructure 0.0.3.0 → 0.0.4.0
raw patch · 5 files changed
+51/−225 lines, 5 files
Files
- CHANGELOG.md +4/−0
- pms-infrastructure.cabal +1/−1
- src/PMS/Infrastructure/DM/Type.hs +3/−3
- src/PMS/Infrastructure/DS/Core.hs +43/−151
- src/PMS/Infrastructure/DS/Utility.hs +0/−70
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infrastructure +## 0.0.4.0 -- 2025-06-29++* Added prompts interface.+ ## 0.0.3.0 -- 2025-06-22 * Added file change monitoring for tools-list.json.
pms-infrastructure.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.3.0+version: 0.0.4.0 -- A short (one-line) description of the package. synopsis: pms-infrastructure
src/PMS/Infrastructure/DM/Type.hs view
@@ -17,7 +17,7 @@ data AppData = AppData {- _pmsAppData :: STM.TMVar (Maybe Pty)+ _ptyAppData :: STM.TMVar (Maybe Pty) , _processHandleAppData :: STM.TMVar (Maybe ProcessHandle) , _lockAppData :: STM.TMVar () }@@ -26,11 +26,11 @@ defaultAppData :: IO AppData defaultAppData = do- pmsVar <- STM.newTMVarIO Nothing+ ptyVar <- STM.newTMVarIO Nothing procVar <- STM.newTMVarIO Nothing lock <- STM.newTMVarIO () return AppData {- _pmsAppData = pmsVar+ _ptyAppData = ptyVar , _processHandleAppData = procVar , _lockAppData = lock }
src/PMS/Infrastructure/DS/Core.hs view
@@ -24,16 +24,13 @@ import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.String.AnsiEscapeCodes.Strip.Text as ANSI-import qualified Data.Text.Encoding.Error as TEE-import Control.Monad import qualified HIE.Bios as HIE import qualified HIE.Bios.Types as HIE import qualified HIE.Bios.Environment as HIE import qualified System.Directory as D -+import qualified PMS.Domain.Model.DS.Utility as DM import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM @@ -85,7 +82,6 @@ go (DM.PtyConnectCommand dat) = genPtyConnectTask dat go (DM.PtyTerminateCommand dat) = genPtyTerminateTask dat go (DM.PtyMessageCommand dat) = genPtyMessageTask dat- go (DM.SystemCommand dat) = genSystemTask dat --------------------------------------------------------------------------------- -- |@@ -135,39 +131,6 @@ -- | ---genSystemTask :: DM.SystemCommandData -> AppContext (IOTask ())-genSystemTask dat = do- toolsDir <- view DM.toolsDirDomainData <$> lift ask-- let nameTmp = dat^.DM.nameSystemCommandData- callback = dat^.DM.callbackSystemCommandData- argsBS = DM.unRawJsonByteString $ dat^.DM.argumentsSystemCommandData- args <- liftEither $ eitherDecode $ argsBS- - name <- validateCommand nameTmp- argsStr <- validateCommandArg $ args^.argumentsStringToolParams-- let cmd = toolsDir </> name ++ ".sh" ++ " " ++ argsStr-- $logDebugS DM._LOGTAG $ T.pack $ "systemTask: system cmd. " ++ cmd- return $ systemTask cmd callback-- where- -- |- --- systemTask :: String -> DM.SystemCommandCallback () -> IOTask ()- systemTask cmd callback = do- hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.systemTask run. " ++ cmd-- (code, out, err) <- readCreateProcessWithExitCode (shell cmd) ""-- callback code out err-- hPutStrLn stderr "[INFO] PMS.Infrastructure.DS.Core.work.systemTask end."----- |--- genPtyConnectTask :: DM.PtyConnectCommandData -> AppContext (IOTask ()) genPtyConnectTask dat = do let name = dat^.DM.namePtyConnectCommandData@@ -176,17 +139,17 @@ tout = 30 * 1000 * 1000 prompts <- view DM.promptsDomainData <$> lift ask- pmsTMVar <- view pmsAppData <$> ask+ ptyTMVar <- view ptyAppData <$> ask procTMVar <- view processHandleAppData <$> ask lockTMVar <- view lockAppData <$> ask (cmdTmp, argsArrayTmp) <- getCommandArgs name argsBS- cmd <- validateCommand cmdTmp- argsArray <- validateCommandArgs argsArrayTmp+ cmd <- liftIOE $ DM.validateCommand cmdTmp+ argsArray <- liftIOE $ DM.validateArgs argsArrayTmp $logDebugS DM._LOGTAG $ T.pack $ "ptyConnectTask: cmd. " ++ cmd ++ " " ++ show argsArray - return $ ptyConnectTask pmsTMVar procTMVar lockTMVar cmd argsArray prompts tout callback+ return $ ptyConnectTask ptyTMVar procTMVar lockTMVar cmd argsArray prompts tout callback where -- |@@ -248,32 +211,23 @@ -> [String] -> [String] -> Int- -> DM.PtyConnectCommandCallback ()+ -> DM.ToolsCallCommandCallback () -> IOTask ()-ptyConnectTask pmsTMVar procTMVar lockTMVar cmd args prompts tout callback = flip E.catchAny errHdl $ do+ptyConnectTask ptyTMVar procTMVar lockTMVar cmd args prompts tout callback = do hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyConnectTask run. " ++ cmd ++ " " ++ show args - let env = Nothing- -- env = Just [("TERM", "dumb")]- dim = (80, 24)-- (pms, procHdl) <- spawnWithPty env True cmd args dim-- STM.atomically (STM.takeTMVar pmsTMVar) >>= \case- Just _ -> do- hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyConnectTask: pms is already connected."+ STM.atomically (STM.takeTMVar ptyTMVar) >>= \case+ Just p -> do+ STM.atomically $ STM.putTMVar ptyTMVar $ Just p+ hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyConnectTask: pty is already connected." callback (ExitFailure 1) "" "PTY is already connected."- Nothing -> STM.atomically $ STM.putTMVar pmsTMVar (Just pms)-- STM.atomically (STM.takeTMVar procTMVar) >>= \case- Just _ -> do- hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyConnectTask: process is already connected."- callback (ExitFailure 1) "" "Process is already connected."- Nothing -> STM.atomically $ STM.putTMVar procTMVar (Just procHdl)+ Nothing -> E.catchAny runPty errHdl - race (expect lockTMVar pms prompts) (CC.threadDelay tout) >>= \case- Left res -> callback ExitSuccess (maybe "Nothing" id res) ""- Right _ -> E.throwString "timeout occurred."+ STM.atomically (STM.readTMVar ptyTMVar) >>= \case + Just p -> race (DM.expect lockTMVar (readPty p) prompts) (CC.threadDelay tout) >>= \case+ Left res -> callback ExitSuccess (maybe "Nothing" id res) ""+ Right _ -> callback (ExitFailure 1) "" "timeout occurred."+ Nothing -> callback (ExitFailure 1) "" "unexpected. pty not found." hPutStrLn stderr "[INFO] PMS.Infrastructure.DS.Core.work.ptyConnectTask end." @@ -281,8 +235,21 @@ -- | -- errHdl :: E.SomeException -> IO ()- errHdl e = callback (ExitFailure 1) "" (show e)+ errHdl e = do+ STM.atomically $ STM.putTMVar ptyTMVar Nothing+ callback (ExitFailure 1) "" (show e) + -- |+ --+ runPty :: IO ()+ runPty = do+ let env = Nothing+ -- env = Just [("TERM", "dumb")]+ dim = (80, 24)+ (pty, procHdl) <- spawnWithPty env True cmd args dim+ STM.atomically $ STM.putTMVar ptyTMVar (Just pty)+ _ <- STM.atomically $ STM.swapTMVar procTMVar (Just procHdl)+ return () -- | --@@ -290,32 +257,32 @@ genPtyTerminateTask dat = do let callback = dat^.DM.callbackPtyTerminateCommandData - pmsTMVar <- view pmsAppData <$> ask+ ptyTMVar <- view ptyAppData <$> ask procTMVar <- view processHandleAppData <$> ask $logDebugS DM._LOGTAG $ T.pack $ "ptyTerminateTask called. "- return $ ptyTerminateTask pmsTMVar procTMVar callback+ return $ ptyTerminateTask ptyTMVar procTMVar callback -- | -- ptyTerminateTask :: STM.TMVar (Maybe Pty) -> STM.TMVar (Maybe ProcessHandle)- -> DM.PtyTerminateCommandCallback ()+ -> DM.ToolsCallCommandCallback () -> IOTask ()-ptyTerminateTask pmsTMVar procTMVar callback = flip E.catchAny errHdl $ do+ptyTerminateTask ptyTMVar procTMVar callback = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyTerminateTask run. " - STM.atomically (STM.swapTMVar pmsTMVar Nothing) >>= \case+ STM.atomically (STM.swapTMVar ptyTMVar Nothing) >>= \case Nothing -> do hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyTerminateTask: pty is not connected." callback (ExitFailure 1) "" "PTY is not connected."- Just pms -> STM.atomically (STM.swapTMVar procTMVar Nothing) >>= \case+ Just pty -> STM.atomically (STM.swapTMVar procTMVar Nothing) >>= \case Nothing -> do hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyTerminateTask: invalid pty status." callback (ExitFailure 1) "" "invalid pty status." Just phandle -> do hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyTerminateTask closePty : "- closePty pms+ closePty pty exitCode <- waitForProcess phandle callback exitCode "pty teminated." "" @@ -337,14 +304,14 @@ argsBS = DM.unRawJsonByteString $ dat^.DM.argumentsPtyMessageCommandData tout = 30 * 1000 * 1000 prompts <- view DM.promptsDomainData <$> lift ask- pmsTMVar <- view pmsAppData <$> ask+ ptyTMVar <- view ptyAppData <$> ask procTMVar <- view processHandleAppData <$> ask lockTMVar <- view lockAppData <$> ask argsDat <- liftEither $ eitherDecode $ argsBS let args = argsDat^.argumentsStringToolParams $logDebugS DM._LOGTAG $ T.pack $ "ptyMessageTask: args. " ++ args- return $ ptyMessageTask pmsTMVar procTMVar lockTMVar args prompts tout callback+ return $ ptyMessageTask ptyTMVar procTMVar lockTMVar args prompts tout callback -- | --@@ -354,7 +321,7 @@ -> String -- arguments line -> [String] -- prompt list -> Int -- timeout microsec- -> DM.PtyMessageCommandCallback ()+ -> DM.ToolsCallCommandCallback () -> IOTask () ptyMessageTask ptyTMVar _ lockTMVar args prompts tout callback = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyMessageTask run. " ++ args@@ -375,92 +342,17 @@ go :: Pty -> IO () go pty = do- msg <- validateMessage args+ msg <- DM.validateMessage args let cmd = TE.encodeUtf8 $ T.pack $ msg ++ _LF hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyMessageTask writePty : " ++ BS.unpack cmd writePty pty cmd - race (expect lockTMVar pty prompts) (CC.threadDelay tout) >>= \case+ race (DM.expect lockTMVar (readPty pty) prompts) (CC.threadDelay tout) >>= \case Left res -> callback ExitSuccess (maybe "Nothing" id res) "" Right _ -> E.throwString "timeout occurred." - -- |----expect :: STM.TMVar () -> Pty -> [String] -> IO (Maybe String)-expect lock pty prompts = STM.atomically (STM.tryTakeTMVar lock) >>= \case- Nothing -> do- hPutStrLn stderr "[INFO] expect running. skip."- return Nothing- Just () -> flip E.catchAny exception $ flip E.finally finalize $ do- hPutStrLn stderr $ "[INFO] expect: " ++ show prompts- output <- readUntilPrompt pty prompts- let result = T.unpack (TE.decodeUtf8 output)- return (Just result)-- where- -- |- --- exception :: E.SomeException -> IO (Maybe String)- exception e = do- hPutStrLn stderr $ "[ERROR] expect exception: " ++ show e- return . Just . show $ e-- -- |- --- finalize :: IO ()- finalize = STM.atomically $ STM.putTMVar lock ()---- |----readUntilPrompt :: Pty -> [String] -> IO BS.ByteString-readUntilPrompt pms prompts = go BS.empty- where- promptBsList = map BS.pack prompts-- foundPrompt acc = any (`BS.isInfixOf` acc) promptBsList-- go acc = do- chunk <- readPty pms- when ("\ESC[6n" `BS.isInfixOf` chunk) $ do- E.throwString "Unsupported: Detected cursor position report request (ESC[6n)."-- let txt = ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode chunk- hPutStrLn stderr $ "[INFO] chunk:\n" ++ T.unpack txt-- let acc' = BS.append acc chunk- if foundPrompt acc'- then return acc'- else go acc'--{--readUntilPrompt :: Pty -> [String] -> IO BS.ByteString-readUntilPrompt pms prompts = go BS.empty T.empty- where- promptTextList = map T.pack prompts-- foundPrompt :: T.Text -> Bool- foundPrompt txt = any (`T.isInfixOf` txt) promptTextList-- go accBs accTxt = do- chunk <- readPty pms- let txt = ANSI.stripAnsiEscapeCodes $ TE.decodeUtf8With TEE.lenientDecode chunk- hPutStrLn stderr $ "[INFO] chunk:\n" ++ T.unpack txt-- when ("\ESC[6n" `BS.isInfixOf` chunk) $ do- hPutStrLn stderr "[INFO] Detected cursor position report request, replying with ESC[1;1R"- writePty pms (DBS.pack ([0x1B :: Word8, 0x5B :: Word8] ++ map (fromIntegral . ord) "0;0R"))-- let accBs' = BS.append accBs chunk- accTxt' = T.append accTxt txt- if foundPrompt accTxt'- then return accBs'- else go accBs' accTxt'--}---- |--- -- getGhciFlagsFromPath :: FilePath -> Maybe FilePath -> IO [String] getGhciFlagsFromPath prjDir startup = do
src/PMS/Infrastructure/DS/Utility.hs view
@@ -8,9 +8,6 @@ import Control.Monad.Except import Control.Monad.Reader import System.Exit-import qualified Data.Text as T-import Data.Char-import Control.Monad import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DS.Utility as DM@@ -42,70 +39,3 @@ exit2int :: ExitCode -> Int exit2int ExitSuccess = 0 exit2int (ExitFailure n) = n----- |----validateCommand :: String -> AppContext String-validateCommand cmd = do- when (null cmd) $- throwError "Command is empty."-- when (".." `T.isInfixOf` tcmd) $- throwError "Command contains directory traversal '..'."-- when ("/" `T.isInfixOf` tcmd) $- throwError "Command must not contain '/'."-- when ("\\" `T.isInfixOf` tcmd) $- throwError "Command must not contain '\\'."-- when (any (not . isAllowedChar) cmd) $- throwError $ "Command contains disallowed characters: " ++ cmd-- return cmd-- where- tcmd = T.pack cmd- isAllowedChar c = isAlphaNum c || c `elem` ("-._" :: String)- ---- |----validateCommandArg :: String -> AppContext String-validateCommandArg arg = do- let tArg = T.pack arg- when (hasDangerousChars tArg) $- throwError $ "Argument contains potentially dangerous characters: " <> arg- return arg- where- hasDangerousChars :: T.Text -> Bool- hasDangerousChars txt =- any (`T.isInfixOf` txt) [";", "&&", "|", "$", "`", "<", ">", "\\", "\""]---- |----validateCommandArgs :: [String] -> AppContext [String]-validateCommandArgs = mapM validateCommandArg----- |----validateMessage :: String -> IO String-validateMessage cmd = do- when (any (`elem` forbiddenChars) cmd) $- E.throwString "Command contains forbidden characters."-- case words cmd of- (firstWord : _) -> when (firstWord `elem` forbiddenCommands) $- E.throwString "Command is forbidden."- _ -> return ()-- return cmd- where- forbiddenChars :: [Char]- forbiddenChars = [';', '&', '|', '`']-- forbiddenCommands :: [String]- forbiddenCommands = ["rm", "mv", "dd", "chmod", "chown", "shutdown", "reboot", "kill", "nc", "telnet", "ssh"]-