commit 59eca69ee009541568d2c249b8724904601f0758 · anil.recoil.org/ocaml-mcp

+7 -28

bin/capitalize_sdk.ml

···

       14
        
       let server = create_server 

     

       15
        
         ~name:"OCaml MCP Capitalizer" 

     

       16
        
         ~version:"0.1.0" 

     

       17
       -
         ~protocol_version:"2024-11-05" 

     

       18
       -
         ()

     

       19
       -
       

     

       20
       -
       (* Define startup and shutdown hooks *)

     

       21
       -
       let startup () =

     

       22
       -
         Printf.printf "CapitalizeServer is starting up!\n";

     

       23
       -
         flush stdout;

     

       24
       -
         Log.info "CapitalizeServer is starting up!"

     

       25
       -
       

     

       26
       -
       let shutdown () =

     

       27
       -
         Printf.printf "CapitalizeServer is shutting down. Goodbye!\n";

     

       28
       -
         flush stdout;

     

       29
       -
         Log.info "CapitalizeServer is shutting down. Goodbye!"

     

       30
       -
       

     

       31
       -
       (* Register the hooks *)

     

       32
       -
       let () =

     

       33
       -
         set_startup_hook server startup;

     

       34
       -
         set_shutdown_hook server shutdown

     

       35
        
       

     

       36
        
       (* Define and register a capitalize tool *)

     

       37
        
       let _ = add_tool server

     
···

       103
        
           ]

     

       104
        
         )

     

       105
        
       

     

       106
       -
       (* Main function *)

     

       107
        
       let () =

     

       108
       -
         (* Print directly to ensure we see output *)

     

       109
       -
         Printf.printf "Starting CapitalizeServer...\n";

     

       110
       -
         flush stdout;

     

       111
       -
         

     

       112
       -
         (* Configure the server with appropriate capabilities *)

     

       113
       -
         ignore (configure_server server ());

     

       114
       -
         

     

       115
       -
         (* Run the server *)

     

       116
       -
         run_server server

···

       14
        
       let server = create_server 

     

       15
        
         ~name:"OCaml MCP Capitalizer" 

     

       16
        
         ~version:"0.1.0" 

     

       17
       +
         ~protocol_version:"2024-11-05" () |>

     

       18
       +
         fun server ->

     

       19
       +
         (* Set default capabilities *)

     

       20
       +
           configure_server server ~with_tools:true ~with_resources:true ~with_prompts:true ()

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       21
        
       

     

       22
        
       (* Define and register a capitalize tool *)

     

       23
        
       let _ = add_tool server

     
···

       89
        
           ]

     

       90
        
         )

     

       91
        
       

     

       0
        
       
     

       92
        
       let () =

     

       93
       +
         (* Run the server with the default scheduler *)

     

       94
       +
         Eio_main.run @@ fun env->

     

       95
       +
           Mcp_server.run_server env server

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

+1 -5

bin/dune

···

       1
       -
       (executable

     

       2
       -
        (name server)

     

       3
       -
        (libraries mcp yojson unix))

     

       4
       -
       

     

       5
        
       (executable

     

       6
        
        (name capitalize_sdk)

     

       7
        
        (modules capitalize_sdk)

     

       8
       -
        (libraries mcp mcp_sdk yojson unix))

···

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       1
        
       (executable

     

       2
        
        (name capitalize_sdk)

     

       3
        
        (modules capitalize_sdk)

     

       4
       +
        (libraries mcp mcp_server yojson eio_main eio))

-365

bin/server.ml

