pms-infrastructure 0.0.2.0 → 0.0.3.0
raw patch · 4 files changed
+198/−28 lines, 4 filesdep +strip-ansi-escape
Dependencies added: strip-ansi-escape
Files
- CHANGELOG.md +4/−0
- pms-infrastructure.cabal +4/−3
- src/PMS/Infrastructure/DS/Core.hs +120/−25
- src/PMS/Infrastructure/DS/Utility.hs +70/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for pms-infrastructure +## 0.0.3.0 -- 2025-06-22++* Added file change monitoring for tools-list.json.+ ## 0.0.2.0 -- 2025-06-15 * Added finally to expect to ensure the lock is released.
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.2.0+version: 0.0.3.0 -- A short (one-line) description of the package. synopsis: pms-infrastructure@@ -57,7 +57,7 @@ library -- Import common warning flags.- ghc-options: -Wall+ ghc-options: -Wall -threaded -- Modules exported by the library. exposed-modules: PMS.Infrastructure.DM.Type,@@ -92,6 +92,7 @@ posix-pty, directory, hie-bios,+ strip-ansi-escape, pms-domain-model -- Directories containing source files.@@ -103,7 +104,7 @@ test-suite pms-infrastructure-test -- Import common warning flags.- ghc-options: -Wall+ ghc-options: -Wall -threaded -- Base language which the package is written in. default-language: GHC2021
src/PMS/Infrastructure/DS/Core.hs view
@@ -11,6 +11,7 @@ import Control.Monad.Reader import qualified Control.Concurrent.STM as STM import Data.Conduit+import qualified Control.Concurrent as CC import Control.Concurrent.Async import qualified Data.Text as T import Control.Monad.Except@@ -23,6 +24,9 @@ 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@@ -77,10 +81,11 @@ cmd2task go :: DM.Command -> AppContext (IOTask ())+ go (DM.EchoCommand dat) = genEchoTask dat go (DM.PtyConnectCommand dat) = genPtyConnectTask dat+ go (DM.PtyTerminateCommand dat) = genPtyTerminateTask dat go (DM.PtyMessageCommand dat) = genPtyMessageTask dat go (DM.SystemCommand dat) = genSystemTask dat- go (DM.EchoCommand dat) = genEchoTask dat --------------------------------------------------------------------------------- -- |@@ -132,16 +137,17 @@ -- genSystemTask :: DM.SystemCommandData -> AppContext (IOTask ()) genSystemTask dat = do- scriptsDir <- view DM.scriptsDirDomainData <$> lift ask+ toolsDir <- view DM.toolsDirDomainData <$> lift ask - let name = dat^.DM.nameSystemCommandData+ 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 - -- ToDo: validation- let cmd = scriptsDir </> name ++ ".sh" ++ " " ++ (args^.argumentsStringToolParams)+ let cmd = toolsDir </> name ++ ".sh" ++ " " ++ argsStr $logDebugS DM._LOGTAG $ T.pack $ "systemTask: system cmd. " ++ cmd return $ systemTask cmd callback@@ -167,17 +173,20 @@ let name = dat^.DM.namePtyConnectCommandData callback = dat^.DM.callbackPtyConnectCommandData argsBS = DM.unRawJsonByteString $ dat^.DM.argumentsPtyConnectCommandData+ tout = 30 * 1000 * 1000 prompts <- view DM.promptsDomainData <$> lift ask pmsTMVar <- view pmsAppData <$> ask procTMVar <- view processHandleAppData <$> ask lockTMVar <- view lockAppData <$> ask - (cmd, argsArray) <- getCommandArgs name argsBS- + (cmdTmp, argsArrayTmp) <- getCommandArgs name argsBS+ cmd <- validateCommand cmdTmp+ argsArray <- validateCommandArgs argsArrayTmp+ $logDebugS DM._LOGTAG $ T.pack $ "ptyConnectTask: cmd. " ++ cmd ++ " " ++ show argsArray - return $ ptyConnectTask pmsTMVar procTMVar lockTMVar cmd argsArray prompts callback+ return $ ptyConnectTask pmsTMVar procTMVar lockTMVar cmd argsArray prompts tout callback where -- |@@ -238,12 +247,14 @@ -> String -> [String] -> [String]+ -> Int -> DM.PtyConnectCommandCallback () -> IOTask ()-ptyConnectTask pmsTMVar procTMVar lockTMVar cmd args prompts callback = flip E.catchAny errHdl $ do+ptyConnectTask pmsTMVar procTMVar lockTMVar cmd args prompts tout callback = flip E.catchAny errHdl $ 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@@ -260,9 +271,9 @@ callback (ExitFailure 1) "" "Process is already connected." Nothing -> STM.atomically $ STM.putTMVar procTMVar (Just procHdl) - res <- expect lockTMVar pms prompts-- callback ExitSuccess (maybe "Nothing" id res) ""+ race (expect lockTMVar pms prompts) (CC.threadDelay tout) >>= \case+ Left res -> callback ExitSuccess (maybe "Nothing" id res) ""+ Right _ -> E.throwString "timeout occurred." hPutStrLn stderr "[INFO] PMS.Infrastructure.DS.Core.work.ptyConnectTask end." @@ -275,11 +286,56 @@ -- | --+genPtyTerminateTask :: DM.PtyTerminateCommandData -> AppContext (IOTask ())+genPtyTerminateTask dat = do+ let callback = dat^.DM.callbackPtyTerminateCommandData+ + pmsTMVar <- view pmsAppData <$> ask+ procTMVar <- view processHandleAppData <$> ask++ $logDebugS DM._LOGTAG $ T.pack $ "ptyTerminateTask called. "+ return $ ptyTerminateTask pmsTMVar procTMVar callback++-- |+--+ptyTerminateTask :: STM.TMVar (Maybe Pty)+ -> STM.TMVar (Maybe ProcessHandle)+ -> DM.PtyTerminateCommandCallback ()+ -> IOTask ()+ptyTerminateTask pmsTMVar procTMVar callback = flip E.catchAny errHdl $ do+ hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyTerminateTask run. "++ STM.atomically (STM.swapTMVar pmsTMVar 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+ 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+ exitCode <- waitForProcess phandle+ callback exitCode "pty teminated." ""++ hPutStrLn stderr "[INFO] PMS.Infrastructure.DS.Core.work.ptyTerminateTask end."++ where+ -- |+ --+ errHdl :: E.SomeException -> IO ()+ errHdl e = callback (ExitFailure 1) "" (show e)++++-- |+-- genPtyMessageTask :: DM.PtyMessageCommandData -> AppContext (IOTask ()) genPtyMessageTask dat = do let callback = dat^.DM.callbackPtyMessageCommandData argsBS = DM.unRawJsonByteString $ dat^.DM.argumentsPtyMessageCommandData- + tout = 30 * 1000 * 1000 prompts <- view DM.promptsDomainData <$> lift ask pmsTMVar <- view pmsAppData <$> ask procTMVar <- view processHandleAppData <$> ask@@ -288,7 +344,7 @@ let args = argsDat^.argumentsStringToolParams $logDebugS DM._LOGTAG $ T.pack $ "ptyMessageTask: args. " ++ args- return $ ptyMessageTask pmsTMVar procTMVar lockTMVar args prompts callback+ return $ ptyMessageTask pmsTMVar procTMVar lockTMVar args prompts tout callback -- | --@@ -296,20 +352,18 @@ -> STM.TMVar (Maybe ProcessHandle) -> STM.TMVar () -> String -- arguments line- -> [String] -- promt list+ -> [String] -- prompt list+ -> Int -- timeout microsec -> DM.PtyMessageCommandCallback () -> IOTask ()-ptyMessageTask pmsTMVar _ lockTMVar args prompts callback = flip E.catchAny errHdl $ do+ptyMessageTask ptyTMVar _ lockTMVar args prompts tout callback = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infrastructure.DS.Core.work.ptyMessageTask run. " ++ args - STM.atomically (STM.readTMVar pmsTMVar) >>= \case+ STM.atomically (STM.readTMVar ptyTMVar) >>= \case Nothing -> do- hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyMessageTask: pms is not connected."+ hPutStrLn stderr "[ERROR] PMS.Infrastructure.DS.Core.work.ptyMessageTask: pty is not connected." callback (ExitFailure 1) "" "PTY is not connected."- Just pms -> do- writePty pms $ TE.encodeUtf8 $ T.pack $ args ++ _LF- res <- expect lockTMVar pms prompts- callback ExitSuccess (maybe "Nothing" id res) ""+ Just pty -> go pty hPutStrLn stderr "[INFO] PMS.Infrastructure.DS.Core.work.ptyMessageTask end." @@ -319,6 +373,19 @@ errHdl :: E.SomeException -> IO () errHdl e = callback (ExitFailure 1) "" (show e) + go :: Pty -> IO ()+ go pty = do+ msg <- 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+ Left res -> callback ExitSuccess (maybe "Nothing" id res) ""+ Right _ -> E.throwString "timeout occurred."+++ -- | -- expect :: STM.TMVar () -> Pty -> [String] -> IO (Maybe String)@@ -345,7 +412,6 @@ finalize :: IO () finalize = STM.atomically $ STM.putTMVar lock () - -- | -- readUntilPrompt :: Pty -> [String] -> IO BS.ByteString@@ -357,12 +423,41 @@ go acc = do chunk <- readPty pms- hPutStrLn stderr $ "[INFO] chunk:\n" ++ T.unpack (TE.decodeUtf8 chunk)+ 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'+-} -- | --
src/PMS/Infrastructure/DS/Utility.hs view
@@ -8,6 +8,9 @@ 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@@ -39,3 +42,70 @@ 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"]+