diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,7 +19,7 @@ - Registry introduction: [REGISTRY.md](https://github.com/axisvela/praxo-core/blob/main/language/haskell/REGISTRY.md) - Machine-readable entry: [llms.txt](https://github.com/axisvela/praxo-core/blob/main/language/haskell/llms.txt) and [llms.md](https://github.com/axisvela/praxo-core/blob/main/language/haskell/llms.md) - Coding-agent contract: [docs/getting-started/coding-agents.md](https://github.com/axisvela/praxo-core/blob/main/docs/getting-started/coding-agents.md) -- Registry: [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) +- Registry: [Hackage](https://hackage.haskell.org/package/praxo-core-0.3.0) ## Build and Test diff --git a/REGISTRY.md b/REGISTRY.md --- a/REGISTRY.md +++ b/REGISTRY.md @@ -1,7 +1,7 @@ # PRAXO-CORE Haskell Registry Introduction -**Status:** source release; Hackage upload pending. Source version `0.3.0`, source -tag `haskell/v0.3.0`. Published registry version: `0.2.0`. Registry +**Status:** published. Source version `0.4.0`, source +tag `haskell/v0.4.0`. Published registry version: `0.3.0`. Registry pages are release snapshots; verify the published version before relying on a feature. @@ -14,12 +14,12 @@ | Field | Value | | --- | --- | | Package | `praxo-core` | -| Registry | [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) | -| Source version | `0.3.0` | -| Published registry version | `0.2.0` | +| Registry | [Hackage](https://hackage.haskell.org/package/praxo-core-0.3.0) | +| Source version | `0.4.0` | +| Published registry version | `0.3.0` | | Install (published) | `cabal install praxo-core` | | Install (source/release prepared) | `cabal install praxo-core` | -| Source tag | `haskell/v0.3.0` | +| Source tag | `haskell/v0.4.0` | | Tier | Core | | Contract | `SPEC_VERSION` `0.2.0` | | Documentation | https://axisvela.github.io/praxo-core/languages/haskell/ | diff --git a/api/0.1.0.txt b/api/0.1.0.txt --- a/api/0.1.0.txt +++ b/api/0.1.0.txt @@ -1,4 +1,4 @@ -# PRAXO-CORE Haskell Wire API 0.3.0 +# PRAXO-CORE Haskell Wire API 0.4.0 # SPEC_VERSION 0.2.0 ## Praxo.Agent @@ -47,6 +47,14 @@ ## Praxo.JsonSchema data ValidationError = ValidationError { errorPath :: String, errorMessage :: String } deriving (Eq, Show) validateSchema :: Json -> Json -> Either String [ValidationError] + +## Praxo.Mcp +data McpClient = McpClient +newtype McpTransport = McpTransport (String -> Json -> IO (Either AgentError Json)) +mcpCallTool :: McpClient -> String -> Json -> IO (Either AgentError Json) +mcpClient :: McpTransport -> String -> String -> IO (Either AgentError McpClient) +mcpClose :: McpClient -> IO () +mcpListTools :: McpClient -> IO (Either AgentError [Json]) ## Praxo.Middleware data CallLimit = CallLimit diff --git a/llms.md b/llms.md --- a/llms.md +++ b/llms.md @@ -7,12 +7,12 @@ ## Package - package: `praxo-core` -- registry: [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) -- source_version: `0.3.0` -- published_version: `0.2.0` +- registry: [Hackage](https://hackage.haskell.org/package/praxo-core-0.3.0) +- source_version: `0.4.0` +- published_version: `0.3.0` - install_published: `cabal install praxo-core` - install_source: `cabal install praxo-core` -- source_tag: `haskell/v0.3.0` +- source_tag: `haskell/v0.4.0` - tier: Core - contract: `SPEC_VERSION` `0.2.0` - documentation: https://axisvela.github.io/praxo-core/languages/haskell/ diff --git a/llms.txt b/llms.txt --- a/llms.txt +++ b/llms.txt @@ -7,12 +7,12 @@ # Package - package: `praxo-core` -- registry: [Hackage (pending)](https://github.com/axisvela/praxo-core/releases/tag/haskell%2Fv0.2.0) -- source_version: `0.3.0` -- published_version: `0.2.0` +- registry: [Hackage](https://hackage.haskell.org/package/praxo-core-0.3.0) +- source_version: `0.4.0` +- published_version: `0.3.0` - install_published: `cabal install praxo-core` - install_source: `cabal install praxo-core` -- source_tag: `haskell/v0.3.0` +- source_tag: `haskell/v0.4.0` - tier: Core - contract: `SPEC_VERSION` `0.2.0` - documentation: https://axisvela.github.io/praxo-core/languages/haskell/ diff --git a/praxo-core.cabal b/praxo-core.cabal --- a/praxo-core.cabal +++ b/praxo-core.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: praxo-core -version: 0.3.0 +version: 0.4.0 synopsis: Embeddable MIT-licensed agent framework for Haskell description: Native agent loop with tools, policy hooks, typed events, memory, checkpoints, context budgets, middleware, JSON Schema validation, @@ -22,7 +22,7 @@ library hs-source-dirs: src - exposed-modules: Praxo.Agent, Praxo.Json, Praxo.ToolCall, Praxo.JsonSchema, Praxo.Pattern, Praxo.Plugin, Praxo.Runtime, Praxo.Middleware, Praxo.Wire, Praxo.OpenAICompatible, Praxo.Anthropic, Praxo.Gemini, Praxo.Harmovela + exposed-modules: Praxo.Agent, Praxo.Json, Praxo.ToolCall, Praxo.JsonSchema, Praxo.Pattern, Praxo.Plugin, Praxo.Runtime, Praxo.Middleware, Praxo.Wire, Praxo.OpenAICompatible, Praxo.Anthropic, Praxo.Gemini, Praxo.Harmovela, Praxo.Mcp build-depends: base >=4.14 && <5, containers >=0.6 && <0.9 default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Praxo/Mcp.hs b/src/Praxo/Mcp.hs new file mode 100644 --- /dev/null +++ b/src/Praxo/Mcp.hs @@ -0,0 +1,104 @@ +module Praxo.Mcp (McpTransport(..), McpClient(..), mcpClient, mcpListTools, mcpCallTool, mcpClose) where + +import Data.IORef +import Praxo.Agent (AgentError(..)) +import Praxo.Json + +newtype McpTransport = McpTransport (String -> Json -> IO (Either AgentError Json)) + +data McpClient = McpClient + { mcpTransport :: McpTransport + , mcpClientVersion :: String + , mcpProtocolVersion :: String + , mcpServerInfo :: Json + , mcpClosed :: IORef Bool + } + +mcpClient :: McpTransport -> String -> String -> IO (Either AgentError McpClient) +mcpClient transport clientVersion protocolVersion = do + let version = if null clientVersion then "0.4.0" else clientVersion + protocol = if null protocolVersion then "2024-11-05" else protocolVersion + params = JObject + [ ("protocolVersion", JString protocol) + , ("capabilities", JObject []) + , ("clientInfo", JObject + [ ("name", JString "praxo-core") + , ("version", JString version) + ]) + ] + result <- invoke transport "initialize" params + case result of + Left err -> pure (Left err) + Right value -> case value of + JObject _ -> + let negotiated = asString (field "protocolVersion" value) + in if null negotiated + then pure (Left (AgentError "MCP_HANDSHAKE" "mcp: initialize returned no protocol version")) + else do + closed <- newIORef False + let info = case field "serverInfo" value of + JObject _ -> field "serverInfo" value + _ -> JObject [] + pure (Right (McpClient transport version negotiated info closed)) + _ -> pure (Left (AgentError "MCP_PROTOCOL" "mcp: initialize result must be an object")) + +mcpListTools :: McpClient -> IO (Either AgentError [Json]) +mcpListTools client = loop "" [] [] [] + where + loop cursor tools names cursors = do + let params = if null cursor then JObject [] else JObject [("cursor", JString cursor)] + result <- invoke (mcpTransport client) "tools/list" params + case result of + Left err -> pure (Left err) + Right value -> case field "tools" value of + JArray items -> case collect items tools names of + Left err -> pure (Left err) + Right (updatedTools, updatedNames) -> + case field "nextCursor" value of + JNull -> pure (Right updatedTools) + JString next + | null next -> pure (Right updatedTools) + | next `elem` cursors -> pure (Left (AgentError "MCP_PAGINATION" "mcp: repeated tool pagination cursor")) + | otherwise -> loop next updatedTools updatedNames (next : cursors) + _ -> pure (Left (AgentError "MCP_PROTOCOL" "mcp: nextCursor must be a string")) + _ -> pure (Left (AgentError "MCP_PROTOCOL" "mcp: tools/list tools must be an array")) + collect [] tools names = Right (tools, names) + collect (item:rest) tools names = case item of + JObject _ -> + let name = asString (field "name" item) + in if null name + then Left (AgentError "MCP_PROTOCOL" "mcp: tool name is required") + else if name `elem` names + then Left (AgentError "MCP_DUPLICATE_TOOL" ("mcp: duplicate tool " ++ name)) + else collect rest (tools ++ [item]) (name : names) + _ -> Left (AgentError "MCP_PROTOCOL" "mcp: tool definition must be an object") + +mcpCallTool :: McpClient -> String -> Json -> IO (Either AgentError Json) +mcpCallTool client name arguments + | null name = pure (Left (AgentError "MCP_PROTOCOL" "mcp: tool name is required")) + | otherwise = do + result <- invoke (mcpTransport client) "tools/call" + (JObject [("name", JString name), ("arguments", arguments)]) + case result of + Left err -> pure (Left err) + Right value -> case value of + JObject _ -> + if field "isError" value == JBool True + then pure (Left (AgentError "MCP_TOOL_ERROR" ("mcp: tool " ++ name ++ " failed"))) + else case lookup "structuredContent" (asObject value) of + Just structured -> pure (Right structured) + Nothing -> pure (Right (textContent (field "content" value))) + _ -> pure (Left (AgentError "MCP_PROTOCOL" "mcp: tools/call result must be an object")) + where + textContent (JArray items) = + case [asString (field "text" item) | item <- items, asString (field "type" item) == "text"] of + [] -> JNull + [text] -> JString text + texts -> JArray (map JString texts) + textContent _ = JNull + +mcpClose :: McpClient -> IO () +mcpClose client = writeIORef (mcpClosed client) True + +invoke :: McpTransport -> String -> Json -> IO (Either AgentError Json) +invoke (McpTransport send) = send diff --git a/src/Praxo/Wire.hs b/src/Praxo/Wire.hs --- a/src/Praxo/Wire.hs +++ b/src/Praxo/Wire.hs @@ -4,4 +4,4 @@ specVersion = "0.2.0" sdkVersion :: String -sdkVersion = "0.3.0" +sdkVersion = "0.4.0" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,6 +13,7 @@ import qualified Praxo.Anthropic as An import qualified Praxo.Gemini as G import qualified Praxo.Harmovela as H +import qualified Praxo.Mcp as M import Praxo.Pattern import Praxo.Plugin import Praxo.Runtime @@ -27,7 +28,8 @@ adapterTests providerTests harmovelaTests - assert "contract version" (specVersion == "0.2.0" && sdkVersion == "0.3.0") + mcpTests + assert "contract version" (specVersion == "0.2.0" && sdkVersion == "0.4.0") forM_ ["", "01", "1.", "+1", "NaN", "1e", "[1,]", "{\"a\":1,}", "{}{}", "\"\\q\"", "\"\\ud800\"", "\"\\udc00\"", "\"\\ud800\\u0041\"", "\"line\nbreak\"", "true garbage"] $ \raw -> assert ("invalid JSON " ++ show raw) (isLeft (parseJson raw)) assert "unicode escape" (parseJson "\"\\u00e9\\ud83d\\ude00\"" == Right (JString "\x00e9\x1f600")) @@ -387,6 +389,69 @@ let missing = H.newHarmovelaSink "" (H.HarmovelaTransport (\_ -> fail "harmovela transport called for missing base URL")) (pure 1) missingResult <- H.emitHarmovelaEvent missing event assert "harmovela missing base url" (case missingResult of Left err -> A.errorCode err == "HARMOVELA_URL"; _ -> False) + +mcpTests :: IO () +mcpTests = do + let transport = M.McpTransport (\method params -> case method of + "initialize" -> pure (Right (json "{\"protocolVersion\":\"2024-11-05\",\"serverInfo\":{\"name\":\"fake\"}}")) + "tools/list" -> case field "cursor" params of + JString "c1" -> pure (Right (json "{\"tools\":[{\"name\":\"two\"}]}")) + _ -> pure (Right (json "{\"tools\":[{\"name\":\"echo\",\"inputSchema\":{\"type\":\"object\"}}],\"nextCursor\":\"c1\"}")) + "tools/call" -> pure (Right (json "{\"content\":[{\"type\":\"text\",\"text\":\"ok\"}]}")) + _ -> pure (Right (JObject []))) + clientResult <- M.mcpClient transport "" "" + case clientResult of + Left err -> fail (A.errorMessage err) + Right client -> do + assert "mcp default client version" (M.mcpClientVersion client == "0.4.0") + assert "mcp negotiated protocol" (M.mcpProtocolVersion client == "2024-11-05") + tools <- M.mcpListTools client + case tools of + Left err -> fail (A.errorMessage err) + Right items -> do + assert "mcp pagination count" (length items == 2) + assert "mcp tool order" (map (asString . field "name") items == ["echo", "two"]) + value <- M.mcpCallTool client "echo" (JObject []) + assert "mcp text call" (value == Right (JString "ok")) + M.mcpClose client + closed <- readIORef (M.mcpClosed client) + assert "mcp closed" closed + let duplicateTransport = M.McpTransport (\method _ -> case method of + "initialize" -> pure (Right (json "{\"protocolVersion\":\"2024-11-05\"}")) + "tools/list" -> pure (Right (json "{\"tools\":[{\"name\":\"echo\"},{\"name\":\"echo\"}]}")) + _ -> pure (Right (JObject []))) + duplicateResult <- M.mcpClient duplicateTransport "" "" + case duplicateResult of + Left err -> fail (A.errorMessage err) + Right duplicateClient -> do + duplicateTools <- M.mcpListTools duplicateClient + assert "mcp duplicate tool error" (case duplicateTools of + Left err -> A.errorCode err == "MCP_DUPLICATE_TOOL" + Right _ -> False) + let cursorTransport = M.McpTransport (\method _ -> case method of + "initialize" -> pure (Right (json "{\"protocolVersion\":\"2024-11-05\"}")) + "tools/list" -> pure (Right (json "{\"tools\":[],\"nextCursor\":\"c1\"}")) + _ -> pure (Right (JObject []))) + cursorResult <- M.mcpClient cursorTransport "" "" + case cursorResult of + Left err -> fail (A.errorMessage err) + Right cursorClient -> do + paginated <- M.mcpListTools cursorClient + assert "mcp repeated cursor error" (case paginated of + Left err -> A.errorCode err == "MCP_PAGINATION" + Right _ -> False) + let failingTransport = M.McpTransport (\method _ -> case method of + "initialize" -> pure (Right (json "{\"protocolVersion\":\"2024-11-05\"}")) + "tools/call" -> pure (Right (json "{\"isError\":true}")) + _ -> pure (Right (JObject []))) + failingResult <- M.mcpClient failingTransport "" "" + case failingResult of + Left err -> fail (A.errorMessage err) + Right failingClient -> do + called <- M.mcpCallTool failingClient "echo" (JObject []) + assert "mcp tool error" (case called of + Left err -> A.errorCode err == "MCP_TOOL_ERROR" + Right _ -> False) assert :: String -> Bool -> IO () assert label condition = unless condition (fail label)