pms-infra-filesystem 0.0.2.0 → 0.0.3.0
raw patch · 5 files changed
+1318/−93 lines, 5 filesdep +ai-agent-diff-patchdep +regex-tdfadep −unix
Dependencies added: ai-agent-diff-patch, regex-tdfa
Dependencies removed: unix
Files
- CHANGELOG.md +9/−0
- pms-infra-filesystem.cabal +6/−3
- src/PMS/Infra/FileSystem/DM/Type.hs +105/−2
- src/PMS/Infra/FileSystem/DS/Core.hs +311/−88
- test/PMS/Infra/FileSystem/App/ControlSpec.hs +887/−0
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for pms-infra-filesystem +## 0.0.3.0 -- 2026-05-15++* Add `pms-file-info` to report line count and byte size.+* Add `pms-grep-file` to search files with POSIX extended regular expressions and return matching line numbers, text, and column offsets.+* Extend `pms-read-file` with optional `startLine` and `endLine` partial-read parameters.+* Add `pms-replace-file` for ordered literal text replacements.+* Fix UTF-8 handling in `pms-grep-file` responses so Japanese text is returned without mojibake.+* Add tests for file info, grep, partial read, replace, Japanese grep output, and related error cases.+ ## 0.0.2.0 -- 2026-01-31 * Add file system pms-make-dir tools.
pms-infra-filesystem.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-infra-filesystem@@ -90,7 +90,9 @@ filepath, aeson, directory,- pms-domain-model+ pms-domain-model,+ ai-agent-diff-patch,+ regex-tdfa -- Directories containing source files. hs-source-dirs: src@@ -129,10 +131,11 @@ stm, monad-logger, async,- unix, lens, filepath, directory,+ bytestring,+ text, pms-domain-model, pms-infra-filesystem
src/PMS/Infra/FileSystem/DM/Type.hs view
@@ -8,6 +8,7 @@ import Control.Lens import Data.Default import Data.Aeson.TH+import qualified Data.Text as T import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.TH as DM@@ -91,7 +92,9 @@ -- data ReadFileParams = ReadFileParams {- _pathReadFileParams :: String+ _pathReadFileParams :: String+ , _startLineReadFileParams :: Maybe Int -- ^ first line to read (1-based, inclusive). Nothing starts from the beginning+ , _endLineReadFileParams :: Maybe Int -- ^ last line to read (1-based, inclusive). Nothing reads to the end } deriving (Show, Read, Eq) $(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ReadFileParams", omitNothingFields = True} ''ReadFileParams)@@ -99,7 +102,9 @@ instance Default ReadFileParams where def = ReadFileParams {- _pathReadFileParams = def+ _pathReadFileParams = def+ , _startLineReadFileParams = Nothing+ , _endLineReadFileParams = Nothing } -- |@@ -119,3 +124,101 @@ , _contentsWriteFileParams = def } +-- | MCP tool arguments for pms-file-info.+-- Carries the target file path.+data FileInfoParams =+ FileInfoParams {+ _pathFileInfoParams :: String -- ^ path of the file to inspect+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "FileInfoParams", omitNothingFields = True} ''FileInfoParams)+makeLenses ''FileInfoParams++instance Default FileInfoParams where+ def = FileInfoParams {+ _pathFileInfoParams = def+ }++-- | MCP tool arguments for pms-patch-file.+-- Carries the target file path and a unified diff patch string.+data PatchFileParams =+ PatchFileParams {+ _pathPatchFileParams :: String -- ^ path of the file to patch+ , _patchPatchFileParams :: String -- ^ unified diff patch string+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "PatchFileParams", omitNothingFields = True} ''PatchFileParams)+makeLenses ''PatchFileParams++instance Default PatchFileParams where+ def = PatchFileParams {+ _pathPatchFileParams = def+ , _patchPatchFileParams = def+ }++-- | MCP tool arguments for pms-grep-file.+data GrepFileParams =+ GrepFileParams {+ _pathGrepFileParams :: String -- ^ path of the file to search+ , _patternGrepFileParams :: String -- ^ POSIX extended regex pattern+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "GrepFileParams", omitNothingFields = True} ''GrepFileParams)+makeLenses ''GrepFileParams++instance Default GrepFileParams where+ def = GrepFileParams {+ _pathGrepFileParams = def+ , _patternGrepFileParams = def+ }++-- | One hit entry returned by pms-grep-file.+data GrepFileHit =+ GrepFileHit {+ _lineGrepFileHit :: Int -- ^ 1-based line number of the matching line+ , _textGrepFileHit :: T.Text -- ^ full text of the matching line+ , _colsGrepFileHit :: [Int] -- ^ 1-based column offsets of each match within the line+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "GrepFileHit", omitNothingFields = True} ''GrepFileHit)+makeLenses ''GrepFileHit++instance Default GrepFileHit where+ def = GrepFileHit {+ _lineGrepFileHit = def+ , _textGrepFileHit = T.empty+ , _colsGrepFileHit = def+ }++-- | One literal replacement rule for pms-replace-file.+-- All occurrences of oldText are replaced with newText.+data Replacement =+ Replacement {+ _oldTextReplacement :: String -- ^ literal text to search for+ , _newTextReplacement :: String -- ^ replacement text+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "Replacement", omitNothingFields = True} ''Replacement)+makeLenses ''Replacement++instance Default Replacement where+ def = Replacement {+ _oldTextReplacement = def+ , _newTextReplacement = def+ }++-- | MCP tool arguments for pms-replace-file.+data ReplaceFileParams =+ ReplaceFileParams {+ _pathReplaceFileParams :: String+ , _replacementsReplaceFileParams :: [Replacement]+ } deriving (Show, Read, Eq)++$(deriveJSON defaultOptions {fieldLabelModifier = DM.dropDataName "ReplaceFileParams", omitNothingFields = True} ''ReplaceFileParams)+makeLenses ''ReplaceFileParams++instance Default ReplaceFileParams where+ def = ReplaceFileParams {+ _pathReplaceFileParams = def+ , _replacementsReplaceFileParams = def+ }
src/PMS/Infra/FileSystem/DS/Core.hs view
@@ -10,7 +10,7 @@ import Control.Monad.Logger import Control.Monad.IO.Class import Control.Monad.Trans.Class-import Control.Lens+import Control.Lens hiding ((.=)) import Control.Monad.Reader import qualified Control.Concurrent.STM as STM import Data.Conduit@@ -26,6 +26,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text.Encoding.Error as TEE+import AIAgent.DiffPatch.Unified (patchFile)+import Text.Regex.TDFA (getAllMatches, (=~), AllMatches(..)) import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Domain.Model.DM.Constant as DM@@ -75,11 +77,15 @@ cmd2task go :: DM.FileSystemCommand -> AppContext (IOTask ())- go (DM.EchoFileSystemCommand dat) = genEchoTask dat- go (DM.ListDirFileSystemCommand dat) = genListDirTask dat- go (DM.MakeDirFileSystemCommand dat) = genMakeDirTask dat- go (DM.ReadFileFileSystemCommand dat) = genReadFileTask dat+ go (DM.EchoFileSystemCommand dat) = genEchoTask dat+ go (DM.ListDirFileSystemCommand dat) = genListDirTask dat+ go (DM.MakeDirFileSystemCommand dat) = genMakeDirTask dat+ go (DM.ReadFileFileSystemCommand dat) = genReadFileTask dat go (DM.WriteFileFileSystemCommand dat) = genWriteFileTask dat+ go (DM.PatchFileFileSystemCommand dat) = genPatchFileTask dat+ go (DM.FileInfoFileSystemCommand dat) = genFileInfoTask dat+ go (DM.GrepFileFileSystemCommand dat) = genGrepFileTask dat+ go (DM.ReplaceFileFileSystemCommand dat) = genReplaceFileTask dat --------------------------------------------------------------------------------- -- |@@ -127,16 +133,215 @@ echoTask resQ cmdDat val = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.FileSystem.DS.Core.echoTask run. " ++ val - toolsCallResponse resQ (cmdDat^.DM.jsonrpcEchoFileSystemCommandData) ExitSuccess val ""+ toolsCallResponse resQ jsonRpc ExitSuccess val "" hPutStrLn stderr "[INFO] PMS.Infra.FileSystem.DS.Core.echoTask end." where+ jsonRpc = cmdDat^.DM.jsonrpcEchoFileSystemCommandData+ errHdl :: E.SomeException -> IO ()- errHdl e = toolsCallResponse resQ (cmdDat^.DM.jsonrpcEchoFileSystemCommandData) (ExitFailure 1) "" (show e)+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) ---------------------------------------------------------------------------------+-- | Generate an IO task that returns file info (line count, byte size).+genFileInfoTask :: DM.FileInfoFileSystemCommandData -> AppContext (IOTask ())+genFileInfoTask dat = do+ let argsBS = DM.unRawJsonByteString+ $ dat^.DM.argumentsFileInfoFileSystemCommandData+ argsDat <- liftEither $ eitherDecode argsBS++ let path = argsDat^.pathFileInfoParams+ abPath <- liftIO $ makeAbsolute path++ resQ <- view DM.responseQueueDomainData <$> lift ask+ sandboxDir <- view DM.sandboxDirDomainData <$> lift ask++ when (not (permitedPath sandboxDir abPath)) $+ throwError $+ "genFileInfoTask: path is not under sandboxDir. path: " ++ abPath++ $logDebugS DM._LOGTAG $+ T.pack $ "fileInfoTask: path : " ++ abPath+ return $ fileInfoTask resQ dat abPath++-- | Return line count and byte size of the file at the given absolute path.+fileInfoTask :: STM.TQueue DM.McpResponse+ -> DM.FileInfoFileSystemCommandData+ -> String -- ^ absolute path of the target file+ -> IOTask ()+fileInfoTask resQ cmdDat path = flip E.catchAny errHdl $ do+ hPutStrLn stderr $+ "[INFO] PMS.Infra.FileSystem.DS.Core.fileInfoTask run. " ++ path++ bs <- BS.readFile path+ let byteSize = BS.length bs+ txt = TE.decodeUtf8With TEE.lenientDecode bs+ lineCount = length (T.lines txt)+ outJson = BL.unpack $ encode $ object+ [ "lines" .= lineCount+ , "bytes" .= byteSize+ ]++ toolsCallResponse resQ jsonRpc ExitSuccess outJson ""++ hPutStrLn stderr+ "[INFO] PMS.Infra.FileSystem.DS.Core.fileInfoTask end."++ where+ jsonRpc = cmdDat^.DM.jsonrpcFileInfoFileSystemCommandData++ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)+++---------------------------------------------------------------------------------+-- | Generate an IO task that greps a file for lines matching a regex pattern.+genGrepFileTask :: DM.GrepFileFileSystemCommandData -> AppContext (IOTask ())+genGrepFileTask dat = do+ let argsBS = DM.unRawJsonByteString+ $ dat^.DM.argumentsGrepFileFileSystemCommandData+ argsDat <- liftEither $ eitherDecode argsBS++ let path = argsDat^.pathGrepFileParams+ pat = argsDat^.patternGrepFileParams+ abPath <- liftIO $ makeAbsolute path++ resQ <- view DM.responseQueueDomainData <$> lift ask+ sandboxDir <- view DM.sandboxDirDomainData <$> lift ask++ when (not (permitedPath sandboxDir abPath)) $+ throwError $+ "genGrepFileTask: path is not under sandboxDir. path: " ++ abPath++ $logDebugS DM._LOGTAG $+ T.pack $ "grepFileTask: path=" ++ abPath ++ " pattern=" ++ pat+ return $ grepFileTask resQ dat abPath pat++-- | Compute 1-based column offsets of all matches of pat in a single line.+colsOf :: String -> String -> [Int]+colsOf pat line =+ [ off + 1+ | (off, _len) <- getAllMatches (line =~ pat :: AllMatches [] (Int, Int))+ ]++-- | Search a file for lines matching a regex pattern.+-- Returns a JSON array of GrepFileHit objects.+-- Returns "[]" when there are no matches.+grepFileTask :: STM.TQueue DM.McpResponse+ -> DM.GrepFileFileSystemCommandData+ -> String -- ^ absolute path of the target file+ -> String -- ^ regex pattern+ -> IOTask ()+grepFileTask resQ cmdDat path pat = flip E.catchAny errHdl $ do+ hPutStrLn stderr $+ "[INFO] PMS.Infra.FileSystem.DS.Core.grepFileTask run. " ++ path++ txtBs <- BS.readFile path+ let txt = TE.decodeUtf8With TEE.lenientDecode txtBs+ ls = zip [1..] (T.lines txt)+ hits = [ GrepFileHit+ { _lineGrepFileHit = n+ , _textGrepFileHit = l+ , _colsGrepFileHit = cols+ }+ | (n, l) <- ls+ , let cols = colsOf pat (T.unpack l)+ , not (null cols)+ ]+ outJson = T.unpack+ . TE.decodeUtf8With TEE.lenientDecode+ . BL.toStrict+ $ encode hits++ toolsCallResponse resQ jsonRpc ExitSuccess outJson ""++ hPutStrLn stderr+ "[INFO] PMS.Infra.FileSystem.DS.Core.grepFileTask end."++ where+ jsonRpc = cmdDat^.DM.jsonrpcGrepFileFileSystemCommandData++ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)+++---------------------------------------------------------------------------------+-- | Generate an IO task that replaces literal text in a file.+genReplaceFileTask :: DM.ReplaceFileFileSystemCommandData -> AppContext (IOTask ())+genReplaceFileTask dat = do+ let argsBS = DM.unRawJsonByteString+ $ dat^.DM.argumentsReplaceFileFileSystemCommandData+ argsDat <- liftEither $ eitherDecode argsBS++ let path = argsDat^.pathReplaceFileParams+ reps = argsDat^.replacementsReplaceFileParams+ abPath <- liftIO $ makeAbsolute path++ resQ <- view DM.responseQueueDomainData <$> lift ask+ sandboxDir <- view DM.sandboxDirDomainData <$> lift ask++ when (not (permitedPath sandboxDir abPath)) $+ throwError $+ "genReplaceFileTask: path is not under sandboxDir. path: " ++ abPath++ $logDebugS DM._LOGTAG $+ T.pack $ "replaceFileTask: path : " ++ abPath+ return $ replaceFileTask resQ dat abPath reps++-- | Apply literal replacement rules in order.+-- The result is all-or-nothing: Left means callers must not write the file.+applyReplacements :: [Replacement] -> T.Text -> Either String T.Text+applyReplacements [] _ =+ Left "replaceFileTask: replacements must not be empty."+applyReplacements reps txt =+ foldM go txt reps+ where+ go :: T.Text -> Replacement -> Either String T.Text+ go acc rep =+ let old = T.pack $ rep^.oldTextReplacement+ new = T.pack $ rep^.newTextReplacement+ in if T.null old+ then Left "replaceFileTask: oldText must not be empty."+ else if not (old `T.isInfixOf` acc)+ then Left "replaceFileTask: oldText not found."+ else Right $ replaceAllText old new acc++-- | Replace all literal occurrences of old text with new text.+replaceAllText :: T.Text -> T.Text -> T.Text -> T.Text+replaceAllText = T.replace++-- | Replace literal text in a file and write only after every rule succeeds.+replaceFileTask :: STM.TQueue DM.McpResponse+ -> DM.ReplaceFileFileSystemCommandData+ -> String+ -> [Replacement]+ -> IOTask ()+replaceFileTask resQ cmdDat path reps = flip E.catchAny errHdl $ do+ hPutStrLn stderr $+ "[INFO] PMS.Infra.FileSystem.DS.Core.replaceFileTask run. " ++ path++ txtBs <- BS.readFile path+ let txt = TE.decodeUtf8With TEE.lenientDecode txtBs++ case applyReplacements reps txt of+ Left err -> toolsCallResponse resQ jsonRpc (ExitFailure 1) "" err+ Right replaced -> do+ BS.writeFile path $ TE.encodeUtf8 replaced+ toolsCallResponse resQ jsonRpc ExitSuccess path ""++ hPutStrLn stderr+ "[INFO] PMS.Infra.FileSystem.DS.Core.replaceFileTask end."++ where+ jsonRpc = cmdDat^.DM.jsonrpcReplaceFileFileSystemCommandData++ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)+++--------------------------------------------------------------------------------- -- | -- genListDirTask :: DM.ListDirFileSystemCommandData -> AppContext (IOTask ())@@ -168,33 +373,19 @@ entries <- mapM (mkEntry path) names - let entriesJson = T.unpack (TE.decodeUtf8With TEE.lenientDecode (BL.toStrict (encode entries))) -- BL.unpack (encode entries)+ let entriesJson = T.unpack (TE.decodeUtf8With TEE.lenientDecode (BL.toStrict (encode entries))) hPutStrLn stderr $ "[INFO] PMS.Infra.FileSystem.DS.Core.work.listDirTask entriesJson." ++ show entriesJson - response ExitSuccess entriesJson ""+ toolsCallResponse resQ jsonRpc ExitSuccess entriesJson "" hPutStrLn stderr "[INFO] PMS.Infra.FileSystem.DS.Core.work.listDirTask 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.jsonrpcListDirFileSystemCommandData- - 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+ jsonRpc = cmdDat^.DM.jsonrpcListDirFileSystemCommandData - STM.atomically $ STM.writeTQueue resQ res+ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) mkEntry :: FilePath -> FilePath -> IO DirEntry mkEntry base name = do@@ -208,11 +399,11 @@ pure (Just (fromIntegral sz)) pure DirEntry {- _nameDirEntry = name- , _paathDirEntry = fullPath- , _typeDirEntry = if isDir then "directory" else "file"- , _sizeDirEntry = mSize- }+ _nameDirEntry = name+ , _paathDirEntry = fullPath+ , _typeDirEntry = if isDir then "directory" else "file"+ , _sizeDirEntry = mSize+ } ---------------------------------------------------------------------------------@@ -249,36 +440,33 @@ hPutStrLn stderr $ "[INFO] PMS.Infra.FileSystem.DS.Core.work.makeDirTask run. " ++ path - -- mkdir -p 相当+ -- create parent directories as needed (mkdir -p equivalent) createDirectoryIfMissing True path - response ExitSuccess path ""+ toolsCallResponse resQ jsonRpc ExitSuccess path "" hPutStrLn stderr "[INFO] PMS.Infra.FileSystem.DS.Core.work.makeDirTask 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.jsonrpcMakeDirFileSystemCommandData- 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+ jsonRpc = cmdDat^.DM.jsonrpcMakeDirFileSystemCommandData - STM.atomically $ STM.writeTQueue resQ res+ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) ---------------------------------------------------------------------------------+-- | Pure helper: slice a list of lines by optional 1-based start/end indices.+-- - Both Nothing : return the list as-is (no processing needed).+-- - Either is Just: apply drop/take with clamping.+sliceLines :: Maybe Int -> Maybe Int -> [T.Text] -> [T.Text]+sliceLines Nothing Nothing ls = ls+sliceLines mStart mEnd ls =+ let start = maybe 1 id mStart+ end = maybe maxBound id mEnd+ clamped = min end (length ls)+ in take (clamped - start + 1) . drop (start - 1) $ ls+ -- | -- genReadFileTask :: DM.ReadFileFileSystemCommandData -> AppContext (IOTask ())@@ -286,7 +474,9 @@ let argsBS = DM.unRawJsonByteString $ dat^.DM.argumentsReadFileFileSystemCommandData argsDat <- liftEither $ eitherDecode $ argsBS - let path = argsDat^.pathReadFileParams+ let path = argsDat^.pathReadFileParams+ startLine = argsDat^.startLineReadFileParams -- Maybe Int+ endLine = argsDat^.endLineReadFileParams -- Maybe Int abPath <- liftIO $ makeAbsolute path sandboxDir <- view DM.sandboxDirDomainData <$> lift ask @@ -296,40 +486,37 @@ resQ <- view DM.responseQueueDomainData <$> lift ask $logDebugS DM._LOGTAG $ T.pack $ "readFileTask: path. " ++ abPath- return $ readFileTask resQ dat abPath+ return $ readFileTask resQ dat abPath startLine endLine -- | -- -readFileTask :: STM.TQueue DM.McpResponse -> DM.ReadFileFileSystemCommandData -> String -> IOTask ()-readFileTask resQ cmdDat path = flip E.catchAny errHdl $ do+readFileTask :: STM.TQueue DM.McpResponse+ -> DM.ReadFileFileSystemCommandData+ -> String -- ^ absolute path+ -> Maybe Int -- ^ startLine (1-based, inclusive). Nothing = from beginning+ -> Maybe Int -- ^ endLine (1-based, inclusive). Nothing = to end+ -> IOTask ()+readFileTask resQ cmdDat path mStart mEnd = flip E.catchAny errHdl $ do hPutStrLn stderr $ "[INFO] PMS.Infra.FileSystem.DS.Core.work.readFileTask run. " ++ path txtBs <- BS.readFile path- let txt = TE.decodeUtf8With TEE.lenientDecode txtBs- contents = path ++ "\n\n" ++ T.unpack txt+ let txt = TE.decodeUtf8With TEE.lenientDecode txtBs+ -- Both Nothing: return file content as-is (no line split/join, full backward compat).+ -- Either Just: apply line slicing.+ body = case (mStart, mEnd) of+ (Nothing, Nothing) -> T.unpack txt+ _ -> T.unpack . T.unlines . sliceLines mStart mEnd . T.lines $ txt+ contents = path ++ "\n\n" ++ body - response ExitSuccess contents ""+ toolsCallResponse resQ jsonRpc ExitSuccess contents "" hPutStrLn stderr "[INFO] PMS.Infra.FileSystem.DS.Core.work.readFileTask 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.jsonrpcReadFileFileSystemCommandData- 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+ jsonRpc = cmdDat^.DM.jsonrpcReadFileFileSystemCommandData - STM.atomically $ STM.writeTQueue resQ res+ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) ---------------------------------------------------------------------------------@@ -371,26 +558,62 @@ let bs = TE.encodeUtf8 (T.pack contents) BS.writeFile path bs - response ExitSuccess path ""+ toolsCallResponse resQ jsonRpc ExitSuccess path "" hPutStrLn stderr "[INFO] PMS.Infra.FileSystem.DS.Core.work.writeFileTask end." where+ jsonRpc = cmdDat^.DM.jsonrpcWriteFileFileSystemCommandData+ errHdl :: E.SomeException -> IO ()- errHdl e = response (ExitFailure 1) "" (show e)+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e) - response :: ExitCode -> String -> String -> IO ()- response code outStr errStr = do- let jsonRpc = cmdDat^.DM.jsonrpcWriteFileFileSystemCommandData- 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+---------------------------------------------------------------------------------+-- | Generate an IO task that applies a unified diff patch to a file.+-- Validates sandbox restriction before returning the task.+genPatchFileTask :: DM.PatchFileFileSystemCommandData -> AppContext (IOTask ())+genPatchFileTask dat = do+ let argsBS = DM.unRawJsonByteString+ $ dat^.DM.argumentsPatchFileFileSystemCommandData+ argsDat <- liftEither $ eitherDecode argsBS + let path = argsDat^.pathPatchFileParams+ ptch = argsDat^.patchPatchFileParams+ abPath <- liftIO $ makeAbsolute path++ resQ <- view DM.responseQueueDomainData <$> lift ask+ sandboxDir <- view DM.sandboxDirDomainData <$> lift ask++ when (not (permitedPath sandboxDir abPath)) $+ throwError $+ "genPatchFileTask: path is not under sandboxDir. path: " ++ abPath++ $logDebugS DM._LOGTAG $+ T.pack $ "patchFileTask: path : " ++ abPath+ return $ patchFileTask resQ dat abPath ptch++-- | Apply a unified diff patch to the file at the given absolute path.+-- On success returns the file path in stdout; on failure returns the error in stderr.+patchFileTask :: STM.TQueue DM.McpResponse+ -> DM.PatchFileFileSystemCommandData+ -> String -- ^ absolute path of the target file+ -> String -- ^ unified diff patch string+ -> IOTask ()+patchFileTask resQ cmdDat path ptch = flip E.catchAny errHdl $ do+ hPutStrLn stderr $+ "[INFO] PMS.Infra.FileSystem.DS.Core.patchFileTask run. " ++ path++ result <- patchFile path ptch+ case result of+ Left err -> toolsCallResponse resQ jsonRpc (ExitFailure 1) "" err+ Right () -> toolsCallResponse resQ jsonRpc ExitSuccess path ""++ hPutStrLn stderr+ "[INFO] PMS.Infra.FileSystem.DS.Core.patchFileTask end."++ where+ jsonRpc = cmdDat^.DM.jsonrpcPatchFileFileSystemCommandData++ errHdl :: E.SomeException -> IO ()+ errHdl e = toolsCallResponse resQ jsonRpc (ExitFailure 1) "" (show e)
test/PMS/Infra/FileSystem/App/ControlSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module PMS.Infra.FileSystem.App.ControlSpec (spec) where @@ -8,9 +9,17 @@ import qualified Control.Concurrent.STM as STM import Control.Lens import Data.Default+import System.Directory (removeFile, makeAbsolute)+import System.FilePath ((</>))+import Control.Exception (catch, IOException)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import qualified PMS.Domain.Model.DM.Type as DM import qualified PMS.Infra.FileSystem.App.Control as SUT+import qualified PMS.Infra.FileSystem.DS.Core as Core import qualified PMS.Infra.FileSystem.DM.Type as SUT -- |@@ -73,11 +82,23 @@ tearDown _ = do putStrLn "[INFO] EXECUTED AFTER EACH TEST FINISHES." +-- | Escape backslashes in a file path for embedding in a JSON string literal.+escapePathForJson :: FilePath -> String+escapePathForJson = concatMap (\c -> if c == '\\' then "\\\\" else [c])++-- | Remove a file, ignoring errors (used for test cleanup).+removeFileSilent :: FilePath -> IO ()+removeFileSilent f = removeFile f `catch` \(_ :: IOException) -> return ()+ -- | -- run :: SpecWith SpecContext run = do describe "runWithAppData" $ do++ -- -----------------------------------------------------------------------+ -- Existing: echo command+ -- ----------------------------------------------------------------------- context "when echo command issued." $ do it "should call callback" $ \ctx -> do putStrLn "[INFO] EXECUTING THE FIRST TEST."@@ -99,5 +120,871 @@ let actual = dat^.DM.jsonrpcMcpToolsCallResponseData^.DM.jsonrpcJsonRpcRequest actual `shouldBe` expect++ cancel thId++ -- -----------------------------------------------------------------------+ -- TC-01: patch-file with a valid patch+ -- -----------------------------------------------------------------------+ context "when patch-file command issued with valid patch." $ do+ it "should apply patch and return file path" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-01: patch-file valid patch."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-patch-file-tc01.txt"++ -- Prepare target file+ writeFile testFile "line1\nline2\nline3\n"++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-patch-file-01" }+ -- Patch: replace "line2" with "LINE2"+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"patch\":\"@@ -1,3 +1,3 @@\\n line1\\n-line2\\n+LINE2\\n line3\\n\"}"+ argsDat = DM.PatchFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.PatchFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ putStrLn $ "[DEBUG] TC-01 isErr = " ++ show isErr+ putStrLn $ "[DEBUG] TC-01 contents= " ++ show contents+ isErr `shouldBe` False+ stdout `shouldContain` testFile++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-02: patch-file with hunk mismatch (context lines do not match)+ -- -----------------------------------------------------------------------+ context "when patch-file command issued with hunk mismatch patch." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-02: patch-file hunk mismatch."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-patch-file-tc02.txt"++ -- File content intentionally differs from patch context lines+ writeFile testFile "alpha\nbeta\ngamma\n"++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-patch-file-02" }+ -- Patch expects "line1/line2/line3" but file has "alpha/beta/gamma"+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"patch\":\"@@ -1,3 +1,3 @@\\n line1\\n-line2\\n+LINE2\\n line3\\n\"}"+ argsDat = DM.PatchFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.PatchFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-03: patch-file with path outside sandbox+ -- -----------------------------------------------------------------------+ context "when patch-file command issued with path outside sandbox." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-03: patch-file sandbox violation."++ domDat0 <- DM.defaultDomainData+ let domDat = domDat0 { DM._sandboxDirDomainData = Just "C:/sandbox" }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-patch-file-03" }+ -- Path is outside the configured sandbox directory+ argsJson = "{\"path\":\"C:/outside/target.txt\""+ ++ ",\"patch\":\"@@ -1,1 +1,1 @@\\n-old\\n+new\\n\"}"+ argsDat = DM.PatchFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.PatchFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId++ -- -----------------------------------------------------------------------+ -- TC-04: file-info with a valid file+ -- -----------------------------------------------------------------------+ context "when file-info command issued with valid file." $ do+ it "should return line count and byte size" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-04: file-info valid file."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-file-info-tc04.txt"++ BL.writeFile testFile (BL.pack "alpha\nbeta\ngamma")++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-file-info-04" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\"}"+ argsDat = DM.FileInfoFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.FileInfoFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ putStrLn $ "[DEBUG] TC-04 isErr = " ++ show isErr+ putStrLn $ "[DEBUG] TC-04 contents= " ++ show contents+ isErr `shouldBe` False+ stdout `shouldContain` "\"lines\":3"+ stdout `shouldContain` "\"bytes\":16"++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-05: file-info with a missing file+ -- -----------------------------------------------------------------------+ context "when file-info command issued with missing file." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-05: file-info missing file."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-file-info-tc05-missing.txt"++ removeFileSilent testFile++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-file-info-05" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\"}"+ argsDat = DM.FileInfoFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.FileInfoFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId++ -- -----------------------------------------------------------------------+ -- TC-06: file-info with path outside sandbox+ -- -----------------------------------------------------------------------+ context "when file-info command issued with path outside sandbox." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-06: file-info sandbox violation."++ domDat0 <- DM.defaultDomainData+ let domDat = domDat0 { DM._sandboxDirDomainData = Just "C:/sandbox" }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-file-info-06" }+ argsJson = "{\"path\":\"C:/outside/target.txt\"}"+ argsDat = DM.FileInfoFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.FileInfoFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId++ -- -----------------------------------------------------------------------+ -- TC-07: grep-file normal case (single match per line)+ -- -----------------------------------------------------------------------+ context "when grep-file command issued with matching pattern." $ do+ it "should return JSON array with line and cols" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-07: grep-file normal case (single match)."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-grep-file-tc07.txt"++ writeFile testFile "foo bar baz\nalpha beta\nfoo again\n"++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-grep-file-07" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"pattern\":\"foo\"}"+ argsDat = DM.GrepFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.GrepFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ putStrLn $ "[DEBUG] TC-07 isErr = " ++ show isErr+ putStrLn $ "[DEBUG] TC-07 contents= " ++ show contents+ isErr `shouldBe` False+ stdout `shouldContain` "\"line\":1"+ stdout `shouldContain` "\"cols\":[1]"+ stdout `shouldContain` "\"line\":3"++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-08J: grep-file with UTF-8 text+ -- -----------------------------------------------------------------------+ context "when grep-file command issued with Japanese text." $ do+ it "should return UTF-8 text without mojibake" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-08J: grep-file UTF-8 Japanese text."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-grep-file-tc08j.txt"++ BS.writeFile testFile $ TE.encodeUtf8 $ T.pack+ "alpha\n日本語の世界\nこんにちは\n"++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-grep-file-08j" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"pattern\":\"\\u65e5\\u672c\\u8a9e\"}"+ argsDat = DM.GrepFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.GrepFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ putStrLn $ "[DEBUG] TC-08J isErr = " ++ show isErr+ putStrLn $ "[DEBUG] TC-08J contents= " ++ show contents+ isErr `shouldBe` False+ stdout `shouldContain` "\"line\":2"+ stdout `shouldContain` "\"text\":\"日本語の世界\""+ stdout `shouldContain` "\"cols\":[1]"++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-08: grep-file normal case (multiple matches on same line)+ -- -----------------------------------------------------------------------+ context "when grep-file command issued with multiple matches on same line." $ do+ it "should return cols with multiple entries" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-08: grep-file multiple matches per line."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-grep-file-tc08.txt"++ writeFile testFile "foo bar foo baz foo\n"++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-grep-file-08" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"pattern\":\"foo\"}"+ argsDat = DM.GrepFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.GrepFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ putStrLn $ "[DEBUG] TC-08 isErr = " ++ show isErr+ putStrLn $ "[DEBUG] TC-08 contents= " ++ show contents+ isErr `shouldBe` False+ -- cols should contain at least two entries: 1 and 9+ stdout `shouldContain` "1,9"++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-09: grep-file with no match+ -- -----------------------------------------------------------------------+ context "when grep-file command issued with no matching pattern." $ do+ it "should return empty JSON array" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-09: grep-file no match."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-grep-file-tc09.txt"++ writeFile testFile "hello world\nno match here\n"++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-grep-file-09" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"pattern\":\"zzz_no_match_zzz\"}"+ argsDat = DM.GrepFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.GrepFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ isErr `shouldBe` False+ stdout `shouldBe` "[]"++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- TC-10: grep-file with missing file+ -- -----------------------------------------------------------------------+ context "when grep-file command issued with missing file." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-10: grep-file missing file."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-grep-file-tc10-missing.txt"++ removeFileSilent testFile++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-grep-file-10" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"pattern\":\"foo\"}"+ argsDat = DM.GrepFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.GrepFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId++ -- -----------------------------------------------------------------------+ -- TC-11: grep-file with path outside sandbox+ -- -----------------------------------------------------------------------+ context "when grep-file command issued with path outside sandbox." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING TC-11: grep-file sandbox violation."++ domDat0 <- DM.defaultDomainData+ let domDat = domDat0 { DM._sandboxDirDomainData = Just "C:/sandbox" }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-grep-file-11" }+ argsJson = "{\"path\":\"C:/outside/target.txt\""+ ++ ",\"pattern\":\"foo\"}"+ argsDat = DM.GrepFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.GrepFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId++ -- -----------------------------------------------------------------------+ -- CR-04: read-file line slicing helper+ -- -----------------------------------------------------------------------+ context "when slicing lines for read-file partial reads." $ do+ it "should keep all lines when no range is specified" $ \_ -> do+ Core.sliceLines Nothing Nothing ["a", "b", "c"]+ `shouldBe` ["a", "b", "c"]++ it "should read from startLine to the end" $ \_ -> do+ Core.sliceLines (Just 3) Nothing ["a", "b", "c", "d", "e"]+ `shouldBe` ["c", "d", "e"]+ Core.sliceLines (Just 1) Nothing ["a", "b", "c"]+ `shouldBe` ["a", "b", "c"]+ Core.sliceLines (Just 5) Nothing ["a", "b", "c", "d", "e"]+ `shouldBe` ["e"]++ it "should read from the beginning through endLine" $ \_ -> do+ Core.sliceLines Nothing (Just 3) ["a", "b", "c", "d", "e"]+ `shouldBe` ["a", "b", "c"]+ Core.sliceLines Nothing (Just 1) ["a", "b", "c"]+ `shouldBe` ["a"]+ Core.sliceLines Nothing (Just 5) ["a", "b", "c", "d", "e"]+ `shouldBe` ["a", "b", "c", "d", "e"]++ it "should read only the requested inclusive range" $ \_ -> do+ Core.sliceLines (Just 2) (Just 4) ["a", "b", "c", "d", "e"]+ `shouldBe` ["b", "c", "d"]+ Core.sliceLines (Just 3) (Just 3) ["a", "b", "c", "d", "e"]+ `shouldBe` ["c"]+ Core.sliceLines (Just 1) (Just 5) ["a", "b", "c", "d", "e"]+ `shouldBe` ["a", "b", "c", "d", "e"]++ it "should clamp endLine to the actual line count" $ \_ -> do+ Core.sliceLines Nothing (Just 99) ["a", "b", "c"]+ `shouldBe` ["a", "b", "c"]+ Core.sliceLines (Just 2) (Just 99) ["a", "b", "c"]+ `shouldBe` ["b", "c"]++ -- -----------------------------------------------------------------------+ -- CR-04: read-file integration+ -- -----------------------------------------------------------------------+ context "when read-file command issued without a line range." $ do+ it "should return file content without line split/join conversion" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-04: read-file backward compatibility."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-read-file-cr04-full.txt"+ fileBody = "line1\nline2\nline3"++ BL.writeFile testFile (BL.pack fileBody)++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-read-file-cr04-full" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\"}"+ argsDat = DM.ReadFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReadFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ isErr `shouldBe` False+ stdout `shouldBe` (testFile ++ "\n\n" ++ fileBody)++ cancel thId+ removeFileSilent testFile++ context "when read-file command issued with a line range." $ do+ it "should return only the requested inclusive range" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-04: read-file partial range."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-read-file-cr04-range.txt"+ fileBody = unlines+ [ "line1"+ , "line2"+ , "line3"+ , "line4"+ , "line5"+ , "line6"+ ]++ BL.writeFile testFile (BL.pack fileBody)++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-read-file-cr04-range" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"startLine\":3"+ ++ ",\"endLine\":5}"+ argsDat = DM.ReadFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReadFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult+ contents = result^.DM.contentMcpToolsCallResponseResult+ stdout = head contents ^. DM.textMcpToolsCallResponseResultContent++ isErr `shouldBe` False+ stdout `shouldBe` (testFile ++ "\n\nline3\nline4\nline5\n")++ cancel thId+ removeFileSilent testFile++ -- -----------------------------------------------------------------------+ -- CR-05: replace-file+ -- -----------------------------------------------------------------------+ context "when replace-file command issued with one replacement." $ do+ it "should replace matching literal text" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-01: replace-file single replacement."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc01.txt"++ BL.writeFile testFile (BL.pack "foo\n")++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-01" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":[{\"oldText\":\"foo\",\"newText\":\"bar\"}]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ body <- BL.readFile testFile++ isErr `shouldBe` False+ BL.unpack body `shouldBe` "bar\n"++ cancel thId+ removeFileSilent testFile++ context "when replace-file command issued and oldText appears multiple times." $ do+ it "should replace every occurrence" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-02: replace-file all occurrences."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc02.txt"++ BL.writeFile testFile (BL.pack "foo one\nfoo two\nkeep foo\n")++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-02" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":[{\"oldText\":\"foo\",\"newText\":\"bar\"}]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ body <- BL.readFile testFile++ isErr `shouldBe` False+ BL.unpack body `shouldBe` "bar one\nbar two\nkeep bar\n"++ cancel thId+ removeFileSilent testFile++ context "when replace-file command issued with multiple replacements." $ do+ it "should apply replacements in order" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-03: replace-file ordered replacements."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc03.txt"++ BL.writeFile testFile (BL.pack "foo\n")++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-03" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":["+ ++ "{\"oldText\":\"foo\",\"newText\":\"bar\"},"+ ++ "{\"oldText\":\"bar\",\"newText\":\"baz\"}"+ ++ "]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ body <- BL.readFile testFile++ isErr `shouldBe` False+ BL.unpack body `shouldBe` "baz\n"++ cancel thId+ removeFileSilent testFile++ context "when replace-file command cannot find oldText." $ do+ it "should return an error and leave the file unchanged" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-04: replace-file missing oldText."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc04.txt"+ original = "foo\n"++ BL.writeFile testFile (BL.pack original)++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-04" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":["+ ++ "{\"oldText\":\"foo\",\"newText\":\"bar\"},"+ ++ "{\"oldText\":\"missing\",\"newText\":\"x\"}"+ ++ "]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ body <- BL.readFile testFile++ isErr `shouldBe` True+ BL.unpack body `shouldBe` original++ cancel thId+ removeFileSilent testFile++ context "when replace-file command has empty oldText." $ do+ it "should return an error and leave the file unchanged" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-05: replace-file empty oldText."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc05.txt"+ original = "foo\n"++ BL.writeFile testFile (BL.pack original)++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-05" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":[{\"oldText\":\"\",\"newText\":\"x\"}]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ body <- BL.readFile testFile++ isErr `shouldBe` True+ BL.unpack body `shouldBe` original++ cancel thId+ removeFileSilent testFile++ context "when replace-file command has no replacements." $ do+ it "should return an error and leave the file unchanged" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-06: replace-file empty replacements."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc06.txt"+ original = "foo\n"++ BL.writeFile testFile (BL.pack original)++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-06" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":[]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ body <- BL.readFile testFile++ isErr `shouldBe` True+ BL.unpack body `shouldBe` original++ cancel thId+ removeFileSilent testFile++ context "when replace-file command issued with path outside sandbox." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-07: replace-file sandbox violation."++ domDat0 <- DM.defaultDomainData+ let domDat = domDat0 { DM._sandboxDirDomainData = Just "C:/sandbox" }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-07" }+ argsJson = "{\"path\":\"C:/outside/target.txt\""+ ++ ",\"replacements\":[{\"oldText\":\"foo\",\"newText\":\"bar\"}]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True++ cancel thId++ context "when replace-file command issued with missing file." $ do+ it "should return error response" $ \ctx -> do+ putStrLn "[INFO] EXECUTING CR-05 TC-08: replace-file missing file."++ sandboxPath <- makeAbsolute "test/data"+ let domDat = (ctx^.domainDataSpecContext) { DM._sandboxDirDomainData = Just sandboxPath }+ appDat = ctx^.appDataSpecContext+ cmdQ = domDat^.DM.fileSystemQueueDomainData+ resQ = domDat^.DM.responseQueueDomainData+ testFile = sandboxPath </> "test-replace-file-tc08-missing.txt"++ removeFileSilent testFile++ let jsonR = def { DM._jsonrpcJsonRpcRequest = "test-replace-file-08" }+ argsJson = "{\"path\":\"" ++ escapePathForJson testFile ++ "\""+ ++ ",\"replacements\":[{\"oldText\":\"foo\",\"newText\":\"bar\"}]}"+ argsDat = DM.ReplaceFileFileSystemCommandData jsonR+ (DM.RawJsonByteString (BL.pack argsJson))+ args = DM.ReplaceFileFileSystemCommand argsDat++ thId <- async $ SUT.runWithAppData appDat domDat+ STM.atomically $ STM.writeTQueue cmdQ args++ (DM.McpToolsCallResponse dat) <- STM.atomically $ STM.readTQueue resQ++ let result = dat^.DM.resultMcpToolsCallResponseData+ isErr = result^.DM.isErrorMcpToolsCallResponseResult++ isErr `shouldBe` True cancel thId