commit 3d958b958219717ad949ba817fb4935591b346a4 · anil.recoil.org/ocaml-mcp

+118

bin/capitalize_sdk.ml

···

       1
       1
       +
       open Mcp

     

       2
       2
       +
       open Mcp_sdk

     

       3
       3
       +
       

     

       4
       4
       +
       (* Create the server module *)

     

       5
       5
       +
       module CapitalizeServer = MakeServer(struct

     

       6
       6
       +
         let name = "OCaml MCP Capitalizer"

     

       7
       7
       +
         let version = Some "0.1.0"

     

       8
       8
       +
       end)

     

       9
       9
       +
       

     

       10
       10
       +
       (* Helper for extracting string value from JSON *)

     

       11
       11
       +
       let get_string_param json name =

     

       12
       12
       +
         match json with

     

       13
       13
       +
         | `Assoc fields ->

     

       14
       14
       +
           (match List.assoc_opt name fields with

     

       15
       15
       +
           | Some (`String value) -> value

     

       16
       16
       +
           | _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))

     

       17
       17
       +
         | _ -> raise (Failure "Expected JSON object")

     

       18
       18
       +
       

     

       19
       19
       +
       (* Define a capitalize tool *)

     

       20
       20
       +
       let _ = CapitalizeServer.tool

     

       21
       21
       +
         ~name:(Some "capitalize")

     

       22
       22
       +
         ~description:"Capitalizes the provided text"

     

       23
       23
       +
         ~schema_properties:[

     

       24
       24
       +
           ("text", "string", "The text to capitalize")

     

       25
       25
       +
         ]

     

       26
       26
       +
         ~schema_required:["text"]

     

       27
       27
       +
         (fun args ->

     

       28
       28
       +
           try

     

       29
       29
       +
             let text = get_string_param args "text" in

     

       30
       30
       +
             let capitalized_text = String.uppercase_ascii text in

     

       31
       31
       +
             TextContent.yojson_of_t TextContent.{

     

       32
       32
       +
               text = capitalized_text;

     

       33
       33
       +
               annotations = None

     

       34
       34
       +
             }

     

       35
       35
       +
           with

     

       36
       36
       +
           | Failure msg ->

     

       37
       37
       +
             Log.error (Printf.sprintf "Error in capitalize tool: %s" msg);

     

       38
       38
       +
             TextContent.yojson_of_t TextContent.{

     

       39
       39
       +
               text = Printf.sprintf "Error: %s" msg;

     

       40
       40
       +
               annotations = None

     

       41
       41
       +
             }

     

       42
       42
       +
         )

     

       43
       43
       +
       

     

       44
       44
       +
       (* Define a resource example *)

     

       45
       45
       +
       let _ = CapitalizeServer.resource

     

       46
       46
       +
         ~uri_template:(Some "greeting://{name}")

     

       47
       47
       +
         ~description:"Get a greeting for a name"

     

       48
       48
       +
         ~mime_type:"text/plain"

     

       49
       49
       +
         (fun params ->

     

       50
       50
       +
           match params with

     

       51
       51
       +
           | [name] -> Printf.sprintf "Hello, %s! Welcome to the OCaml MCP server." name

     

       52
       52
       +
           | _ -> "Hello, world! Welcome to the OCaml MCP server."

     

       53
       53
       +
         )

     

       54
       54
       +
       

     

       55
       55
       +
       (* Define a prompt example *)

     

       56
       56
       +
       let _ = CapitalizeServer.prompt

     

       57
       57
       +
         ~name:(Some "capitalize-prompt")

     

       58
       58
       +
         ~description:"A prompt to help with text capitalization"

     

       59
       59
       +
         ~arguments:[

     

       60
       60
       +
           ("text", Some "The text to be capitalized", true)

     

       61
       61
       +
         ]

     

       62
       62
       +
         (fun args ->

     

       63
       63
       +
           let text = 

     

       64
       64
       +
             try

     

       65
       65
       +
               List.assoc "text" args

     

       66
       66
       +
             with

     

       67
       67
       +
             | Not_found -> "No text provided"

     

       68
       68
       +
           in

     

       69
       69
       +
           [

     

       70
       70
       +
             Prompt.{ 

     

       71
       71
       +
               role = `User; 

     

       72
       72
       +
               content = make_text_content "Please help me capitalize the following text:"

     

       73
       73
       +
             };

     

       74
       74
       +
             Prompt.{ 

     

       75
       75
       +
               role = `User; 

     

       76
       76
       +
               content = make_text_content text

     

       77
       77
       +
             };

     

       78
       78
       +
             Prompt.{ 

     

       79
       79
       +
               role = `Assistant; 

     

       80
       80
       +
               content = make_text_content "Here's the capitalized version:"

     

       81
       81
       +
             };

     

       82
       82
       +
             Prompt.{ 

     

       83
       83
       +
               role = `Assistant; 

     

       84
       84
       +
               content = make_text_content (String.uppercase_ascii text)

     

       85
       85
       +
             }

     

       86
       86
       +
           ]

     

       87
       87
       +
         )

     

       88
       88
       +
       

     

       89
       89
       +
       (* Define startup and shutdown hooks *)

     

       90
       90
       +
       let startup () =

     

       91
       91
       +
         Printf.printf "CapitalizeServer is starting up!\n";

     

       92
       92
       +
         flush stdout;

     

       93
       93
       +
         Log.info "CapitalizeServer is starting up!"

     

       94
       94
       +
       

     

       95
       95
       +
       let shutdown () =

     

       96
       96
       +
         Printf.printf "CapitalizeServer is shutting down. Goodbye!\n";

     

       97
       97
       +
         flush stdout;

     

       98
       98
       +
         Log.info "CapitalizeServer is shutting down. Goodbye!"

     

       99
       99
       +
       

     

       100
       100
       +
       (* Main function *)

     

       101
       101
       +
       let () =

     

       102
       102
       +
         (* Print directly to ensure we see output *)

     

       103
       103
       +
         Printf.printf "Starting CapitalizeServer...\n";

     

       104
       104
       +
         flush stdout;

     

       105
       105
       +
         

     

       106
       106
       +
         (* Run the server with all our registered capabilities *)

     

       107
       107
       +
         let server_with_hooks = { CapitalizeServer.server with 

     

       108
       108
       +
           Server.startup_hook = Some startup;

     

       109
       109
       +
           Server.shutdown_hook = Some shutdown;

     

       110
       110
       +
         } in

     

       111
       111
       +
         

     

       112
       112
       +
         (* Run the startup hook directly *)

     

       113
       113
       +
         (match server_with_hooks.Server.startup_hook with

     

       114
       114
       +
          | Some hook -> hook()

     

       115
       115
       +
          | None -> ());

     

       116
       116
       +
         

     

       117
       117
       +
         (* Now run the server *)

     

       118
       118
       +
         Server.run server_with_hooks