···

       1
       -
       open Mcp

     

       2
       -
       open Jsonrpc

     

       3
       -
       

     

       4
       -
       (* Logging utilities *)

     

       5
       -
       let log_debug msg =

     

       6
       -
         Printf.eprintf "[DEBUG] %s\n" msg;

     

       7
       -
         flush stderr

     

       8
       -
       

     

       9
       -
       let log_error msg =

     

       10
       -
         Printf.eprintf "[ERROR] %s\n" msg;

     

       11
       -
         flush stderr

     

       12
       -
       

     

       13
       -
       (* Server state *)

     

       14
       -
       let protocol_version = "2024-11-05"

     

       15
       -
       let server_info = Implementation.{ name = "ocaml-mcp-capitalizer"; version = "0.1.0" }

     

       16
       -
       let server_capabilities = `Assoc [

     

       17
       -
         (* We support tools *)

     

       18
       -
         ("tools", `Assoc [

     

       19
       -
           ("listChanged", `Bool true)

     

       20
       -
         ]);

     

       21
       -
         (* We don't support resources - make this explicit *)

     

       22
       -
         ("resources", `Assoc [

     

       23
       -
           ("listChanged", `Bool false);

     

       24
       -
           ("subscribe", `Bool false)

     

       25
       -
         ]);

     

       26
       -
         (* We don't support prompts - make this explicit *)

     

       27
       -
         ("prompts", `Assoc [

     

       28
       -
           ("listChanged", `Bool false)

     

       29
       -
         ])

     

       30
       -
       ]

     

       31
       -
       

     

       32
       -
       (* Tool implementation *)

     

       33
       -
       module CapitalizeTool = struct

     

       34
       -
         let name = "capitalize"

     

       35
       -
         let description = "Capitalizes the provided text"

     

       36
       -
         let input_schema = `Assoc [

     

       37
       -
           ("type", `String "object");

     

       38
       -
           ("properties", `Assoc [

     

       39
       -
             ("text", `Assoc [

     

       40
       -
               ("type", `String "string");

     

       41
       -
               ("description", `String "The text to capitalize")

     

       42
       -
             ])

     

       43
       -
           ]);

     

       44
       -
           ("required", `List [`String "text"])

     

       45
       -
         ]

     

       46
       -
       

     

       47
       -
         let call json =

     

       48
       -
           match json with

     

       49
       -
           | `Assoc fields ->

     

       50
       -
             (match List.assoc_opt "text" fields with

     

       51
       -
              | Some (`String text) ->

     

       52
       -
                let capitalized_text = String.uppercase_ascii text in

     

       53
       -
                let content = TextContent.{ 

     

       54
       -
                  text = capitalized_text;

     

       55
       -
                  annotations = None 

     

       56
       -
                } in

     

       57
       -
                `Assoc [

     

       58
       -
                  ("content", `List [TextContent.yojson_of_t content]);

     

       59
       -
                  ("isError", `Bool false)

     

       60
       -
                ]

     

       61
       -
              | _ -> 

     

       62
       -
                let error_content = TextContent.{

     

       63
       -
                  text = "Missing or invalid 'text' parameter";

     

       64
       -
                  annotations = None

     

       65
       -
                } in

     

       66
       -
                `Assoc [

     

       67
       -
                  ("content", `List [TextContent.yojson_of_t error_content]);

     

       68
       -
                  ("isError", `Bool true)

     

       69
       -
                ])

     

       70
       -
           | _ ->

     

       71
       -
             let error_content = TextContent.{

     

       72
       -
               text = "Invalid arguments format";

     

       73
       -
               annotations = None

     

       74
       -
             } in

     

       75
       -
             `Assoc [

     

       76
       -
               ("content", `List [TextContent.yojson_of_t error_content]);

     

       77
       -
               ("isError", `Bool true)

     

       78
       -
             ]

     

       79
       -
       end

     

       80
       -
       

     

       81
       -
       (* Handle tool listing *)

     

       82
       -
       let list_tools () =

     

       83
       -
         let tool = `Assoc [

     

       84
       -
           ("name", `String CapitalizeTool.name);

     

       85
       -
           ("description", `String CapitalizeTool.description);

     

       86
       -
           ("inputSchema", CapitalizeTool.input_schema)

     

       87
       -
         ] in

     

       88
       -
         `Assoc [

     

       89
       -
           ("tools", `List [tool])

     

       90
       -
         ]

     

       91
       -
       

     

       92
       -
       (* Handle tool calls *)

     

       93
       -
       let call_tool name args =

     

       94
       -
         if name = CapitalizeTool.name then

     

       95
       -
           CapitalizeTool.call args

     

       96
       -
         else

     

       97
       -
           let error_content = TextContent.{

     

       98
       -
             text = Printf.sprintf "Unknown tool: %s" name;

     

       99
       -
             annotations = None

     

       100
       -
           } in

     

       101
       -
           `Assoc [

     

       102
       -
             ("content", `List [TextContent.yojson_of_t error_content]);

     

       103
       -
             ("isError", `Bool true)

     

       104
       -
           ]

     

       105
       -
       

     

       106
       -
       (* Handle initialization *)

     

       107
       -
       let handle_initialize id json =

     

       108
       -
         try

     

       109
       -
           log_debug (Printf.sprintf "Processing initialize request with id: %s" 

     

       110
       -
             (match id with 

     

       111
       -
              | `Int i -> string_of_int i 

     

       112
       -
              | `String s -> s));

     

       113
       -
           

     

       114
       -
           log_debug (Printf.sprintf "Initialize params: %s" 

     

       115
       -
             (match json with 

     

       116
       -
              | Some j -> Yojson.Safe.to_string j 

     

       117
       -
              | None -> "null"));

     

       118
       -
           

     

       119
       -
           let _ = match json with

     

       120
       -
             | Some params -> 

     

       121
       -
                 log_debug "Parsing initialize request params...";

     

       122
       -
                 let req = Initialize.Request.t_of_yojson params in

     

       123
       -
                 log_debug (Printf.sprintf "Client info: %s v%s" req.client_info.name req.client_info.version);

     

       124
       -
                 log_debug (Printf.sprintf "Client protocol version: %s" req.protocol_version);

     

       125
       -
                 

     

       126
       -
                 (* Check protocol version compatibility *)

     

       127
       -
                 if req.protocol_version <> protocol_version then

     

       128
       -
                   log_debug (Printf.sprintf "Protocol version mismatch: client=%s server=%s - will use server version" 

     

       129
       -
                     req.protocol_version protocol_version);

     

       130
       -
                 

     

       131
       -
                 req

     

       132
       -
             | None -> 

     

       133
       -
                 log_error "Missing params for initialize request";

     

       134
       -
                 raise (Json.Of_json ("Missing params for initialize request", `Null))

     

       135
       -
           in

     

       136
       -
           

     

       137
       -
           log_debug "Creating initialize response...";

     

       138
       -
           let result = Initialize.Result.create

     

       139
       -
             ~capabilities:server_capabilities

     

       140
       -
             ~server_info

     

       141
       -
             ~protocol_version

     

       142
       -
             ~instructions:"This server provides a tool to capitalize text."

     

       143
       -
             ()

     

       144
       -
           in

     

       145
       -
           

     

       146
       -
           log_debug "Serializing initialize response...";

     

       147
       -
           let response = create_response ~id ~result:(Initialize.Result.yojson_of_t result) in

     

       148
       -
           log_debug "Initialize response created successfully";

     

       149
       -
           response

     

       150
       -
         with

     

       151
       -
         | Json.Of_json (msg, _) ->

     

       152
       -
           log_error (Printf.sprintf "JSON error in initialize: %s" msg);

     

       153
       -
           create_error ~id ~code:(-32602) ~message:("Invalid params: " ^ msg) ()

     

       154
       -
         | exc ->

     

       155
       -
           log_error (Printf.sprintf "Exception in initialize: %s" (Printexc.to_string exc));

     

       156
       -
           log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));

     

       157
       -
           create_error ~id ~code:(-32603) ~message:("Internal error: " ^ (Printexc.to_string exc)) ()

     

       158
       -
       

     

       159
       -
       (* Handle tools/list *)

     

       160
       -
       let handle_list_tools id =

     

       161
       -
         log_debug "Processing tools/list request";

     

       162
       -
         let result = list_tools () in

     

       163
       -
         log_debug (Printf.sprintf "Tools list result: %s" (Yojson.Safe.to_string result));

     

       164
       -
         create_response ~id ~result

     

       165
       -
       

     

       166
       -
       (* Handle tools/call *)

     

       167
       -
       let handle_call_tool id json =

     

       168
       -
         try

     

       169
       -
           log_debug (Printf.sprintf "Processing tool call request with id: %s" 

     

       170
       -
             (match id with 

     

       171
       -
              | `Int i -> string_of_int i 

     

       172
       -
              | `String s -> s));

     

       173
       -
           

     

       174
       -
           log_debug (Printf.sprintf "Tool call params: %s" 

     

       175
       -
             (match json with 

     

       176
       -
              | Some j -> Yojson.Safe.to_string j 

     

       177
       -
              | None -> "null"));

     

       178
       -
           

     

       179
       -
           match json with

     

       180
       -
           | Some (`Assoc params) ->

     

       181
       -
             let name = match List.assoc_opt "name" params with

     

       182
       -
               | Some (`String name) -> 

     

       183
       -
                   log_debug (Printf.sprintf "Tool name: %s" name);

     

       184
       -
                   name

     

       185
       -
               | _ -> 

     

       186
       -
                   log_error "Missing or invalid 'name' parameter in tool call";

     

       187
       -
                   raise (Json.Of_json ("Missing or invalid 'name' parameter", `Assoc params))

     

       188
       -
             in

     

       189
       -
             let args = match List.assoc_opt "arguments" params with

     

       190
       -
               | Some (args) -> 

     

       191
       -
                   log_debug (Printf.sprintf "Tool arguments: %s" (Yojson.Safe.to_string args));

     

       192
       -
                   args

     

       193
       -
               | _ -> 

     

       194
       -
                   log_debug "No arguments provided for tool call, using empty object";

     

       195
       -
                   `Assoc [] (* Empty arguments is valid *)

     

       196
       -
             in

     

       197
       -
             log_debug (Printf.sprintf "Calling tool: %s" name);

     

       198
       -
             let result = call_tool name args in

     

       199
       -
             log_debug (Printf.sprintf "Tool call result: %s" (Yojson.Safe.to_string result));

     

       200
       -
             create_response ~id ~result

     

       201
       -
           | _ ->

     

       202
       -
             log_error "Invalid params format for tools/call";

     

       203
       -
             create_error ~id ~code:(-32602) ~message:"Invalid params for tools/call" ()

     

       204
       -
         with

     

       205
       -
         | Json.Of_json (msg, _) ->

     

       206
       -
           log_error (Printf.sprintf "JSON error in tool call: %s" msg);

     

       207
       -
           create_error ~id ~code:(-32602) ~message:("Invalid params: " ^ msg) ()

     

       208
       -
         | exc ->

     

       209
       -
           log_error (Printf.sprintf "Exception in tool call: %s" (Printexc.to_string exc));

     

       210
       -
           log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));

     

       211
       -
           create_error ~id ~code:(-32603) ~message:("Internal error: " ^ (Printexc.to_string exc)) ()

     

       212
       -
       

     

       213
       -
       (* Handle ping *)

     

       214
       -
       let handle_ping id =

     

       215
       -
         create_response ~id ~result:(`Assoc [])

     

       216
       -
       

     

       217
       -
       (* Process a single message *)

     

       218
       -
       let process_message message =

     

       219
       -
         try

     

       220
       -
           log_debug "Parsing message as JSONRPC message...";

     

       221
       -
           match JSONRPCMessage.t_of_yojson message with

     

       222
       -
           | JSONRPCMessage.Request req ->

     

       223
       -
             log_debug (Printf.sprintf "Received request with method: %s" req.method_);

     

       224
       -
             (match req.method_ with

     

       225
       -
              | "initialize" -> 

     

       226
       -
                log_debug "Processing initialize request";

     

       227
       -
                Some (handle_initialize req.id req.params)

     

       228
       -
              | "tools/list" -> 

     

       229
       -
                log_debug "Processing tools/list request";

     

       230
       -
                Some (handle_list_tools req.id)

     

       231
       -
              | "tools/call" -> 

     

       232
       -
                log_debug "Processing tools/call request";

     

       233
       -
                Some (handle_call_tool req.id req.params)

     

       234
       -
              | "ping" -> 

     

       235
       -
                log_debug "Processing ping request";

     

       236
       -
                Some (handle_ping req.id)

     

       237
       -
              | _ -> 

     

       238
       -
                log_error (Printf.sprintf "Unknown method received: %s" req.method_);

     

       239
       -
                Some (create_error ~id:req.id ~code:(-32601) ~message:("Method not found: " ^ req.method_) ()))

     

       240
       -
           | JSONRPCMessage.Notification notif ->

     

       241
       -
             log_debug (Printf.sprintf "Received notification with method: %s" notif.method_);

     

       242
       -
             (match notif.method_ with

     

       243
       -
              | "notifications/initialized" ->

     

       244
       -
                log_debug "Client initialization complete - Server is now ready to receive requests";

     

       245
       -
                log_debug (Printf.sprintf "Notification params: %s" 

     

       246
       -
                  (match notif.params with

     

       247
       -
                   | Some p -> Yojson.Safe.to_string p

     

       248
       -
                   | None -> "null"));

     

       249
       -
                None

     

       250
       -
              | _ ->

     

       251
       -
                log_debug (Printf.sprintf "Ignoring notification: %s" notif.method_);

     

       252
       -
                None)

     

       253
       -
           | JSONRPCMessage.Response _ ->

     

       254
       -
             log_error "Unexpected response message received";

     

       255
       -
             None

     

       256
       -
           | JSONRPCMessage.Error _ ->

     

       257
       -
             log_error "Unexpected error message received";

     

       258
       -
             None

     

       259
       -
         with

     

       260
       -
         | exc ->

     

       261
       -
           log_error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));

     

       262
       -
           log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));

     

       263
       -
           log_error (Printf.sprintf "Message was: %s" (Yojson.Safe.to_string message));

     

       264
       -
           None

     

       265
       -
       

     

       266
       -
       (* Main loop *)

     

       267
       -
       let rec read_message () =

     

       268
       -
         try

     

       269
       -
           log_debug "Attempting to read line from stdin...";

     

       270
       -
           let line = read_line () in

     

       271
       -
           if line = "" then (

     

       272
       -
             log_debug "Empty line received, ignoring";

     

       273
       -
             None

     

       274
       -
           ) else (

     

       275
       -
             log_debug (Printf.sprintf "Raw input: %s" line);

     

       276
       -
             try

     

       277
       -
               let json = Yojson.Safe.from_string line in

     

       278
       -
               log_debug "Successfully parsed JSON";

     

       279
       -
               Some json

     

       280
       -
             with

     

       281
       -
             | Yojson.Json_error msg -> 

     

       282
       -
               log_error (Printf.sprintf "Error parsing JSON: %s" msg);

     

       283
       -
               log_error (Printf.sprintf "Input was: %s" line);

     

       284
       -
               read_message ()

     

       285
       -
           )

     

       286
       -
         with

     

       287
       -
         | End_of_file -> 

     

       288
       -
           log_debug "End of file received on stdin";

     

       289
       -
           None

     

       290
       -
         | Sys_error msg -> 

     

       291
       -
           log_error (Printf.sprintf "System error while reading: %s" msg);

     

       292
       -
           None

     

       293
       -
         | exc ->

     

       294
       -
           log_error (Printf.sprintf "Exception while reading: %s" (Printexc.to_string exc));

     

       295
       -
           None

     

       296
       -
       

     

       297
       -
       let () =

     

       298
       -
         try

     

       299
       -
           (* Enable exception backtraces *)

     

       300
       -
           Printexc.record_backtrace true;

     

       301
       -
           

     

       302
       -
           (* Enable line buffering for stdout *)

     

       303
       -
           set_binary_mode_out stdout false;

     

       304
       -
           

     

       305
       -
           log_debug "MCP Capitalizer server started";

     

       306
       -
           log_debug (Printf.sprintf "Protocol version: %s" protocol_version);

     

       307
       -
           log_debug (Printf.sprintf "Server info: %s v%s" server_info.name server_info.version);

     

       308
       -
           

     

       309
       -
           (* Print environment info for debugging *)

     

       310
       -
           log_debug "Environment variables:";

     

       311
       -
           Unix.environment()

     

       312
       -
           |> Array.iter (fun s -> 

     

       313
       -
             try

     

       314
       -
               let i = String.index s '=' in

     

       315
       -
               let name = String.sub s 0 i in

     

       316
       -
               if String.length name > 0 then

     

       317
       -
                 log_debug (Printf.sprintf "  %s" s)

     

       318
       -
             with Not_found -> ()

     

       319
       -
           );

     

       320
       -
           

     

       321
       -
           let rec server_loop count =

     

       322
       -
             log_debug (Printf.sprintf "Waiting for message #%d..." count);

     

       323
       -
             match read_message () with

     

       324
       -
             | Some json ->

     

       325
       -
               log_debug (Printf.sprintf "Received message: %s" (Yojson.Safe.to_string json));

     

       326
       -
               (match process_message json with

     

       327
       -
                | Some response ->

     

       328
       -
                  let response_json = JSONRPCMessage.yojson_of_t response in

     

       329
       -
                  let response_str = Yojson.Safe.to_string response_json in

     

       330
       -
                  log_debug (Printf.sprintf "Sending response: %s" response_str);

     

       331
       -
                  (* Make sure we emit properly formatted JSON on a single line with a newline at the end *)

     

       332
       -
                  Printf.printf "%s\n" response_str;

     

       333
       -
                  flush stdout;

     

       334
       -
                  (* Give the client a moment to process the response *)

     

       335
       -
                  Unix.sleepf 0.01;

     

       336
       -
                  server_loop (count + 1)

     

       337
       -
                | None -> 

     

       338
       -
                  log_debug "No response needed for this message";

     

       339
       -
                  server_loop (count + 1))

     

       340
       -
             | None -> 

     

       341
       -
               log_debug "End of input stream, terminating server";

     

       342
       -
               ()

     

       343
       -
           in

     

       344
       -
           

     

       345
       -
           log_debug "Starting server loop...";

     

       346
       -
           log_debug "Waiting for the initialize request...";

     

       347
       -
           

     

       348
       -
           (* Set up signal handler to gracefully exit *)

     

       349
       -
           Sys.(set_signal sigint (Signal_handle (fun _ -> 

     

       350
       -
             log_debug "Received interrupt signal, exiting...";

     

       351
       -
             exit 0

     

       352
       -
           )));

     

       353
       -
           

     

       354
       -
           server_loop 1;

     

       355
       -
           log_debug "Server terminated normally";

     

       356
       -
         with

     

       357
       -
         | End_of_file ->

     

       358
       -
           log_error "Unexpected end of file";

     

       359
       -
         | Sys_error msg ->

     

       360
       -
           log_error (Printf.sprintf "System error: %s" msg);

     

       361
       -
         | Unix.Unix_error(err, func, arg) ->

     

       362
       -
           log_error (Printf.sprintf "Unix error in %s(%s): %s" func arg (Unix.error_message err));

     

       363
       -
         | exc ->

     

       364
       -
           log_error (Printf.sprintf "Unhandled exception: %s" (Printexc.to_string exc));

     

       365
       -
           log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()))

-5

bin/server.mli

···

       1
       -
       val process_message : Jsonrpc.Json.t -> Mcp.JSONRPCMessage.t option

     

       2
       -
       val handle_initialize : Jsonrpc.Id.t -> Jsonrpc.Json.t option -> Mcp.JSONRPCMessage.t

     

       3
       -
       val handle_list_tools : Jsonrpc.Id.t -> Mcp.JSONRPCMessage.t

     

       4
       -
       val handle_call_tool : Jsonrpc.Id.t -> Jsonrpc.Json.t option -> Mcp.JSONRPCMessage.t

     

       5
       -
       val handle_ping : Jsonrpc.Id.t -> Mcp.JSONRPCMessage.t

lib/dune

···

       8
        
         (libraries mcp jsonrpc unix yojson)

     

       9
        
         (modules mcp_sdk)

     

       10
        
         (flags (:standard -w -67 -w -27 -w -32)))

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

···

       8
        
         (libraries mcp jsonrpc unix yojson)

     

       9
        
         (modules mcp_sdk)

     

       10
        
         (flags (:standard -w -67 -w -27 -w -32)))

     

       11
       +
       

     

       12
       +
       (library

     

       13
       +
         (name mcp_server)

     

       14
       +
         (libraries mcp_sdk jsonrpc eio_main eio)

     

       15
       +
         (modules mcp_server)

     

       16
       +
       )

+10 -37

lib/mcp_sdk.ml

···

       16
        
       

     

       17
        
         let log level msg =

     

       18
        
           Printf.eprintf "[%s] %s\n" (string_of_level level) msg;

     

       19
       -
           flush stderr;

     

       20
       -
           Printf.printf "[%s] %s\n" (string_of_level level) msg;

     

       21
       -
           flush stdout

     

       22
        
       

     

       23
        
         let debug = log Debug

     

       24
        
         let info = log Info

     
···

       190
        
         name: string;

     

       191
        
         version: string;

     

       192
        
         protocol_version: string;

     

       0
        
       
     

       193
        
         mutable capabilities: Json.t;

     

       194
        
         mutable tools: Tool.t list;

     

       195
        
         mutable resources: Resource.t list;

     

       196
        
         mutable prompts: Prompt.t list;

     

       197
       -
         mutable lifespan_context: (string * Json.t) list;

     

       198
       -
         mutable startup_hook: (unit -> unit) option;

     

       199
       -
         mutable shutdown_hook: (unit -> unit) option;

     

       200
       -
       }

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       201
        
       

     

       202
        
       (* Create a new server *)

     

       203
        
       let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =

     
···

       210
        
           resources = [];

     

       211
        
           prompts = [];

     

       212
        
           lifespan_context = [];

     

       213
       -
           startup_hook = None;

     

       214
       -
           shutdown_hook = None;

     

       215
        
         }

     

       216
        
       

     

       217
        
       (* Default capabilities for the server *)

     
···

       344
        
         let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in

     

       345
        
         set_capabilities server capabilities;

     

       346
        
         server

     

       347
       -
       

     

       348
       -
       (* Set startup and shutdown hooks *)

     

       349
       -
       let set_startup_hook server hook =

     

       350
       -
         server.startup_hook <- Some hook

     

       351
       -
       

     

       352
       -
       let set_shutdown_hook server hook =

     

       353
       -
         server.shutdown_hook <- Some hook

     

       354
       -
       

     

       355
       -
       (* Run the server *)

     

       356
       -
       let run_server server =

     

       357
       -
         (* Setup *)

     

       358
       -
         Printexc.record_backtrace true;

     

       359
       -
         set_binary_mode_out stdout false;

     

       360
       -
         

     

       361
       -
         Log.info (Printf.sprintf "%s server started" server.name);

     

       362
       -
         Log.debug (Printf.sprintf "Protocol version: %s" server.protocol_version);

     

       363
       -
         Log.debug (Printf.sprintf "Server info: %s v%s" server.name server.version);

     

       364
       -
         

     

       365
       -
         (* Initialize capabilities if not already set *)

     

       366
       -
         if server.capabilities = `Assoc [] then

     

       367
       -
           ignore (configure_server server ());

     

       368
       -
         

     

       369
       -
         (* Run startup hook if provided *)

     

       370
       -
         (match server.startup_hook with

     

       371
       -
          | Some hook -> hook ()

     

       372
       -
          | None -> ());

     

       373
       -
         

     

       374
       -
         Log.info "Server initialized and ready."

···

       16
        
       

     

       17
        
         let log level msg =

     

       18
        
           Printf.eprintf "[%s] %s\n" (string_of_level level) msg;

     

       19
       +
           flush stderr

     

       0
        
       
     

       0
        
       
     

       20
        
       

     

       21
        
         let debug = log Debug

     

       22
        
         let info = log Info

     
···

       188
        
         name: string;

     

       189
        
         version: string;

     

       190
        
         protocol_version: string;

     

       191
       +
         lifespan_context: (string * Json.t) list;

     

       192
        
         mutable capabilities: Json.t;

     

       193
        
         mutable tools: Tool.t list;

     

       194
        
         mutable resources: Resource.t list;

     

       195
        
         mutable prompts: Prompt.t list;

     

       196
       +
       } 

     

       197
       +
       

     

       198
       +
       let name { name; _ } = name

     

       199
       +
       let version { version; _ } = version

     

       200
       +
       let capabilities { capabilities; _ } = capabilities

     

       201
       +
       let lifespan_context { lifespan_context; _ } = lifespan_context

     

       202
       +
       let protocol_version { protocol_version; _ } = protocol_version

     

       203
       +
       let tools { tools; _ } = tools

     

       204
        
       

     

       205
        
       (* Create a new server *)

     

       206
        
       let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =

     
