diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for pms-domain-model +## 0.1.8.0 -- 2026-05-31 + +* Added pms-infra-agent-socket, pms-infra-agent-serial. + ## 0.1.7.0 -- 2026-05-15 * Add file system tools. diff --git a/pms-domain-model.cabal b/pms-domain-model.cabal --- a/pms-domain-model.cabal +++ b/pms-domain-model.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.7.0 +version: 0.1.8.0 -- A short (one-line) description of the package. synopsis: pms-domain-model @@ -85,7 +85,11 @@ stm, async, strip-ansi-escape, - safe-exceptions + safe-exceptions, + base16-bytestring, + regex-tdfa, + iproute, + network -- Directories containing source files. hs-source-dirs: src @@ -126,6 +130,7 @@ async, lens, aeson, + bytestring, pms-domain-model build-tool-depends: diff --git a/src/PMS/Domain/Model/DM/Type.hs b/src/PMS/Domain/Model/DM/Type.hs --- a/src/PMS/Domain/Model/DM/Type.hs +++ b/src/PMS/Domain/Model/DM/Type.hs @@ -1501,6 +1501,294 @@ -------------------------------------------------------------------------------- -- | -- +data AgentSocketEchoCommandData = + AgentSocketEchoCommandData { + _jsonrpcAgentSocketEchoCommandData :: JsonRpcRequest + , _valueAgentSocketEchoCommandData :: String + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketEchoCommandData", omitNothingFields = True} ''AgentSocketEchoCommandData) +makeLenses ''AgentSocketEchoCommandData + +instance Default AgentSocketEchoCommandData where + def = AgentSocketEchoCommandData { + _jsonrpcAgentSocketEchoCommandData = def + , _valueAgentSocketEchoCommandData = def + } + +-- | +-- +data AgentSocketOpenCommandData = + AgentSocketOpenCommandData { + _jsonrpcAgentSocketOpenCommandData :: JsonRpcRequest + , _nameAgentSocketOpenCommandData :: String + , _argumentsAgentSocketOpenCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketOpenCommandData", omitNothingFields = True} ''AgentSocketOpenCommandData) +makeLenses ''AgentSocketOpenCommandData + +instance Default AgentSocketOpenCommandData where + def = AgentSocketOpenCommandData { + _jsonrpcAgentSocketOpenCommandData = def + , _nameAgentSocketOpenCommandData = def + , _argumentsAgentSocketOpenCommandData = def + } + +-- | +-- +data AgentSocketCloseCommandData = + AgentSocketCloseCommandData { + _jsonrpcAgentSocketCloseCommandData :: JsonRpcRequest + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketCloseCommandData", omitNothingFields = True} ''AgentSocketCloseCommandData) +makeLenses ''AgentSocketCloseCommandData + +instance Default AgentSocketCloseCommandData where + def = AgentSocketCloseCommandData { + _jsonrpcAgentSocketCloseCommandData = def + } + +-- | +-- +data AgentSocketReadCommandData = + AgentSocketReadCommandData { + _jsonrpcAgentSocketReadCommandData :: JsonRpcRequest + , _argumentsAgentSocketReadCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketReadCommandData", omitNothingFields = True} ''AgentSocketReadCommandData) +makeLenses ''AgentSocketReadCommandData + +instance Default AgentSocketReadCommandData where + def = AgentSocketReadCommandData { + _jsonrpcAgentSocketReadCommandData = def + , _argumentsAgentSocketReadCommandData = def + } + +-- | +-- +data AgentSocketWriteCommandData = + AgentSocketWriteCommandData { + _jsonrpcAgentSocketWriteCommandData :: JsonRpcRequest + , _argumentsAgentSocketWriteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketWriteCommandData", omitNothingFields = True} ''AgentSocketWriteCommandData) +makeLenses ''AgentSocketWriteCommandData + +instance Default AgentSocketWriteCommandData where + def = AgentSocketWriteCommandData { + _jsonrpcAgentSocketWriteCommandData = def + , _argumentsAgentSocketWriteCommandData = def + } + +-- | +-- +data AgentSocketReadByteCommandData = + AgentSocketReadByteCommandData { + _jsonrpcAgentSocketReadByteCommandData :: JsonRpcRequest + , _argumentsAgentSocketReadByteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketReadByteCommandData", omitNothingFields = True} ''AgentSocketReadByteCommandData) +makeLenses ''AgentSocketReadByteCommandData + +instance Default AgentSocketReadByteCommandData where + def = AgentSocketReadByteCommandData { + _jsonrpcAgentSocketReadByteCommandData = def + , _argumentsAgentSocketReadByteCommandData = def + } + +-- | +-- +data AgentSocketWriteByteCommandData = + AgentSocketWriteByteCommandData { + _jsonrpcAgentSocketWriteByteCommandData :: JsonRpcRequest + , _argumentsAgentSocketWriteByteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSocketWriteByteCommandData", omitNothingFields = True} ''AgentSocketWriteByteCommandData) +makeLenses ''AgentSocketWriteByteCommandData + +instance Default AgentSocketWriteByteCommandData where + def = AgentSocketWriteByteCommandData { + _jsonrpcAgentSocketWriteByteCommandData = def + , _argumentsAgentSocketWriteByteCommandData = def + } + +-- | +-- +data AgentSocketCommand = + AgentSocketEchoCommand AgentSocketEchoCommandData + | AgentSocketOpenCommand AgentSocketOpenCommandData + | AgentSocketCloseCommand AgentSocketCloseCommandData + | AgentSocketReadCommand AgentSocketReadCommandData + | AgentSocketWriteCommand AgentSocketWriteCommandData + | AgentSocketReadByteCommand AgentSocketReadByteCommandData + | AgentSocketWriteByteCommand AgentSocketWriteByteCommandData + deriving (Show, Read, Eq) + +-- | +-- +getJsonRpcAgentSocketCommand :: AgentSocketCommand -> JsonRpcRequest +getJsonRpcAgentSocketCommand (AgentSocketEchoCommand d) = d^.jsonrpcAgentSocketEchoCommandData +getJsonRpcAgentSocketCommand (AgentSocketOpenCommand d) = d^.jsonrpcAgentSocketOpenCommandData +getJsonRpcAgentSocketCommand (AgentSocketCloseCommand d) = d^.jsonrpcAgentSocketCloseCommandData +getJsonRpcAgentSocketCommand (AgentSocketReadCommand d) = d^.jsonrpcAgentSocketReadCommandData +getJsonRpcAgentSocketCommand (AgentSocketWriteCommand d) = d^.jsonrpcAgentSocketWriteCommandData +getJsonRpcAgentSocketCommand (AgentSocketReadByteCommand d) = d^.jsonrpcAgentSocketReadByteCommandData +getJsonRpcAgentSocketCommand (AgentSocketWriteByteCommand d) = d^.jsonrpcAgentSocketWriteByteCommandData + + +-------------------------------------------------------------------------------- +-- | +-- +data AgentSerialEchoCommandData = + AgentSerialEchoCommandData { + _jsonrpcAgentSerialEchoCommandData :: JsonRpcRequest + , _valueAgentSerialEchoCommandData :: String + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialEchoCommandData", omitNothingFields = True} ''AgentSerialEchoCommandData) +makeLenses ''AgentSerialEchoCommandData + +instance Default AgentSerialEchoCommandData where + def = AgentSerialEchoCommandData { + _jsonrpcAgentSerialEchoCommandData = def + , _valueAgentSerialEchoCommandData = def + } + +-- | +-- +data AgentSerialOpenCommandData = + AgentSerialOpenCommandData { + _jsonrpcAgentSerialOpenCommandData :: JsonRpcRequest + , _nameAgentSerialOpenCommandData :: String + , _argumentsAgentSerialOpenCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialOpenCommandData", omitNothingFields = True} ''AgentSerialOpenCommandData) +makeLenses ''AgentSerialOpenCommandData + +instance Default AgentSerialOpenCommandData where + def = AgentSerialOpenCommandData { + _jsonrpcAgentSerialOpenCommandData = def + , _nameAgentSerialOpenCommandData = def + , _argumentsAgentSerialOpenCommandData = def + } + +-- | +-- +data AgentSerialCloseCommandData = + AgentSerialCloseCommandData { + _jsonrpcAgentSerialCloseCommandData :: JsonRpcRequest + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialCloseCommandData", omitNothingFields = True} ''AgentSerialCloseCommandData) +makeLenses ''AgentSerialCloseCommandData + +instance Default AgentSerialCloseCommandData where + def = AgentSerialCloseCommandData { + _jsonrpcAgentSerialCloseCommandData = def + } + +-- | +-- +data AgentSerialReadCommandData = + AgentSerialReadCommandData { + _jsonrpcAgentSerialReadCommandData :: JsonRpcRequest + , _argumentsAgentSerialReadCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialReadCommandData", omitNothingFields = True} ''AgentSerialReadCommandData) +makeLenses ''AgentSerialReadCommandData + +instance Default AgentSerialReadCommandData where + def = AgentSerialReadCommandData { + _jsonrpcAgentSerialReadCommandData = def + , _argumentsAgentSerialReadCommandData = def + } + +-- | +-- +data AgentSerialWriteCommandData = + AgentSerialWriteCommandData { + _jsonrpcAgentSerialWriteCommandData :: JsonRpcRequest + , _argumentsAgentSerialWriteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialWriteCommandData", omitNothingFields = True} ''AgentSerialWriteCommandData) +makeLenses ''AgentSerialWriteCommandData + +instance Default AgentSerialWriteCommandData where + def = AgentSerialWriteCommandData { + _jsonrpcAgentSerialWriteCommandData = def + , _argumentsAgentSerialWriteCommandData = def + } + +-- | +-- +data AgentSerialReadByteCommandData = + AgentSerialReadByteCommandData { + _jsonrpcAgentSerialReadByteCommandData :: JsonRpcRequest + , _argumentsAgentSerialReadByteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialReadByteCommandData", omitNothingFields = True} ''AgentSerialReadByteCommandData) +makeLenses ''AgentSerialReadByteCommandData + +instance Default AgentSerialReadByteCommandData where + def = AgentSerialReadByteCommandData { + _jsonrpcAgentSerialReadByteCommandData = def + , _argumentsAgentSerialReadByteCommandData = def + } + +-- | +-- +data AgentSerialWriteByteCommandData = + AgentSerialWriteByteCommandData { + _jsonrpcAgentSerialWriteByteCommandData :: JsonRpcRequest + , _argumentsAgentSerialWriteByteCommandData :: RawJsonByteString + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions {fieldLabelModifier = dropDataName "AgentSerialWriteByteCommandData", omitNothingFields = True} ''AgentSerialWriteByteCommandData) +makeLenses ''AgentSerialWriteByteCommandData + +instance Default AgentSerialWriteByteCommandData where + def = AgentSerialWriteByteCommandData { + _jsonrpcAgentSerialWriteByteCommandData = def + , _argumentsAgentSerialWriteByteCommandData = def + } + +-- | +-- +data AgentSerialCommand = + AgentSerialEchoCommand AgentSerialEchoCommandData + | AgentSerialOpenCommand AgentSerialOpenCommandData + | AgentSerialCloseCommand AgentSerialCloseCommandData + | AgentSerialReadCommand AgentSerialReadCommandData + | AgentSerialWriteCommand AgentSerialWriteCommandData + | AgentSerialReadByteCommand AgentSerialReadByteCommandData + | AgentSerialWriteByteCommand AgentSerialWriteByteCommandData + deriving (Show, Read, Eq) + +-- | +-- +getJsonRpcAgentSerialCommand :: AgentSerialCommand -> JsonRpcRequest +getJsonRpcAgentSerialCommand (AgentSerialEchoCommand d) = d^.jsonrpcAgentSerialEchoCommandData +getJsonRpcAgentSerialCommand (AgentSerialOpenCommand d) = d^.jsonrpcAgentSerialOpenCommandData +getJsonRpcAgentSerialCommand (AgentSerialCloseCommand d) = d^.jsonrpcAgentSerialCloseCommandData +getJsonRpcAgentSerialCommand (AgentSerialReadCommand d) = d^.jsonrpcAgentSerialReadCommandData +getJsonRpcAgentSerialCommand (AgentSerialWriteCommand d) = d^.jsonrpcAgentSerialWriteCommandData +getJsonRpcAgentSerialCommand (AgentSerialReadByteCommand d) = d^.jsonrpcAgentSerialReadByteCommandData +getJsonRpcAgentSerialCommand (AgentSerialWriteByteCommand d) = d^.jsonrpcAgentSerialWriteByteCommandData + + +-------------------------------------------------------------------------------- +-- | +-- data SocketEchoCommandData = SocketEchoCommandData { _jsonrpcSocketEchoCommandData :: JsonRpcRequest @@ -1700,12 +1988,16 @@ , _watchQueueDomainData :: TQueue WatchCommand , _procspawnQueueDomainData :: TQueue ProcSpawnCommand , _agentProcessQueueDomainData :: TQueue AgentProcessCommand + , _agentSocketQueueDomainData :: TQueue AgentSocketCommand + , _agentSerialQueueDomainData :: TQueue AgentSerialCommand , _socketQueueDomainData :: TQueue SocketCommand , _serialQueueDomainData :: TQueue SerialCommand , _promptsDomainData :: [String] , _invalidCharsDomainData :: [String] , _invalidCmdsDomainData :: [String] , _allowedAgentCmdsDomainData :: [String] -- ^ whitelist for agent-proc-run; empty means deny all + , _sandboxNetworksDomainData :: [String] -- ^ CIDR list for agent-socket-open; empty = deny all + , _invalidPatternsDomainData :: [String] -- ^ regex blacklist for write commands; empty = allow all , _timeoutMicrosecDomainData :: Int } @@ -1731,6 +2023,8 @@ watchQ <- newTQueueIO procQ <- newTQueueIO agentProcQ <- newTQueueIO + agentSocketQ <- newTQueueIO + agentSerialQ <- newTQueueIO socketQ <- newTQueueIO serialQ <- newTQueueIO return DomainData { @@ -1749,12 +2043,16 @@ , _watchQueueDomainData = watchQ , _procspawnQueueDomainData = procQ , _agentProcessQueueDomainData = agentProcQ + , _agentSocketQueueDomainData = agentSocketQ + , _agentSerialQueueDomainData = agentSerialQ , _socketQueueDomainData = socketQ , _serialQueueDomainData = serialQ , _promptsDomainData = def , _invalidCharsDomainData = def , _invalidCmdsDomainData = def , _allowedAgentCmdsDomainData = def -- deny all by default + , _sandboxNetworksDomainData = def -- deny all by default + , _invalidPatternsDomainData = def -- allow all by default , _timeoutMicrosecDomainData = 30 * 1000 * 1000 } diff --git a/src/PMS/Domain/Model/DS/Utility.hs b/src/PMS/Domain/Model/DS/Utility.hs --- a/src/PMS/Domain/Model/DS/Utility.hs +++ b/src/PMS/Domain/Model/DS/Utility.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} module PMS.Domain.Model.DS.Utility where @@ -22,6 +21,14 @@ import qualified Control.Concurrent.STM as STM import System.IO import Data.List +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Base16 as B16 +import System.Exit (ExitCode(..)) +import Text.Regex.TDFA ((=~)) +import Data.IP (AddrRange, IPv4, IP(..), isMatchedTo, fromSockAddr) +import Network.Socket (getAddrInfo, defaultHints, addrAddress, HostName, SockAddr) +import Data.Maybe (mapMaybe) +import Text.Read (readMaybe) import PMS.Domain.Model.DM.Type import PMS.Domain.Model.DM.Constant @@ -227,3 +234,122 @@ hdlExcept acc e = do let accText = TE.decodeUtf8With TEE.lenientDecode acc E.throwString $ show e ++ "\nAccumulated input so far:\n" ++ T.unpack accText + + +-------------------------------------------------------------------------------- +-- CR-11: Handle I/O common utilities +-------------------------------------------------------------------------------- + +-- | Read from a Handle with a timeout. tout is in milliseconds. +-- Returns an empty ByteString on timeout (not an error). +-- Consolidates readProc (agent-process) and readSocket (agent-socket) patterns. +readHandle :: Handle -> Int -> Int -> IO BSS.ByteString +readHandle hdl tout size = do + ready <- hWaitForInput hdl tout + if ready + then BSS.hGetSome hdl size + else return BSS.empty + +-- | Write a ByteString to a Handle and flush. +writeHandle :: Handle -> BSS.ByteString -> IO () +writeHandle hdl bs = do + BSS.hPut hdl bs + hFlush hdl + +-- | Convert a ByteString to an uppercase hex string (e.g. "000A1BFF"). +bytesToHex :: BSS.ByteString -> String +bytesToHex = map toUpper . BS.unpack . B16.encode + +-- | Encode a String to a UTF-8 encoded ByteString. +str2bsUTF8 :: String -> BSS.ByteString +str2bsUTF8 = TE.encodeUtf8 . T.pack + +-- | Decode a ByteString to a String using UTF-8 lenient decoding (no ANSI strip). +-- For raw socket or binary data. +bs2strUTF8 :: BSS.ByteString -> String +bs2strUTF8 = T.unpack . TE.decodeUtf8With TEE.lenientDecode + +-- | Decode a ByteString to a String using UTF-8 lenient decoding and strip ANSI escapes. +-- For process output (pty / pipe output). +bs2strUTF8Strip :: BSS.ByteString -> String +bs2strUTF8Strip = T.unpack . ANSI.stripAnsiEscapeCodes . TE.decodeUtf8With TEE.lenientDecode + +-- | Write a McpResponse to the TQueue. +-- Consolidated here because it depends only on domain-model types. +toolsCallResponse :: STM.TQueue McpResponse + -> JsonRpcRequest + -> ExitCode + -> String + -> String + -> IO () +toolsCallResponse resQ jsonRpc code outStr errStr = do + let content = [ McpToolsCallResponseResultContent "text" outStr + , McpToolsCallResponseResultContent "text" errStr + ] + result = McpToolsCallResponseResult { + _contentMcpToolsCallResponseResult = content + , _isErrorMcpToolsCallResponseResult = (ExitSuccess /= code) + } + resDat = McpToolsCallResponseData jsonRpc result + res = McpToolsCallResponse resDat + STM.atomically $ STM.writeTQueue resQ res + + +-- | Append a newline character ('\n') to the string. +-- Simple unconditional append; no escape expansion, no duplicate check. +-- Called only when appendNewline is True (or omitted = default True). +-- write-byte variants (binary) must NOT use this function. +appendCRLF :: String -> String +appendCRLF str = str ++ lineEnding + where + lineEnding :: String + lineEnding = case nativeNewline of + CRLF -> _CRLF + LF -> _LF + +-------------------------------------------------------------------------------- +-- CR-12: Security check functions +-------------------------------------------------------------------------------- + +-- | Check input against a list of regex patterns (invalidPatterns). +-- Returns the first matching pattern as Just, or Nothing if no match (allow). +-- An empty pattern list means allow all. +checkInvalidPatterns :: [String] -> String -> Maybe String +checkInvalidPatterns patterns input = + find (\pat -> (input =~ pat) :: Bool) patterns + +-- | Check a hostname against a list of CIDR ranges (sandboxNetworks). +-- Returns Right () if the resolved IP matches any range, Left error otherwise. +-- An empty CIDR list means deny all hosts. +-- Unix Domain Socket connections should NOT call this function. +checkSandboxNetworks :: [String] -> HostName -> IO (Either String ()) +checkSandboxNetworks [] host = + return . Left $ + "agent-socket-open: connection refused. host " ++ host + ++ " is outside sandboxNetworks (sandboxNetworks is empty; all hosts denied)." +checkSandboxNetworks cidrs host = do + let ranges = mapMaybe readMaybe cidrs :: [AddrRange IPv4] + addrs <- getAddrInfo (Just defaultHints) (Just host) Nothing + -- Case B: classify each resolved address; IPv6 is explicitly rejected. + let classified = map (classifyAddr . addrAddress) addrs + case sequence classified of + Left errMsg -> return (Left errMsg) + Right ipv4s -> + if any (\ip -> any (ip `isMatchedTo`) ranges) ipv4s + then return (Right ()) + else return . Left $ + "agent-socket-open: connection refused. host " ++ host + ++ " is outside sandboxNetworks (allowed: " ++ show cidrs ++ ")." + +-- | Classify a SockAddr as IPv4 (Right) or unsupported (Left error message). +-- IPv6 addresses are explicitly rejected with a descriptive error (Case B). +-- Non-IP addresses should never reach this function (Unix Domain Socket is exempt). +classifyAddr :: SockAddr -> Either String IPv4 +classifyAddr sa = case fromSockAddr sa of + Just (IPv4 v4, _) -> Right v4 + Just (IPv6 v6, _) -> Left $ + "agent-socket-open: IPv6 is not supported in sandboxNetworks. " + ++ "resolved address: " ++ show v6 + ++ " (use an IPv4 host or IPv4 CIDR ranges)." + _ -> Left + "agent-socket-open: unsupported address type returned by DNS resolution." diff --git a/test/PMS/Domain/Model/DS/UtilitySpec.hs b/test/PMS/Domain/Model/DS/UtilitySpec.hs --- a/test/PMS/Domain/Model/DS/UtilitySpec.hs +++ b/test/PMS/Domain/Model/DS/UtilitySpec.hs @@ -1,18 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultilineStrings #-} module PMS.Domain.Model.DS.UtilitySpec (spec) where import Test.Hspec import Control.Lens import Data.Aeson - +import System.Exit (ExitCode(..)) +import System.IO +import qualified Control.Concurrent.STM as STM +import qualified Data.ByteString as BS import qualified PMS.Domain.Model.DS.Utility as SUT import qualified PMS.Domain.Model.DM.Type as SUT - - --- | -- data SpecContext = SpecContext {} @@ -74,5 +73,146 @@ actual `shouldBe` expect + -- CR-11: Handle I/O common utility tests + describe "bytesToHex" $ do + -- TC-DM-04 + context "bytes [0x00, 0x0A, 0x1B, 0xFF]" $ do + it "should return '000A1BFF'" $ \_ -> do + let input = BS.pack [0x00, 0x0A, 0x1B, 0xFF] + actual = SUT.bytesToHex input + actual `shouldBe` "000A1BFF" + + describe "str2bsUTF8" $ do + -- TC-DM-05 + context "hello" $ do + it "should encode to UTF-8 ByteString" $ \_ -> do + let actual = SUT.str2bsUTF8 "hello" + actual `shouldBe` BS.pack [0x68, 0x65, 0x6C, 0x6C, 0x6F] + + describe "bs2strUTF8" $ do + -- TC-DM-06: no ANSI stripping + context "UTF-8 ByteString without ANSI" $ do + it "should decode to String" $ \_ -> do + let input = BS.pack [0x68, 0x65, 0x6C, 0x6C, 0x6F] + actual = SUT.bs2strUTF8 input + actual `shouldBe` "hello" + context "UTF-8 ByteString with ANSI escape" $ do + it "should decode without stripping ANSI" $ \_ -> do + -- ESC[31m = red color escape sequence + let input = BS.pack [0x1B, 0x5B, 0x33, 0x31, 0x6D, 0x68, 0x69] + actual = SUT.bs2strUTF8 input + actual `shouldBe` "\ESC[31mhi" + + describe "bs2strUTF8Strip" $ do + -- TC-DM-07: ANSI stripped + context "UTF-8 ByteString with ANSI escape" $ do + it "should decode and strip ANSI sequences" $ \_ -> do + let input = BS.pack [0x1B, 0x5B, 0x33, 0x31, 0x6D, 0x68, 0x69] + actual = SUT.bs2strUTF8Strip input + actual `shouldBe` "hi" + + describe "toolsCallResponse" $ do + -- TC-DM-08 + context "ExitSuccess" $ do + it "should write McpToolsCallResponse with isError=False to TQueue" $ \_ -> do + let jsonRpc = SUT.JsonRpcRequest + { SUT._jsonrpcJsonRpcRequest = "2.0" + , SUT._idJsonRpcRequest = Just 1 + , SUT._methodJsonRpcRequest = "tools/call" + , SUT._paramsJsonRpcRequest = Nothing + } + resQ <- STM.newTQueueIO + SUT.toolsCallResponse resQ jsonRpc ExitSuccess "out" "err" + res <- STM.atomically $ STM.readTQueue resQ + case res of + SUT.McpToolsCallResponse dat -> + SUT._isErrorMcpToolsCallResponseResult + (SUT._resultMcpToolsCallResponseData dat) `shouldBe` False + _ -> expectationFailure "unexpected McpResponse variant" + -- TC-DM-09 + context "ExitFailure" $ do + it "should write McpToolsCallResponse with isError=True to TQueue" $ \_ -> do + let jsonRpc = SUT.JsonRpcRequest + { SUT._jsonrpcJsonRpcRequest = "2.0" + , SUT._idJsonRpcRequest = Just 1 + , SUT._methodJsonRpcRequest = "tools/call" + , SUT._paramsJsonRpcRequest = Nothing + } + resQ <- STM.newTQueueIO + SUT.toolsCallResponse resQ jsonRpc (ExitFailure 1) "" "error" + res <- STM.atomically $ STM.readTQueue resQ + case res of + SUT.McpToolsCallResponse dat -> + SUT._isErrorMcpToolsCallResponseResult + (SUT._resultMcpToolsCallResponseData dat) `shouldBe` True + _ -> expectationFailure "unexpected McpResponse variant" + + + + -- CR-12: Security check function tests + + describe "checkInvalidPatterns" $ do + + -- TC-DM-10: match exists -> Just pattern + context "TC-DM-10: input matches a literal pattern" $ do + it "should return Just the matched pattern" $ \_ -> do + let patterns = ["rm", "shutdown"] + input = "rm -rf /" + actual = SUT.checkInvalidPatterns patterns input + actual `shouldBe` Just "rm" + + -- TC-DM-11: no match -> Nothing + context "TC-DM-11: input does not match any pattern" $ do + it "should return Nothing" $ \_ -> do + let patterns = ["rm", "shutdown"] + input = "echo hello" + actual = SUT.checkInvalidPatterns patterns input + actual `shouldBe` Nothing + + -- TC-DM-12: empty pattern list -> Nothing (allow all) + context "TC-DM-12: empty pattern list" $ do + it "should return Nothing (allow all)" $ \_ -> do + let patterns = [] :: [String] + input = "rm -rf /" + actual = SUT.checkInvalidPatterns patterns input + actual `shouldBe` Nothing + + -- TC-DM-13: regex pattern ".*ssh.*" matches + context "TC-DM-13: regex pattern '.*ssh.*' matches ssh command" $ do + it "should return Just \".*ssh.*\"" $ \_ -> do + let patterns = [".*ssh.*"] + input = "ssh user@host" + actual = SUT.checkInvalidPatterns patterns input + actual `shouldBe` Just ".*ssh.*" + + describe "checkSandboxNetworks" $ do + + -- TC-DM-14: empty CIDR list -> Left (deny all) + context "TC-DM-14: empty CIDR list" $ do + it "should return Left (deny all hosts)" $ \_ -> do + result <- SUT.checkSandboxNetworks [] "127.0.0.1" + case result of + Left msg -> msg `shouldContain` "sandboxNetworks is empty" + Right () -> expectationFailure "Expected Left but got Right" + + -- TC-DM-15: host IP within range -> Right () + context "TC-DM-15: loopback IP within 127.0.0.0/8" $ do + it "should return Right ()" $ \_ -> do + result <- SUT.checkSandboxNetworks ["127.0.0.0/8"] "127.0.0.1" + result `shouldBe` Right () + + -- TC-DM-16: host IP outside all ranges -> Left + context "TC-DM-16: IP outside all CIDR ranges" $ do + it "should return Left with error message containing 'outside sandboxNetworks'" $ \_ -> do + result <- SUT.checkSandboxNetworks ["10.0.0.0/8"] "127.0.0.1" + case result of + Left msg -> msg `shouldContain` "outside sandboxNetworks" + Right () -> expectationFailure "Expected Left but got Right" + + -- TC-DM-17: multiple CIDRs, IP matches one -> Right () + context "TC-DM-17: IP matches second of multiple CIDR ranges" $ do + it "should return Right ()" $ \_ -> do + result <- SUT.checkSandboxNetworks ["10.0.0.0/8", "127.0.0.0/8"] "127.0.0.1" + result `shouldBe` Right ()