commit 415c0832056a7b9ebee7fc4bac5c274d03b2bb0b · anil.recoil.org/ocaml-mcp

bin/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (name server)

     

       3
       3
       +
        (libraries mcp yojson unix))

+365

bin/server.ml

···

       1
       1
       +
       open Mcp

     

       2
       2
       +
       open Jsonrpc

     

       3
       3
       +
       

     

       4
       4
       +
       (* Logging utilities *)

     

       5
       5
       +
       let log_debug msg =

     

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

     

       7
       7
       +
         flush stderr

     

       8
       8
       +
       

     

       9
       9
       +
       let log_error msg =

     

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

     

       11
       11
       +
         flush stderr

     

       12
       12
       +
       

     

       13
       13
       +
       (* Server state *)

     

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

     

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

     

       16
       16
       +
       let server_capabilities = `Assoc [

     

       17
       17
       +
         (* We support tools *)

     

       18
       18
       +
         ("tools", `Assoc [

     

       19
       19
       +
           ("listChanged", `Bool true)

     

       20
       20
       +
         ]);

     

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

     

       22
       22
       +
         ("resources", `Assoc [

     

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

     

       24
       24
       +
           ("subscribe", `Bool false)

     

       25
       25
       +
         ]);

     

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

     

       27
       27
       +
         ("prompts", `Assoc [

     

       28
       28
       +
           ("listChanged", `Bool false)

     

       29
       29
       +
         ])

     

       30
       30
       +
       ]

     

       31
       31
       +
       

     

       32
       32
       +
       (* Tool implementation *)

     

       33
       33
       +
       module CapitalizeTool = struct

     

       34
       34
       +
         let name = "capitalize"

     

       35
       35
       +
         let description = "Capitalizes the provided text"

     

       36
       36
       +
         let input_schema = `Assoc [

     

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

     

       38
       38
       +
           ("properties", `Assoc [

     

       39
       39
       +
             ("text", `Assoc [

     

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

     

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

     

       42
       42
       +
             ])

     

       43
       43
       +
           ]);

     

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

     

       45
       45
       +
         ]

     

       46
       46
       +
       

     

       47
       47
       +
         let call json =

     

       48
       48
       +
           match json with

     

       49
       49
       +
           | `Assoc fields ->

     

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

     

       51
       51
       +
              | Some (`String text) ->

     

       52
       52
       +
                let capitalized_text = String.uppercase_ascii text in

     

       53
       53
       +
                let content = TextContent.{ 

     

       54
       54
       +
                  text = capitalized_text;

     

       55
       55
       +
                  annotations = None 

     

       56
       56
       +
                } in

     

       57
       57
       +
                `Assoc [

     

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

     

       59
       59
       +
                  ("isError", `Bool false)

     

       60
       60
       +
                ]

     

       61
       61
       +
              | _ -> 

     

       62
       62
       +
                let error_content = TextContent.{

     

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

     

       64
       64
       +
                  annotations = None

     

       65
       65
       +
                } in

     

       66
       66
       +
                `Assoc [

     

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

     

       68
       68
       +
                  ("isError", `Bool true)

     

       69
       69
       +
                ])

     

       70
       70
       +
           | _ ->

     

       71
       71
       +
             let error_content = TextContent.{

     

       72
       72
       +
               text = "Invalid arguments format";

     

       73
       73
       +
               annotations = None

     

       74
       74
       +
             } in

     

       75
       75
       +
             `Assoc [

     

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

     

       77
       77
       +
               ("isError", `Bool true)

     

       78
       78
       +
             ]

     

       79
       79
       +
       end

     

       80
       80
       +
       

     

       81
       81
       +
       (* Handle tool listing *)

     

       82
       82
       +
       let list_tools () =

     

       83
       83
       +
         let tool = `Assoc [

     

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

     

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

     

       86
       86
       +
           ("inputSchema", CapitalizeTool.input_schema)

     

       87
       87
       +
         ] in

     

       88
       88
       +
         `Assoc [

     

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

     

       90
       90
       +
         ]

     

       91
       91
       +
       

     

       92
       92
       +
       (* Handle tool calls *)

     

       93
       93
       +
       let call_tool name args =

     

       94
       94
       +
         if name = CapitalizeTool.name then

     

       95
       95
       +
           CapitalizeTool.call args

     

       96
       96
       +
         else

     

       97
       97
       +
           let error_content = TextContent.{

     

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

     

       99
       99
       +
             annotations = None

     

       100
       100
       +
           } in

     

       101
       101
       +
           `Assoc [

     

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

     

       103
       103
       +
             ("isError", `Bool true)

     

       104
       104
       +
           ]

     

       105
       105
       +
       

     

       106
       106
       +
       (* Handle initialization *)

     

       107
       107
       +
       let handle_initialize id json =

     

       108
       108
       +
         try

     

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

     

       110
       110
       +
             (match id with 

     

       111
       111
       +
              | `Int i -> string_of_int i 

     

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

     

       113
       113
       +
           

     

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

     

       115
       115
       +
             (match json with 

     

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

     

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

     

       118
       118
       +
           

     

       119
       119
       +
           let _ = match json with

     

       120
       120
       +
             | Some params -> 

     

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

     

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

     

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

     

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

     

       125
       125
       +
                 

     

       126
       126
       +
                 (* Check protocol version compatibility *)

     

       127
       127
       +
                 if req.protocol_version <> protocol_version then

     

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

     

       129
       129
       +
                     req.protocol_version protocol_version);

     

       130
       130
       +
                 

     

       131
       131
       +
                 req

     

       132
       132
       +
             | None -> 

     

       133
       133
       +
                 log_error "Missing params for initialize request";

     

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

     

       135
       135
       +
           in

     

       136
       136
       +
           

     

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

     

       138
       138
       +
           let result = Initialize.Result.create

     

       139
       139
       +
             ~capabilities:server_capabilities

     

       140
       140
       +
             ~server_info

     

       141
       141
       +
             ~protocol_version

     

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

     

       143
       143
       +
             ()

     

       144
       144
       +
           in

     

       145
       145
       +
           

     

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

     

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

     

       148
       148
       +
           log_debug "Initialize response created successfully";

     

       149
       149
       +
           response

     

       150
       150
       +
         with

     

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

     

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

     

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

     

       154
       154
       +
         | exc ->

     

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

     

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

     

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

     

       158
       158
       +
       

     

       159
       159
       +
       (* Handle tools/list *)

     

       160
       160
       +
       let handle_list_tools id =

     

       161
       161
       +
         log_debug "Processing tools/list request";

     

       162
       162
       +
         let result = list_tools () in

     

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

     

       164
       164
       +
         create_response ~id ~result

     

       165
       165
       +
       

     

       166
       166
       +
       (* Handle tools/call *)

     

       167
       167
       +
       let handle_call_tool id json =

     

       168
       168
       +
         try

     

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

     

       170
       170
       +
             (match id with 

     

       171
       171
       +
              | `Int i -> string_of_int i 

     

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

     

       173
       173
       +
           

     

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

     

       175
       175
       +
             (match json with 

     

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

     

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

     

       178
       178
       +
           

     

       179
       179
       +
           match json with

     

       180
       180
       +
           | Some (`Assoc params) ->

     

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

     

       182
       182
       +
               | Some (`String name) -> 

     

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

     

       184
       184
       +
                   name

     

       185
       185
       +
               | _ -> 

     

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

     

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

     

       188
       188
       +
             in

     

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

     

       190
       190
       +
               | Some (args) -> 

     

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

     

       192
       192
       +
                   args

     

       193
       193
       +
               | _ -> 

     

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

     

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

     

       196
       196
       +
             in

     

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

     

       198
       198
       +
             let result = call_tool name args in

     

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

     

       200
       200
       +
             create_response ~id ~result

     

       201
       201
       +
           | _ ->

     

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

     

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

     

       204
       204
       +
         with

     

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

     

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

     

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

     

       208
       208
       +
         | exc ->

     

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

     

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

     

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

     

       212
       212
       +
       

     

       213
       213
       +
       (* Handle ping *)

     

       214
       214
       +
       let handle_ping id =

     

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

     

       216
       216
       +
       

     

       217
       217
       +
       (* Process a single message *)

     

       218
       218
       +
       let process_message message =

     

       219
       219
       +
         try

     

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

     

       221
       221
       +
           match JSONRPCMessage.t_of_yojson message with

     

       222
       222
       +
           | JSONRPCMessage.Request req ->

     

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

     

       224
       224
       +
             (match req.method_ with

     

       225
       225
       +
              | "initialize" -> 

     

       226
       226
       +
                log_debug "Processing initialize request";

     

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

     

       228
       228
       +
              | "tools/list" -> 

     

       229
       229
       +
                log_debug "Processing tools/list request";

     

       230
       230
       +
                Some (handle_list_tools req.id)

     

       231
       231
       +
              | "tools/call" -> 

     

       232
       232
       +
                log_debug "Processing tools/call request";

     

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

     

       234
       234
       +
              | "ping" -> 

     

       235
       235
       +
                log_debug "Processing ping request";

     

       236
       236
       +
                Some (handle_ping req.id)

     

       237
       237
       +
              | _ -> 

     

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

     

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

     

       240
       240
       +
           | JSONRPCMessage.Notification notif ->

     

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

     

       242
       242
       +
             (match notif.method_ with

     

       243
       243
       +
              | "notifications/initialized" ->

     

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

     

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

     

       246
       246
       +
                  (match notif.params with

     

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

     

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

     

       249
       249
       +
                None

     

       250
       250
       +
              | _ ->

     

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

     

       252
       252
       +
                None)

     

       253
       253
       +
           | JSONRPCMessage.Response _ ->

     

       254
       254
       +
             log_error "Unexpected response message received";

     

       255
       255
       +
             None

     

       256
       256
       +
           | JSONRPCMessage.Error _ ->

     

       257
       257
       +
             log_error "Unexpected error message received";

     

       258
       258
       +
             None

     

       259
       259
       +
         with

     

       260
       260
       +
         | exc ->

     

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

     

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

     

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

     

       264
       264
       +
           None

     

       265
       265
       +
       

     

       266
       266
       +
       (* Main loop *)

     

       267
       267
       +
       let rec read_message () =

     

       268
       268
       +
         try

     

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

     

       270
       270
       +
           let line = read_line () in

     

       271
       271
       +
           if line = "" then (

     

       272
       272
       +
             log_debug "Empty line received, ignoring";

     

       273
       273
       +
             None

     

       274
       274
       +
           ) else (

     

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

     

       276
       276
       +
             try

     

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

     

       278
       278
       +
               log_debug "Successfully parsed JSON";

     

       279
       279
       +
               Some json

     

       280
       280
       +
             with

     

       281
       281
       +
             | Yojson.Json_error msg -> 

     

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

     

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

     

       284
       284
       +
               read_message ()

     

       285
       285
       +
           )

     

       286
       286
       +
         with

     

       287
       287
       +
         | End_of_file -> 

     

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

     

       289
       289
       +
           None

     

       290
       290
       +
         | Sys_error msg -> 

     

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

     

       292
       292
       +
           None

     

       293
       293
       +
         | exc ->

     

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

     

       295
       295
       +
           None

     

       296
       296
       +
       

     

       297
       297
       +
       let () =

     

       298
       298
       +
         try

     

       299
       299
       +
           (* Enable exception backtraces *)

     

       300
       300
       +
           Printexc.record_backtrace true;

     

       301
       301
       +
           

     

       302
       302
       +
           (* Enable line buffering for stdout *)

     

       303
       303
       +
           set_binary_mode_out stdout false;

     

       304
       304
       +
           

     

       305
       305
       +
           log_debug "MCP Capitalizer server started";

     

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

     

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

     

       308
       308
       +
           

     

       309
       309
       +
           (* Print environment info for debugging *)

     

       310
       310
       +
           log_debug "Environment variables:";

     

       311
       311
       +
           Unix.environment()

     

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

     

       313
       313
       +
             try

     

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

     

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

     

       316
       316
       +
               if String.length name > 0 then

     

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

     

       318
       318
       +
             with Not_found -> ()

     

       319
       319
       +
           );

     

       320
       320
       +
           

     

       321
       321
       +
           let rec server_loop count =

     

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

     

       323
       323
       +
             match read_message () with

     

       324
       324
       +
             | Some json ->

     

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

     

       326
       326
       +
               (match process_message json with

     

       327
       327
       +
                | Some response ->

     

       328
       328
       +
                  let response_json = JSONRPCMessage.yojson_of_t response in

     

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

     

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

     

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

     

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

     

       333
       333
       +
                  flush stdout;

     

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

     

       335
       335
       +
                  Unix.sleepf 0.01;

     

       336
       336
       +
                  server_loop (count + 1)

     

       337
       337
       +
                | None -> 

     

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

     

       339
       339
       +
                  server_loop (count + 1))

     

       340
       340
       +
             | None -> 

     

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

     

       342
       342
       +
               ()

     

       343
       343
       +
           in

     

       344
       344
       +
           

     

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

     

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

     

       347
       347
       +
           

     

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

     

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

     

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

     

       351
       351
       +
             exit 0

     

       352
       352
       +
           )));

     

       353
       353
       +
           

     

       354
       354
       +
           server_loop 1;

     

       355
       355
       +
           log_debug "Server terminated normally";

     

       356
       356
       +
         with

     

       357
       357
       +
         | End_of_file ->

     

       358
       358
       +
           log_error "Unexpected end of file";

     

       359
       359
       +
         | Sys_error msg ->

     

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

     

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

     

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

     

       363
       363
       +
         | exc ->

     

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

     

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