+6 -1

bin/dune

···

       1
       1
        
       (executable

     

       2
       2
        
        (name server)

     

       3
       3
       -
        (libraries mcp yojson unix))
     

       3
       3
       +
        (libraries mcp yojson unix))

     

       4
       4
       +
       

     

       5
       5
       +
       (executable

     

       6
       6
       +
        (name capitalize_sdk)

     

       7
       7
       +
        (modules capitalize_sdk)

     

       8
       8
       +
        (libraries mcp mcp_sdk yojson unix))

bin/server.mli

···

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

     

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

     

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

     

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

     

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

+8 -1

lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
         (name mcp)

     

       3
       3
       -
         (libraries jsonrpc))

     

       3
       3
       +
         (libraries jsonrpc unix yojson)

     

       4
       4
       +
         (modules mcp))

     

       5
       5
       +
       

     

       6
       6
       +
       (library

     

       7
       7
       +
         (name mcp_sdk)

     

       8
       8
       +
         (libraries mcp jsonrpc unix yojson)

     

       9
       9
       +
         (modules mcp_sdk)

     

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

+391

lib/mcp_sdk.ml

···

       1
       1
       +
       open Mcp

     

       2
       2
       +
       open Jsonrpc

     

       3
       3
       +
       

     

       4
       4
       +
       (* SDK version *)

     

       5
       5
       +
       let version = "0.1.0"

     

       6
       6
       +
       

     

       7
       7
       +
       (* Logging utilities *)

     

       8
       8
       +
       module Log = struct

     

       9
       9
       +
         type level = Debug | Info | Warning | Error

     

       10
       10
       +
       

     

       11
       11
       +
         let string_of_level = function

     

       12
       12
       +
           | Debug -> "DEBUG"

     

       13
       13
       +
           | Info -> "INFO"

     

       14
       14
       +
           | Warning -> "WARNING"

     

       15
       15
       +
           | Error -> "ERROR"

     

       16
       16
       +
       

     

       17
       17
       +
         let log level msg =

     

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

     

       19
       19
       +
           flush stderr;

     

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

     

       21
       21
       +
           flush stdout

     

       22
       22
       +
       

     

       23
       23
       +
         let debug = log Debug

     

       24
       24
       +
         let info = log Info

     

       25
       25
       +
         let warning = log Warning

     

       26
       26
       +
         let error = log Error

     

       27
       27
       +
       end

     

       28
       28
       +
       

     

       29
       29
       +
       (* Context for tools and resources *)

     

       30
       30
       +
       module Context = struct

     

       31
       31
       +
         type t = {

     

       32
       32
       +
           request_id: RequestId.t option;

     

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

     

       34
       34
       +
           mutable progress_token: ProgressToken.t option;

     

       35
       35
       +
         }

     

       36
       36
       +
       

     

       37
       37
       +
         let create ?request_id ?(lifespan_context=[]) () =

     

       38
       38
       +
           { request_id; lifespan_context; progress_token = None }

     

       39
       39
       +
       

     

       40
       40
       +
         let get_context_value ctx key =

     

       41
       41
       +
           List.assoc_opt key ctx.lifespan_context

     

       42
       42
       +
         

     

       43
       43
       +
         let report_progress ctx value total =

     

       44
       44
       +
           match ctx.progress_token, ctx.request_id with

     

       45
       45
       +
           | Some token, Some id ->

     

       46
       46
       +
             let params = `Assoc [

     

       47
       47
       +
               ("progress", `Float value);

     

       48
       48
       +
               ("total", `Float total);

     

       49
       49
       +
               ("progressToken", ProgressToken.yojson_of_t token)

     

       50
       50
       +
             ] in

     

       51
       51
       +
             Some (create_notification ~method_:"notifications/progress" ~params:(Some params) ())

     

       52
       52
       +
           | _ -> None

     

       53
       53
       +
       end

     

       54
       54
       +
       

     

       55
       55
       +
       (* Tools for the MCP server *)

     

       56
       56
       +
       module Tool = struct

     

       57
       57
       +
         type handler = Context.t -> Json.t -> (Json.t, string) result

     

       58
       58
       +
       

     

       59
       59
       +
         type t = {

     

       60
       60
       +
           name: string;

     

       61
       61
       +
           description: string option;

     

       62
       62
       +
           input_schema: Json.t;  (* JSON Schema *)

     

       63
       63
       +
           handler: handler;

     

       64
       64
       +
         }

     

       65
       65
       +
       

     

       66
       66
       +
         let create ~name ?description ~input_schema ~handler () = 

     

       67
       67
       +
           { name; description; input_schema; handler }

     

       68
       68
       +
       

     

       69
       69
       +
         let to_json tool =

     

       70
       70
       +
           let assoc = [

     

       71
       71
       +
             ("name", `String tool.name);

     

       72
       72
       +
             ("inputSchema", tool.input_schema);

     

       73
       73
       +
           ] in

     

       74
       74
       +
           let assoc = match tool.description with

     

       75
       75
       +
             | Some desc -> ("description", `String desc) :: assoc

     

       76
       76
       +
             | None -> assoc

     

       77
       77
       +
           in

     

       78
       78
       +
           `Assoc assoc

     

       79
       79
       +
       end

     

       80
       80
       +
       

     

       81
       81
       +
       (* Resources for the MCP server *)

     

       82
       82
       +
       module Resource = struct

     

       83
       83
       +
         type handler = Context.t -> string list -> (string, string) result

     

       84
       84
       +
       

     

       85
       85
       +
         type t = {

     

       86
       86
       +
           uri_template: string;

     

       87
       87
       +
           description: string option;

     

       88
       88
       +
           mime_type: string option;

     

       89
       89
       +
           handler: handler;

     

       90
       90
       +
         }

     

       91
       91
       +
       

     

       92
       92
       +
         let create ~uri_template ?description ?mime_type ~handler () = 

     

       93
       93
       +
           { uri_template; description; mime_type; handler }

     

       94
       94
       +
       

     

       95
       95
       +
         let to_json resource =

     

       96
       96
       +
           let assoc = [

     

       97
       97
       +
             ("uriTemplate", `String resource.uri_template);

     

       98
       98
       +
           ] in

     

       99
       99
       +
           let assoc = match resource.description with

     

       100
       100
       +
             | Some desc -> ("description", `String desc) :: assoc

     

       101
       101
       +
             | None -> assoc

     

       102
       102
       +
           in

     

       103
       103
       +
           let assoc = match resource.mime_type with

     

       104
       104
       +
             | Some mime -> ("mimeType", `String mime) :: assoc

     

       105
       105
       +
             | None -> assoc

     

       106
       106
       +
           in

     

       107
       107
       +
           `Assoc assoc

     

       108
       108
       +
       end

     

       109
       109
       +
       

     

       110
       110
       +
       (* Prompts for the MCP server *)

     

       111
       111
       +
       module Prompt = struct

     

       112
       112
       +
         type argument = {

     

       113
       113
       +
           name: string;

     

       114
       114
       +
           description: string option;

     

       115
       115
       +
           required: bool;

     

       116
       116
       +
         }

     

       117
       117
       +
       

     

       118
       118
       +
         type message = {

     

       119
       119
       +
           role: Role.t;

     

       120
       120
       +
           content: content;

     

       121
       121
       +
         }

     

       122
       122
       +
       

     

       123
       123
       +
         type handler = Context.t -> (string * string) list -> (message list, string) result

     

       124
       124
       +
       

     

       125
       125
       +
         type t = {

     

       126
       126
       +
           name: string;

     

       127
       127
       +
           description: string option;

     

       128
       128
       +
           arguments: argument list;

     

       129
       129
       +
           handler: handler;

     

       130
       130
       +
         }

     

       131
       131
       +
       

     

       132
       132
       +
         let create ~name ?description ?(arguments=[]) ~handler () = 

     

       133
       133
       +
           { name; description; arguments; handler }

     

       134
       134
       +
       

     

       135
       135
       +
         let create_argument ~name ?description ?(required=false) () =

     

       136
       136
       +
           { name; description; required }

     

       137
       137
       +
       

     

       138
       138
       +
         let to_json prompt =

     

       139
       139
       +
           let assoc = [

     

       140
       140
       +
             ("name", `String prompt.name);

     

       141
       141
       +
           ] in

     

       142
       142
       +
           let assoc = match prompt.description with

     

       143
       143
       +
             | Some desc -> ("description", `String desc) :: assoc

     

       144
       144
       +
             | None -> assoc

     

       145
       145
       +
           in

     

       146
       146
       +
           let assoc = if prompt.arguments <> [] then

     

       147
       147
       +
             let args = List.map (fun (arg: argument) ->

     

       148
       148
       +
               let arg_assoc = [

     

       149
       149
       +
                 ("name", `String arg.name);

     

       150
       150
       +
               ] in

     

       151
       151
       +
               let arg_assoc = match arg.description with

     

       152
       152
       +
                 | Some desc -> ("description", `String desc) :: arg_assoc

     

       153
       153
       +
                 | None -> arg_assoc

     

       154
       154
       +
               in

     

       155
       155
       +
               let arg_assoc = 

     

       156
       156
       +
                 if arg.required then

     

       157
       157
       +
                   ("required", `Bool true) :: arg_assoc

     

       158
       158
       +
                 else

     

       159
       159
       +
                   arg_assoc

     

       160
       160
       +
               in

     

       161
       161
       +
               `Assoc arg_assoc

     

       162
       162
       +
             ) prompt.arguments in

     

       163
       163
       +
             ("arguments", `List args) :: assoc

     

       164
       164
       +
           else

     

       165
       165
       +
             assoc

     

       166
       166
       +
           in

     

       167
       167
       +
           `Assoc assoc

     

       168
       168
       +
       end

     

       169
       169
       +
       

     

       170
       170
       +
       (* Helper functions for creating common objects *)

     

       171
       171
       +
       let make_text_content text =

     

       172
       172
       +
         Text (TextContent.{ text; annotations = None })

     

       173
       173
       +
       

     

       174
       174
       +
       let make_tool_schema properties required =

     

       175
       175
       +
         let props = List.map (fun (name, schema_type, description) ->

     

       176
       176
       +
           (name, `Assoc [

     

       177
       177
       +
             ("type", `String schema_type);

     

       178
       178
       +
             ("description", `String description)

     

       179
       179
       +
           ])

     

       180
       180
       +
         ) properties in

     

       181
       181
       +
         let required_json = `List (List.map (fun name -> `String name) required) in

     

       182
       182
       +
         `Assoc [

     

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

     

       184
       184
       +
           ("properties", `Assoc props);

     

       185
       185
       +
           ("required", required_json)

     

       186
       186
       +
         ]

     

       187
       187
       +
       

     

       188
       188
       +
       (* Server implementation *)

     

       189
       189
       +
       module Server = struct

     

       190
       190
       +
         type startup_hook = unit -> unit

     

       191
       191
       +
         type shutdown_hook = unit -> unit

     

       192
       192
       +
       

     

       193
       193
       +
         type t = {

     

       194
       194
       +
           name: string;

     

       195
       195
       +
           version: string;

     

       196
       196
       +
           protocol_version: string;

     

       197
       197
       +
           mutable capabilities: Json.t;

     

       198
       198
       +
           mutable tools: Tool.t list;

     

       199
       199
       +
           mutable resources: Resource.t list;

     

       200
       200
       +
           mutable prompts: Prompt.t list;

     

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

     

       202
       202
       +
           startup_hook: startup_hook option;

     

       203
       203
       +
           shutdown_hook: shutdown_hook option;

     

       204
       204
       +
         }

     

       205
       205
       +
       

     

       206
       206
       +
         let create ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") ?startup_hook ?shutdown_hook () =

     

       207
       207
       +
           { 

     

       208
       208
       +
             name;

     

       209
       209
       +
             version;

     

       210
       210
       +
             protocol_version;

     

       211
       211
       +
             capabilities = `Assoc [];

     

       212
       212
       +
             tools = [];

     

       213
       213
       +
             resources = [];

     

       214
       214
       +
             prompts = [];

     

       215
       215
       +
             lifespan_context = [];

     

       216
       216
       +
             startup_hook;

     

       217
       217
       +
             shutdown_hook;

     

       218
       218
       +
           }

     

       219
       219
       +
       

     

       220
       220
       +
         (* Register a tool *)

     

       221
       221
       +
         let register_tool server tool =

     

       222
       222
       +
           server.tools <- tool :: server.tools;

     

       223
       223
       +
           ()

     

       224
       224
       +
       

     

       225
       225
       +
         (* Register a resource *)

     

       226
       226
       +
         let register_resource server resource =

     

       227
       227
       +
           server.resources <- resource :: server.resources;

     

       228
       228
       +
           ()

     

       229
       229
       +
       

     

       230
       230
       +
         (* Register a prompt *)

     

       231
       231
       +
         let register_prompt server prompt =

     

       232
       232
       +
           server.prompts <- prompt :: server.prompts;

     

       233
       233
       +
           ()

     

       234
       234
       +
         

     

       235
       235
       +
         (* Default server capabilities *)

     

       236
       236
       +
         let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =

     

       237
       237
       +
           let caps = [] in

     

       238
       238
       +
           let caps = 

     

       239
       239
       +
             if with_tools then

     

       240
       240
       +
               ("tools", `Assoc [

     

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

     

       242
       242
       +
               ]) :: caps

     

       243
       243
       +
             else

     

       244
       244
       +
               caps

     

       245
       245
       +
           in

     

       246
       246
       +
           let caps = 

     

       247
       247
       +
             if with_resources then

     

       248
       248
       +
               ("resources", `Assoc [

     

       249
       249
       +
                 ("listChanged", `Bool true);

     

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

     

       251
       251
       +
               ]) :: caps

     

       252
       252
       +
             else if not with_resources then

     

       253
       253
       +
               ("resources", `Assoc [

     

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

     

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

     

       256
       256
       +
               ]) :: caps

     

       257
       257
       +
             else

     

       258
       258
       +
               caps

     

       259
       259
       +
           in

     

       260
       260
       +
           let caps = 

     

       261
       261
       +
             if with_prompts then

     

       262
       262
       +
               ("prompts", `Assoc [

     

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

     

       264
       264
       +
               ]) :: caps

     

       265
       265
       +
             else if not with_prompts then

     

       266
       266
       +
               ("prompts", `Assoc [

     

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

     

       268
       268
       +
               ]) :: caps

     

       269
       269
       +
             else

     

       270
       270
       +
               caps

     

       271
       271
       +
           in

     

       272
       272
       +
           `Assoc caps

     

       273
       273
       +
       

     

       274
       274
       +
         (* Update server capabilities *)

     

       275
       275
       +
         let update_capabilities server capabilities =

     

       276
       276
       +
           server.capabilities <- capabilities

     

       277
       277
       +
       

     

       278
       278
       +
         (* Process a message *)

     

       279
       279
       +
         let process_message _server _json =

     

       280
       280
       +
           None

     

       281
       281
       +
         

     

       282
       282
       +
         (* Main server loop *)

     

       283
       283
       +
         let run _server =

     

       284
       284
       +
           (* Placeholder implementation *)

     

       285
       285
       +
           ()

     

       286
       286
       +
       end

     

       287
       287
       +
       

     

       288
       288
       +
       (* Helper function for default capabilities *)

     

       289
       289
       +
       let default_capabilities = Server.default_capabilities

     

       290
       290
       +
       

     

       291
       291
       +
       (* Add syntactic sugar for creating a server *)

     

       292
       292
       +
       module MakeServer(S: sig val name: string val version: string option end) = struct

     

       293
       293
       +
         let _config = (S.name, S.version) (* Used to prevent unused parameter warning *)

     

       294
       294
       +
         

     

       295
       295
       +
         (* Create server *)

     

       296
       296
       +
         let server = Server.create 

     

       297
       297
       +
           ~name:S.name 

     

       298
       298
       +
           ?version:S.version 

     

       299
       299
       +
           ~protocol_version:"2024-11-05" 

     

       300
       300
       +
           ()

     

       301
       301
       +
           

     

       302
       302
       +
         (* Create a tool *)

     

       303
       303
       +
         let tool ?name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =

     

       304
       304
       +
           let name = match name with 

     

       305
       305
       +
                      | Some (Some n) -> n 

     

       306
       306
       +
                      | Some None | None -> "tool" in

     

       307
       307
       +
           let input_schema = make_tool_schema schema_properties schema_required in

     

       308
       308
       +
           let handler' ctx args =

     

       309
       309
       +
             try

     

       310
       310
       +
               Ok (handler args)

     

       311
       311
       +
             with exn ->

     

       312
       312
       +
               Error (Printexc.to_string exn)

     

       313
       313
       +
           in

     

       314
       314
       +
           let tool = Tool.create

     

       315
       315
       +
             ~name

     

       316
       316
       +
             ?description

     

       317
       317
       +
             ~input_schema

     

       318
       318
       +
             ~handler:handler'

     

       319
       319
       +
             ()

     

       320
       320
       +
           in

     

       321
       321
       +
           server.tools <- tool :: server.tools;

     

       322
       322
       +
           tool

     

       323
       323
       +
           

     

       324
       324
       +
         (* Create a resource *)

     

       325
       325
       +
         let resource ?uri_template ?description ?mime_type handler =

     

       326
       326
       +
           let uri_template = match uri_template with 

     

       327
       327
       +
                             | Some (Some uri) -> uri 

     

       328
       328
       +
                             | Some None | None -> "resource://" in

     

       329
       329
       +
           let handler' ctx params =

     

       330
       330
       +
             try

     

       331
       331
       +
               Ok (handler params)

     

       332
       332
       +
             with exn ->

     

       333
       333
       +
               Error (Printexc.to_string exn)

     

       334
       334
       +
           in

     

       335
       335
       +
           let resource = Resource.create

     

       336
       336
       +
             ~uri_template

     

       337
       337
       +
             ?description

     

       338
       338
       +
             ?mime_type

     

       339
       339
       +
             ~handler:handler'

     

       340
       340
       +
             ()

     

       341
       341
       +
           in

     

       342
       342
       +
           server.resources <- resource :: server.resources;

     

       343
       343
       +
           resource

     

       344
       344
       +
           

     

       345
       345
       +
         (* Create a prompt *)

     

       346
       346
       +
         let prompt ?name ?description ?(arguments=[]) handler =

     

       347
       347
       +
           let name = match name with 

     

       348
       348
       +
                     | Some (Some n) -> n 

     

       349
       349
       +
                     | Some None | None -> "prompt" in

     

       350
       350
       +
           let prompt_args = List.map (fun (name, desc, required) ->

     

       351
       351
       +
             Prompt.create_argument ~name ?description:desc ~required ()

     

       352
       352
       +
           ) arguments in

     

       353
       353
       +
           let handler' ctx args =

     

       354
       354
       +
             try

     

       355
       355
       +
               Ok (handler args)

     

       356
       356
       +
             with exn ->

     

       357
       357
       +
               Error (Printexc.to_string exn)

     

       358
       358
       +
           in

     

       359
       359
       +
           let prompt = Prompt.create

     

       360
       360
       +
             ~name

     

       361
       361
       +
             ?description

     

       362
       362
       +
             ~arguments:prompt_args

     

       363
       363
       +
             ~handler:handler'

     

       364
       364
       +
             ()

     

       365
       365
       +
           in

     

       366
       366
       +
           server.prompts <- prompt :: server.prompts;

     

       367
       367
       +
           prompt

     

       368
       368
       +
           

     

       369
       369
       +
         (* Run the server *)

     

       370
       370
       +
         let run ?with_tools ?with_resources ?with_prompts () =

     

       371
       371
       +
           let with_tools = match with_tools with

     

       372
       372
       +
             | Some b -> b

     

       373
       373
       +
             | None -> server.tools <> []

     

       374
       374
       +
           in

     

       375
       375
       +
           let with_resources = match with_resources with

     

       376
       376
       +
             | Some b -> b

     

       377
       377
       +
             | None -> server.resources <> []

     

       378
       378
       +
           in

     

       379
       379
       +
           let with_prompts = match with_prompts with

     

       380
       380
       +
             | Some b -> b

     

       381
       381
       +
             | None -> server.prompts <> []

     

       382
       382
       +
           in

     

       383
       383
       +
           let capabilities = Server.default_capabilities ~with_tools ~with_resources ~with_prompts () in

     

       384
       384
       +
           server.capabilities <- capabilities;

     

       385
       385
       +
           Log.info "Starting server...";

     

       386
       386
       +
           Log.info (Printf.sprintf "Server info: %s v%s" server.name 

     

       387
       387
       +
                     (match S.version with Some v -> v | None -> "unknown"));

     

       388
       388
       +
           Printexc.record_backtrace true;

     

       389
       389
       +
           set_binary_mode_out stdout false;

     

       390
       390
       +
           Log.info "This is just a placeholder server implementation."

     

       391
       391
       +
       end

+137

lib/mcp_sdk.mli

···

       1
       1
       +
       (** MCP SDK - Model Context Protocol SDK for OCaml *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Mcp

     

       4
       4
       +
       open Jsonrpc

     

       5
       5
       +
       

     

       6
       6
       +
       (** SDK version *)

     

       7
       7
       +
       val version : string

     

       8
       8
       +
       

     

       9
       9
       +
       (** Logging utilities *)

     

       10
       10
       +
       module Log : sig

     

       11
       11
       +
         type level = Debug | Info | Warning | Error

     

       12
       12
       +
       

     

       13
       13
       +
         val string_of_level : level -> string

     

       14
       14
       +
       

     

       15
       15
       +
         val log : level -> string -> unit

     

       16
       16
       +
         val debug : string -> unit

     

       17
       17
       +
         val info : string -> unit

     

       18
       18
       +
         val warning : string -> unit

     

       19
       19
       +
         val error : string -> unit

     

       20
       20
       +
       end

     

       21
       21
       +
       

     

       22
       22
       +
       (** Context for tools and resources *)

     

       23
       23
       +
       module Context : sig

     

       24
       24
       +
         type t = {

     

       25
       25
       +
           request_id: RequestId.t option;

     

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

     

       27
       27
       +
           mutable progress_token: ProgressToken.t option;

     

       28
       28
       +
         }

     

       29
       29
       +
       

     

       30
       30
       +
         val create : ?request_id:RequestId.t -> ?lifespan_context:(string * Json.t) list -> unit -> t

     

       31
       31
       +
         val get_context_value : t -> string -> Json.t option

     

       32
       32
       +
         val report_progress : t -> float -> float -> JSONRPCMessage.t option

     

       33
       33
       +
       end

     

       34
       34
       +
       

     

       35
       35
       +
       (** Tools for the MCP server *)

     

       36
       36
       +
       module Tool : sig

     

       37
       37
       +
         type handler = Context.t -> Json.t -> (Json.t, string) result

     

       38
       38
       +
       

     

       39
       39
       +
         type t = {

     

       40
       40
       +
           name: string;

     

       41
       41
       +
           description: string option;

     

       42
       42
       +
           input_schema: Json.t;

     

       43
       43
       +
           handler: handler;

     

       44
       44
       +
         }

     

       45
       45
       +
       

     

       46
       46
       +
         val create : name:string -> ?description:string -> input_schema:Json.t -> handler:handler -> unit -> t

     

       47
       47
       +
         val to_json : t -> Json.t

     

       48
       48
       +
       end

     

       49
       49
       +
       

     

       50
       50
       +
       (** Resources for the MCP server *)

     

       51
       51
       +
       module Resource : sig

     

       52
       52
       +
         type handler = Context.t -> string list -> (string, string) result

     

       53
       53
       +
       

     

       54
       54
       +
         type t = {

     

       55
       55
       +
           uri_template: string;

     

       56
       56
       +
           description: string option;

     

       57
       57
       +
           mime_type: string option;

     

       58
       58
       +
           handler: handler;

     

       59
       59
       +
         }

     

       60
       60
       +
       

     

       61
       61
       +
         val create : uri_template:string -> ?description:string -> ?mime_type:string -> handler:handler -> unit -> t

     

       62
       62
       +
         val to_json : t -> Json.t

     

       63
       63
       +
       end

     

       64
       64
       +
       

     

       65
       65
       +
       (** Prompts for the MCP server *)

     

       66
       66
       +
       module Prompt : sig

     

       67
       67
       +
         type argument = {

     

       68
       68
       +
           name: string;

     

       69
       69
       +
           description: string option;

     

       70
       70
       +
           required: bool;

     

       71
       71
       +
         }

     

       72
       72
       +
       

     

       73
       73
       +
         type message = {

     

       74
       74
       +
           role: Role.t;

     

       75
       75
       +
           content: content;

     

       76
       76
       +
         }

     

       77
       77
       +
       

     

       78
       78
       +
         type handler = Context.t -> (string * string) list -> (message list, string) result

     

       79
       79
       +
       

     

       80
       80
       +
         type t = {

     

       81
       81
       +
           name: string;

     

       82
       82
       +
           description: string option;

     

       83
       83
       +
           arguments: argument list;

     

       84
       84
       +
           handler: handler;

     

       85
       85
       +
         }

     

       86
       86
       +
       

     

       87
       87
       +
         val create : name:string -> ?description:string -> ?arguments:argument list -> handler:handler -> unit -> t

     

       88
       88
       +
         val create_argument : name:string -> ?description:string -> ?required:bool -> unit -> argument

     

       89
       89
       +
         val to_json : t -> Json.t

     

       90
       90
       +
       end

     

       91
       91
       +
       

     

       92
       92
       +
       (** Server implementation *)

     

       93
       93
       +
       module Server : sig

     

       94
       94
       +
         type startup_hook = unit -> unit

     

       95
       95
       +
         type shutdown_hook = unit -> unit

     

       96
       96
       +
       

     

       97
       97
       +
         type t = {

     

       98
       98
       +
           name: string;

     

       99
       99
       +
           version: string;

     

       100
       100
       +
           protocol_version: string;

     

       101
       101
       +
           mutable capabilities: Json.t;

     

       102
       102
       +
           mutable tools: Tool.t list;

     

       103
       103
       +
           mutable resources: Resource.t list;

     

       104
       104
       +
           mutable prompts: Prompt.t list;

     

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

     

       106
       106
       +
           startup_hook: startup_hook option;

     

       107
       107
       +
           shutdown_hook: shutdown_hook option;

     

       108
       108
       +
         }

     

       109
       109
       +
       

     

       110
       110
       +
         val create : name:string -> ?version:string -> ?protocol_version:string -> ?startup_hook:startup_hook -> ?shutdown_hook:shutdown_hook -> unit -> t

     

       111
       111
       +
         val register_tool : t -> Tool.t -> unit

     

       112
       112
       +
         val register_resource : t -> Resource.t -> unit

     

       113
       113
       +
         val register_prompt : t -> Prompt.t -> unit

     

       114
       114
       +
         val default_capabilities : ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> Json.t

     

       115
       115
       +
         val update_capabilities : t -> Json.t -> unit

     

       116
       116
       +
       

     

       117
       117
       +
         val process_message : t -> Json.t -> JSONRPCMessage.t option

     

       118
       118
       +
         val run : t -> unit

     

       119
       119
       +
       end

     

       120
       120
       +
       

     

       121
       121
       +
       (** Helper functions for creating common objects *)

     

       122
       122
       +
       val make_text_content : string -> content

     

       123
       123
       +
       val make_tool_schema : (string * string * string) list -> string list -> Json.t

     

       124
       124
       +
       

     

       125
       125
       +
       (** Syntax sugar for creating an MCP server *)

     

       126
       126
       +
       module MakeServer : functor (S : sig

     

       127
       127
       +
         val name : string

     

       128
       128
       +
         val version : string option

     

       129
       129
       +
       end) -> sig

     

       130
       130
       +
         val _config : string * string option  (* Used to prevent unused parameter warning *)

     

       131
       131
       +
         val server : Server.t

     

       132
       132
       +
       

     

       133
       133
       +
         val tool : ?name:string option -> ?description:string -> ?schema_properties:(string * string * string) list -> ?schema_required:string list -> (Json.t -> Json.t) -> Tool.t

     

       134
       134
       +
         val resource : ?uri_template:string option -> ?description:string -> ?mime_type:string -> (string list -> string) -> Resource.t

     

       135
       135
       +
         val prompt : ?name:string option -> ?description:string -> ?arguments:(string * string option * bool) list -> ((string * string) list -> Prompt.message list) -> Prompt.t

     

       136
       136
       +
         val run : ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> unit

     

       137
       137
       +
       end