feat(service): add MCP STDIO transport for AI assistant integration

.gitignore

@@ -61,6 +61,7 @@ IMPLEMENTATION_PLAN.md
 feature-progress.md
 .sisyphus/
 .pipeline/
+docs/architecture/
 
 
 # Node.js / pnpm (website)

.hlint.yaml

@@ -70,6 +70,7 @@
 - ignore: { name: Use lambda case }
 - ignore: { name: Use bimap }
 - ignore: { name: Use uncurry }
+- ignore: { name: Redundant id }
 # Define some custom infix operators
 # - fixity: infixr 3 ~^#^~
 

core/nhcore.cabal

@@ -280,6 +280,10 @@ library
     Service.Transport.Internal
     Service.Transport.Cli
     Service.Transport.Cli.Output
+    Service.Transport.Mcp
+    Service.Transport.Mcp.JsonRpc
+    Service.Transport.Mcp.Protocol
+    Service.Transport.Mcp.Response
     Schema
     Schema.OpenApi
     Schema.JsonSchema
@@ -439,6 +443,10 @@ test-suite nhcore-test
     Service.Transport.CliSpec
     Service.Transport.Cli.OutputSpec
     Service.Transport.InternalSpec
+    Service.Transport.McpSpec
+    Service.Transport.Mcp.JsonRpcSpec
+    Service.Transport.Mcp.ProtocolSpec
+    Service.Transport.Mcp.ResponseSpec
     Service.Transport.WebSpec
     Service.Transport.Web.SwaggerUISpec
     Service.Transport.Web.HealthCheckSpec
@@ -541,6 +549,10 @@ test-suite nhcore-test-service
     Service.Transport.CliSpec
     Service.Transport.Cli.OutputSpec
     Service.Transport.InternalSpec
+    Service.Transport.McpSpec
+    Service.Transport.Mcp.JsonRpcSpec
+    Service.Transport.Mcp.ProtocolSpec
+    Service.Transport.Mcp.ResponseSpec
     Service.Transport.WebSpec
 
   type: exitcode-stdio-1.0

core/service/Service/Transport/Mcp.hs