···

       213
        
           resources = [];

     

       214
        
           prompts = [];

     

       215
        
           lifespan_context = [];

     

       0
        
       
     

       0
        
       
     

       216
        
         }

     

       217
        
       

     

       218
        
       (* Default capabilities for the server *)

     
···

       345
        
         let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in

     

       346
        
         set_capabilities server capabilities;

     

       347
        
         server

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

+7 -21

lib/mcp_sdk.mli

···

       90
        
       end

     

       91
        
       

     

       92
        
       (** Main server type *)

     

       93
       -
       type server = {

     

       94
       -
         name: string;

     

       95
       -
         version: string;

     

       96
       -
         protocol_version: string;

     

       97
       -
         mutable capabilities: Json.t;

     

       98
       -
         mutable tools: Tool.t list;

     

       99
       -
         mutable resources: Resource.t list;

     

       100
       -
         mutable prompts: Prompt.t list;

     

       101
       -
         mutable lifespan_context: (string * Json.t) list;

     

       102
       -
         mutable startup_hook: (unit -> unit) option;

     

       103
       -
         mutable shutdown_hook: (unit -> unit) option;

     

       104
       -
       }

     

       105
        
       

     

       106
        
       (** Create a new server *)

     

       107
        
       val create_server : name:string -> ?version:string -> ?protocol_version:string -> unit -> server

     
