diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/pms-infra-filesystem.cabal b/pms-infra-filesystem.cabal --- a/pms-infra-filesystem.cabal +++ b/pms-infra-filesystem.cabal @@ -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 diff --git a/src/PMS/Infra/FileSystem/DM/Type.hs b/src/PMS/Infra/FileSystem/DM/Type.hs --- a/src/PMS/Infra/FileSystem/DM/Type.hs +++ b/src/PMS/Infra/FileSystem/DM/Type.hs @@ -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 + } diff --git a/src/PMS/Infra/FileSystem/DS/Core.hs b/src/PMS/Infra/FileSystem/DS/Core.hs --- a/src/PMS/Infra/FileSystem/DS/Core.hs +++ b/src/PMS/Infra/FileSystem/DS/Core.hs @@ -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) diff --git a/test/PMS/Infra/FileSystem/App/ControlSpec.hs b/test/PMS/Infra/FileSystem/App/ControlSpec.hs --- a/test/PMS/Infra/FileSystem/App/ControlSpec.hs +++ b/test/PMS/Infra/FileSystem/App/ControlSpec.hs @@ -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