@@ -0,0 +1,111 @@
+module Service.Transport.Mcp (
+  McpTransport (..),
+) where
+
+import Bytes qualified
+import Core
+import Data.ByteString qualified as GhcByteString
+import Data.ByteString.Char8 qualified as GhcByteStringChar8
+import GHC.TypeLits qualified
+import Json qualified
+import Record qualified
+import Service.Auth (RequestContext)
+import Service.CommandExecutor.TH (deriveKnownHash)
+import Service.Response (CommandResponse)
+import Service.Response qualified as Response
+import Service.Transport (EndpointHandler, Endpoints (..), Transport (..))
+import Service.Transport.Mcp.JsonRpc qualified as JsonRpc
+import Service.Transport.Mcp.Protocol qualified as Protocol
+import System.IO qualified as GhcIO
+import Task qualified
+import Text qualified
+
+
+data McpTransport = McpTransport
+  { serverName :: Text
+  , serverVersion :: Text
+  }
+
+
+type instance NameOf McpTransport = "McpTransport"
+
+
+deriveKnownHash "McpTransport"
+
+
+instance Transport McpTransport where
+  type Request McpTransport = Bytes
+  type Response McpTransport = Bytes
+  type RunnableTransport McpTransport = Task Text Unit
+
+
+  buildHandler ::
+    forall command name.
+    ( Command command,
+      Json.FromJSON command,
+      name ~ NameOf command,
+      Record.KnownSymbol name
+    ) =>
+    McpTransport ->
+    Record.Proxy command ->
+    (RequestContext -> command -> Task Text CommandResponse) ->
+    EndpointHandler
+  buildHandler _transport _ handler requestContext body respond = do
+    let commandName =
+          GHC.TypeLits.symbolVal (Record.Proxy @name)
+            |> Text.fromLinkedList
+    let commandValue = body |> Json.decodeBytes @command
+    case commandValue of
+      Ok cmd -> do
+        response <- handler requestContext cmd
+        let responseJson = Json.encodeText response |> Text.toBytes
+        respond (response, responseJson)
+      Err _err -> do
+        let errorResponse =
+              Response.Failed
+                { error = [fmt|Invalid input for command #{commandName}|]
+                }
+        let responseJson = Json.encodeText errorResponse |> Text.toBytes
+        respond (errorResponse, responseJson)
+
+
+  assembleTransport ::
+    Endpoints McpTransport ->
+    Task Text Unit
+  assembleTransport endpoints = do
+    let mcpTransport = endpoints.transport
+    serverState <- Protocol.newServerState
+      mcpTransport.serverName
+      mcpTransport.serverVersion
+      endpoints.commandEndpoints
+      endpoints.queryEndpoints
+      endpoints.commandSchemas
+      endpoints.querySchemas
+    -- STDIO event loop: read JSON-RPC from stdin, dispatch, write to stdout
+    let loop = do
+          isEof <- Task.fromIO GhcIO.isEOF
+          if isEof
+            then Task.yield unit
+            else do
+              line <- Task.fromIO (GhcByteStringChar8.hGetLine GhcIO.stdin)
+              let request = JsonRpc.parseRequest (Bytes.fromLegacy line)
+              case request of
+                Err errResp -> do
+                  let encoded = JsonRpc.encodeResponse errResp
+                  Task.fromIO (GhcByteString.hPut GhcIO.stdout (Bytes.unwrap encoded))
+                  Task.fromIO (GhcIO.hFlush GhcIO.stdout)
+                  loop
+                Ok req -> do
+                  maybeResp <- Protocol.handleRequest serverState req
+                  case maybeResp of
+                    Nothing -> loop
+                    Just resp -> do
+                      let encoded = JsonRpc.encodeResponse resp
+                      Task.fromIO (GhcByteString.hPut GhcIO.stdout (Bytes.unwrap encoded))
+                      Task.fromIO (GhcIO.hFlush GhcIO.stdout)
+                      loop
+    loop
+
+
+  runTransport :: McpTransport -> Task Text Unit -> Task Text Unit
+  runTransport _transport task = task

core/service/Service/Transport/Mcp/JsonRpc.hs

@@ -0,0 +1,195 @@
+module Service.Transport.Mcp.JsonRpc (
+  -- * Request types
+  JsonRpcRequest (..),
+  parseRequest,
+  -- * Response types
+  JsonRpcResponse (..),
+  successResponse,
+  errorResponse,
+  -- * Error types
+  JsonRpcError (..),
+  -- * Standard error codes
+  parseError,
+  invalidRequest,
+  methodNotFound,
+  invalidParams,
+  internalError,
+  -- * Serialization
+  encodeResponse,
+) where
+
+import Basics
+import Bytes (Bytes)
+import Bytes qualified
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Key qualified as AesonKey
+import Data.Aeson.KeyMap qualified as AesonKeyMap
+import Appendable ((<>))
+import Data.ByteString.Lazy qualified as LazyBytes
+import Json qualified
+import Maybe (Maybe (..))
+import Result (Result (..))
+import Text (Text)
+
+
+-- | A parsed JSON-RPC 2.0 request.
+data JsonRpcRequest = JsonRpcRequest
+  { method :: Text
+  , params :: Maybe Json.Value
+  , id :: Maybe Json.Value
+  }
+  deriving (Show, Eq, Generic)
+
+
+-- | A JSON-RPC 2.0 response.
+data JsonRpcResponse = JsonRpcResponse
+  { jsonrpc :: Text
+  , result :: Maybe Json.Value
+  , error :: Maybe JsonRpcError
+  , id :: Maybe Json.Value
+  }
+  deriving (Show, Eq, Generic)
+
+
+-- | A JSON-RPC 2.0 error object.
+data JsonRpcError = JsonRpcError
+  { code :: {-# UNPACK #-} Int
+  , message :: Text
+  , errorData :: Maybe Json.Value
+  }
+  deriving (Show, Eq, Generic)
+
+
+-- | Parse a raw Bytes line into a JsonRpcRequest.
+parseRequest :: Bytes -> Result JsonRpcResponse JsonRpcRequest
+parseRequest bytes = do
+  let rawBytes = Bytes.unwrap bytes
+  case Aeson.decodeStrict' @Json.Value rawBytes of
+    Nothing ->
+      Err (errorResponse Nothing (parseError "Malformed JSON"))
+    Just (Aeson.Object obj) ->
+      case AesonKeyMap.lookup (AesonKey.fromText "jsonrpc") obj of
+        Nothing ->
+          Err (errorResponse Nothing (invalidRequest "Missing jsonrpc field"))
+        Just (Aeson.String version) ->
+          if version == "2.0"
+            then do
+              let methodVal = AesonKeyMap.lookup (AesonKey.fromText "method") obj
+              case methodVal of
+                Just (Aeson.String m) -> do
+                  let paramsVal = AesonKeyMap.lookup (AesonKey.fromText "params") obj
+                  let idVal = AesonKeyMap.lookup (AesonKey.fromText "id") obj
+                  Ok JsonRpcRequest
+                    { method = m
+                    , params = paramsVal
+                    , id = idVal
+                    }
+                _ ->
+                  Err (errorResponse Nothing (invalidRequest "Missing or invalid method field"))
+            else
+              Err (errorResponse Nothing (invalidRequest "Unsupported jsonrpc version"))
+        _ ->
+          Err (errorResponse Nothing (invalidRequest "Invalid jsonrpc field"))
+    Just _ ->
+      Err (errorResponse Nothing (invalidRequest "Request must be a JSON object"))
+{-# INLINE parseRequest #-}
+
+
+-- | Construct a success response.
+successResponse :: Maybe Json.Value -> Json.Value -> JsonRpcResponse
+successResponse requestId resultValue = JsonRpcResponse
+  { jsonrpc = "2.0"
+  , result = Just resultValue
+  , error = Nothing
+  , id = requestId
+  }
+{-# INLINE successResponse #-}
+
+
+-- | Construct an error response.
+errorResponse :: Maybe Json.Value -> JsonRpcError -> JsonRpcResponse
+errorResponse requestId err = JsonRpcResponse
+  { jsonrpc = "2.0"
+  , result = Nothing
+  , error = Just err
+  , id = requestId
+  }
+{-# INLINE errorResponse #-}
+
+
+-- | -32700: Malformed JSON
+parseError :: Text -> JsonRpcError
+parseError msg = JsonRpcError
+  { code = -32700
+  , message = msg
+  , errorData = Nothing
+  }
+{-# INLINE parseError #-}
+
+
+-- | -32600: Invalid request
+invalidRequest :: Text -> JsonRpcError
+invalidRequest msg = JsonRpcError
+  { code = -32600
+  , message = msg
+  , errorData = Nothing
+  }
+{-# INLINE invalidRequest #-}
+
+
+-- | -32601: Unknown method
+methodNotFound :: Text -> JsonRpcError
+methodNotFound msg = JsonRpcError
+  { code = -32601
+  , message = msg
+  , errorData = Nothing
+  }
+{-# INLINE methodNotFound #-}
+
+
+-- | -32602: Invalid params
+invalidParams :: Text -> JsonRpcError
+invalidParams msg = JsonRpcError
+  { code = -32602
+  , message = msg
+  , errorData = Nothing
+  }
+{-# INLINE invalidParams #-}
+
+
+-- | -32603: Internal server error (generic message, never leaks details)
+internalError :: JsonRpcError
+internalError = JsonRpcError
+  { code = -32603
+  , message = "Internal server error"
+  , errorData = Nothing
+  }
+{-# INLINE internalError #-}
+
+
+-- | Serialize a JsonRpcResponse to Bytes with trailing newline.
+encodeResponse :: JsonRpcResponse -> Bytes
+encodeResponse response = do
+  let obj = AesonKeyMap.fromList
+        [ (AesonKey.fromText "jsonrpc", Aeson.String response.jsonrpc)
+        , (AesonKey.fromText "id", case response.id of { Just v -> v; Nothing -> Aeson.Null })
+        , case response.error of
+            Just err ->
+              let errObj = case err.errorData of
+                    Just d -> Json.object
+                      [ "code" Json..= err.code
+                      , "message" Json..= err.message
+                      , "data" Json..= d
+                      ]
+                    Nothing -> Json.object
+                      [ "code" Json..= err.code
+                      , "message" Json..= err.message
+                      ]
+              in (AesonKey.fromText "error", errObj)
+            Nothing ->
+              (AesonKey.fromText "result", case response.result of { Just v -> v; Nothing -> Aeson.Null })
+        ]
+  let jsonBytes = Aeson.encode (Aeson.Object obj)
+  let withNewline = jsonBytes <> LazyBytes.singleton 0x0A
+  Bytes.fromLazyLegacy withNewline
+{-# INLINE encodeResponse #-}