···

       132
        
       

     

       133
        
       (** Configure server with default capabilities based on registered components *)

     

       134
        
       val configure_server : server -> ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> server

     

       135
       -
       

     

       136
       -
       (** Set startup hook *)

     

       137
       -
       val set_startup_hook : server -> (unit -> unit) -> unit

     

       138
       -
       

     

       139
       -
       (** Set shutdown hook *)

     

       140
       -
       val set_shutdown_hook : server -> (unit -> unit) -> unit

     

       141
       -
       

     

       142
       -
       (** Run the server *)

     

       143
       -
       val run_server : server -> unit

     

       144
        
       

     

       145
        
       (** Helper functions for creating common objects *)

     

       146
        
       val make_text_content : string -> content

···

       90
        
       end

     

       91
        
       

     

       92
        
       (** Main server type *)

     

       93
       +
       type server

     

       94
       +
       

     

       95
       +
       val name : server -> string

     

       96
       +
       val version : server -> string

     

       97
       +
       val protocol_version : server -> string

     

       98
       +
       val capabilities : server -> Json.t

     

       99
       +
       val tools : server -> Tool.t list

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       100
        
       

     

       101
        
       (** Create a new server *)

     

       102
        
       val create_server : name:string -> ?version:string -> ?protocol_version:string -> unit -> server

     
···

       127
        
       

     

       128
        
       (** Configure server with default capabilities based on registered components *)

     

       129
        
       val configure_server : server -> ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> server

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       130
        
       

     

       131
        
       (** Helper functions for creating common objects *)

     

       132
        
       val make_text_content : string -> content

+207

lib/mcp_server.ml

···

       1
       +
       open Mcp

     

       2
       +
       open Jsonrpc

     

       3
       +
       open Mcp_sdk

     

       4
       +
       

     

       5
       +
       (* Process a single message using the MCP SDK *)

     

       6
       +
       let process_message server message =

     

       7
       +
         try

     

       8
       +
           Log.debug (Printf.sprintf "Processing message: %s" (Yojson.Safe.to_string message));

     

       9
       +
           match JSONRPCMessage.t_of_yojson message with

     

       10
       +
           | JSONRPCMessage.Request req ->

     

       11
       +
             Log.debug (Printf.sprintf "Received request with method: %s" req.method_);

     

       12
       +
             (match req.method_ with

     

       13
       +
              | "initialize" -> 

     

       14
       +
                 Log.debug "Processing initialize request";

     

       15
       +
                 let result = match req.params with

     

       16
       +
                   | Some params -> 

     

       17
       +
                       let req_data = Initialize.Request.t_of_yojson params in

     

       18
       +
                       Log.debug (Printf.sprintf "Client info: %s v%s" 

     

       19
       +
                         req_data.client_info.name req_data.client_info.version);

     

       20
       +
                       Log.debug (Printf.sprintf "Client protocol version: %s" req_data.protocol_version);

     

       21
       +
                       

     

       22
       +
                       (* Create initialize response *)

     

       23
       +
                       let result = Initialize.Result.create

     

       24
       +
                         ~capabilities:(capabilities server)

     

       25
       +
                         ~server_info:Implementation.{ 

     

       26
       +
                           name = name server; 

     

       27
       +
                           version = version server 

     

       28
       +
                         }

     

       29
       +
                         ~protocol_version:(protocol_version server)

     

       30
       +
                         ~instructions:(Printf.sprintf "This server provides tools for %s." (name server))

     

       31
       +
                         ()

     

       32
       +
                       in

     

       33
       +
                       Initialize.Result.yojson_of_t result

     

       34
       +
                   | None -> 

     

       35
       +
                       Log.error "Missing params for initialize request";

     

       36
       +
                       `Assoc [("error", `String "Missing params for initialize request")]

     

       37
       +
                 in

     

       38
       +
                 Some (create_response ~id:req.id ~result)

     

       39
       +
              | "tools/list" -> 

     

       40
       +
                 Log.debug "Processing tools/list request";

     

       41
       +
                 let tool_list = List.map Tool.to_json (tools server) in

     

       42
       +
                 let result = `Assoc [("tools", `List tool_list)] in

     

       43
       +
                 Some (create_response ~id:req.id ~result)

     

       44
       +
              | "tools/call" -> 

     

       45
       +
                 Log.debug "Processing tools/call request";

     

       46
       +
                 (match req.params with

     

       47
       +
                 | Some (`Assoc params) ->

     

       48
       +
                   let name = match List.assoc_opt "name" params with

     

       49
       +
                     | Some (`String name) -> 

     

       50
       +
                         Log.debug (Printf.sprintf "Tool name: %s" name);

     

       51
       +
                         name

     

       52
       +
                     | _ -> 

     

       53
       +
                         Log.error "Missing or invalid 'name' parameter in tool call";

     

       54
       +
                         ""

     

       55
       +
                   in

     

       56
       +
                   let args = match List.assoc_opt "arguments" params with

     

       57
       +
                     | Some (args) -> 

     

       58
       +
                         Log.debug (Printf.sprintf "Tool arguments: %s" (Yojson.Safe.to_string args));

     

       59
       +
                         args

     

       60
       +
                     | _ -> 

     

       61
       +
                         Log.debug "No arguments provided for tool call, using empty object";

     

       62
       +
                         `Assoc [] (* Empty arguments is valid *)

     

       63
       +
                   in

     

       64
       +
                   

     

       65
       +
                   (* Find the matching tool *)

     

       66
       +
                   let result = 

     

       67
       +
                     try

     

       68
       +
                       let tool = List.find (fun t -> t.Tool.name = name) (tools server) in

     

       69
       +
                       Log.debug (Printf.sprintf "Found tool: %s" name);

     

       70
       +
                       

     

       71
       +
                       (* Create context for this request *)

     

       72
       +
                       let ctx = Context.create ?request_id:req.progress_token () in

     

       73
       +
                       

     

       74
       +
                       (* Call the tool handler *)

     

       75
       +
                       match tool.handler ctx args with

     

       76
       +
                       | Ok result -> 

     

       77
       +
                           Log.debug (Printf.sprintf "Tool execution succeeded");

     

       78
       +
                           result

     

       79
       +
                       | Error err -> 

     

       80
       +
                           Log.error (Printf.sprintf "Tool execution failed: %s" err);

     

       81
       +
                           let error_content = TextContent.{

     

       82
       +
                             text = Printf.sprintf "Error executing tool: %s" err;

     

       83
       +
                             annotations = None

     

       84
       +
                           } in

     

       85
       +
                           `Assoc [

     

       86
       +
                             ("content", `List [TextContent.yojson_of_t error_content]);

     

       87
       +
                             ("isError", `Bool true)

     

       88
       +
                           ]

     

       89
       +
                     with

     

       90
       +
                     | Not_found ->

     

       91
       +
                         Log.error (Printf.sprintf "Unknown tool: %s" name);

     

       92
       +
                         let error_content = TextContent.{

     

       93
       +
                           text = Printf.sprintf "Unknown tool: %s" name;

     

       94
       +
                           annotations = None

     

       95
       +
                         } in

     

       96
       +
                         `Assoc [

     

       97
       +
                           ("content", `List [TextContent.yojson_of_t error_content]);

     

       98
       +
                           ("isError", `Bool true)

     

       99
       +
                         ]

     

       100
       +
                     | exn ->

     

       101
       +
                         Log.error (Printf.sprintf "Exception executing tool: %s" (Printexc.to_string exn));

     

       102
       +
                         let error_content = TextContent.{

     

       103
       +
                           text = Printf.sprintf "Internal error: %s" (Printexc.to_string exn);

     

       104
       +
                           annotations = None

     

       105
       +
                         } in

     

       106
       +
                         `Assoc [

     

       107
       +
                           ("content", `List [TextContent.yojson_of_t error_content]);

     

       108
       +
                           ("isError", `Bool true)

     

       109
       +
                         ]

     

       110
       +
                   in

     

       111
       +
                   Some (create_response ~id:req.id ~result)

     

       112
       +
                 | _ ->

     

       113
       +
                   Log.error "Invalid params format for tools/call";

     

       114
       +
                   Some (create_error ~id:req.id ~code:(-32602) ~message:"Invalid params for tools/call" ()))

     

       115
       +
              | "ping" -> 

     

       116
       +
                 Log.debug "Processing ping request";

     

       117
       +
                 Some (create_response ~id:req.id ~result:(`Assoc []))

     

       118
       +
              | _ -> 

     

       119
       +
                 Log.error (Printf.sprintf "Unknown method received: %s" req.method_);

     

       120
       +
                 Some (create_error ~id:req.id ~code:(-32601) ~message:("Method not found: " ^ req.method_) ()))

     

       121
       +
           | JSONRPCMessage.Notification notif ->

     

       122
       +
             Log.debug (Printf.sprintf "Received notification with method: %s" notif.method_);

     

       123
       +
             (match notif.method_ with

     

       124
       +
              | "notifications/initialized" ->

     

       125
       +
                 Log.debug "Client initialization complete - Server is now ready to receive requests";

     

       126
       +
                 Log.debug (Printf.sprintf "Notification params: %s" 

     

       127
       +
                   (match notif.params with

     

       128
       +
                    | Some p -> Yojson.Safe.to_string p

     

       129
       +
                    | None -> "null"));

     

       130
       +
                 None

     

       131
       +
              | _ ->

     

       132
       +
                 Log.debug (Printf.sprintf "Ignoring notification: %s" notif.method_);

     

       133
       +
                 None)

     

       134
       +
           | JSONRPCMessage.Response _ ->

     

       135
       +
             Log.error "Unexpected response message received";

     

       136
       +
             None

     

       137
       +
           | JSONRPCMessage.Error _ ->

     

       138
       +
             Log.error "Unexpected error message received";

     

       139
       +
             None

     

       140
       +
         with

     

       141
       +
         | Json.Of_json (msg, _) ->

     

       142
       +
           Log.error (Printf.sprintf "JSON error: %s" msg);

     

       143
       +
           None

     

       144
       +
         | exc ->

     

       145
       +
           Log.error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));

     

       146
       +
           Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));

     

       147
       +
           Log.error (Printf.sprintf "Message was: %s" (Yojson.Safe.to_string message));

     

       148
       +
           None

     

       149
       +
       

     

       150
       +
       (* Run the MCP server with the given server configuration *)

     

       151
       +
       let run_server env server =

     

       152
       +
         let stdin = Eio.Stdenv.stdin env in

     

       153
       +
         let stdout = Eio.Stdenv.stdout env in

     

       154
       +
       

     

       155
       +
         Log.debug (Printf.sprintf "Starting MCP server: %s v%s" (name server) (version server));

     

       156
       +
         Log.debug (Printf.sprintf "Protocol version: %s" (protocol_version server));

     

       157
       +
       

     

       158
       +
         (* Enable exception backtraces *)

     

       159
       +
         Printexc.record_backtrace true;

     

       160
       +
         

     

       161
       +
         let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in

     

       162
       +
         

     

       163
       +
         (* Main processing loop *)

     

       164
       +
         try

     

       165
       +
         while true do

     

       166
       +
           Log.debug (Printf.sprintf "Waiting for message..." );

     

       167
       +
             let line = Eio.Buf_read.line buf in

     

       168
       +
             if line = "" then (

     

       169
       +
               Log.debug "Empty line received, ignoring";

     

       170
       +
             ) else (

     

       171
       +
               Log.debug (Printf.sprintf "Raw input: %s" line);

     

       172
       +
               try

     

       173
       +
                 let json = Yojson.Safe.from_string line in

     

       174
       +
                 Log.debug "Successfully parsed JSON";

     

       175
       +
                 

     

       176
       +
                 (* Process the message *)

     

       177
       +
                 match process_message server json with

     

       178
       +
                 | Some response -> begin

     

       179
       +
                     (* Send response *)

     

       180
       +
                     let response_json = JSONRPCMessage.yojson_of_t response in

     

       181
       +
                     let response_str = Yojson.Safe.to_string response_json in

     

       182
       +
                     Log.debug (Printf.sprintf "Sending response: %s" response_str);

     

       183
       +
                     

     

       184
       +
                     (* Write the response followed by a newline *)

     

       185
       +
                     Eio.Flow.copy_string response_str stdout;

     

       186
       +
                     Eio.Flow.copy_string "\n" stdout;

     

       187
       +
                 end

     

       188
       +
                 | None -> 

     

       189
       +
                     Log.debug "No response needed for this message";

     

       190
       +
               with

     

       191
       +
               | Yojson.Json_error msg -> begin

     

       192
       +
                   Log.error (Printf.sprintf "Error parsing JSON: %s" msg);

     

       193
       +
                   Log.error (Printf.sprintf "Input was: %s" line);

     

       194
       +
               end

     

       195
       +
             )

     

       196
       +
           done

     

       197
       +
           with

     

       198
       +
           | End_of_file -> 

     

       199
       +
               Log.debug "End of file received on stdin";

     

       200
       +
               ()

     

       201
       +
           | Eio.Exn.Io _ as exn ->

     

       202
       +
               Log.error (Printf.sprintf "I/O error while reading: %s" (Printexc.to_string exn));

     

       203
       +
               ()

     

       204
       +
           | exc ->

     

       205
       +
               Log.error (Printf.sprintf "Exception while reading: %s" (Printexc.to_string exc));

     

       206
       +
               ()

     

       207
       +