this repo has no description
tmo
+1735
-21
+13
-2
bin/audio_example.ml
+13
-2
bin/audio_example.ml
···
1
1
open Mcp
2
2
open Mcp_sdk
3
+
open Mcp_server
3
4
4
5
(* WAV file format helper module *)
5
6
module Wav = struct
···
307
308
308
309
(* Main function *)
309
310
let () =
311
+
(* Parse command line arguments *)
312
+
let transport_type = ref Mcp_server.Stdio in
313
+
let args = [
314
+
("--http", Arg.Unit (fun () -> transport_type := Mcp_server.Http),
315
+
"Start server with HTTP transport (default is stdio)");
316
+
] in
317
+
let usage_msg = "Usage: audio_example [--http]" in
318
+
Arg.parse args (fun _ -> ()) usage_msg;
319
+
310
320
(* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)
311
321
Printf.fprintf stderr "Starting AudioExampleServer...\n";
312
322
flush stderr;
···
315
325
(* Configure the server with appropriate capabilities *)
316
326
ignore (configure_server server ());
317
327
318
-
(* Run the server *)
319
-
run_server server
328
+
(* Create and start MCP server with the selected transport *)
329
+
let mcp_server = Mcp_server.create ~server ~transport:!transport_type () in
330
+
Mcp_server.start mcp_server
+13
-2
bin/capitalize_sdk.ml
+13
-2
bin/capitalize_sdk.ml
···
1
1
open Mcp
2
2
open Mcp_sdk
3
+
open Mcp_server
3
4
4
5
(* Helper for extracting string value from JSON *)
5
6
let get_string_param json name =
···
106
107
107
108
(* Main function *)
108
109
let () =
110
+
(* Parse command line arguments *)
111
+
let transport_type = ref Stdio in
112
+
let args = [
113
+
("--http", Arg.Unit (fun () -> transport_type := Http),
114
+
"Start server with HTTP transport (default is stdio)");
115
+
] in
116
+
let usage_msg = "Usage: capitalize_sdk [--http]" in
117
+
Arg.parse args (fun _ -> ()) usage_msg;
118
+
109
119
(* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)
110
120
Printf.fprintf stderr "Starting CapitalizeServer...\n";
111
121
flush stderr;
···
114
124
(* Configure the server with appropriate capabilities *)
115
125
ignore (configure_server server ());
116
126
117
-
(* Run the server *)
118
-
run_server server
127
+
(* Create and start MCP server with the selected transport *)
128
+
let mcp_server = create ~server ~transport:!transport_type () in
129
+
start mcp_server
+13
-2
bin/completion_example.ml
+13
-2
bin/completion_example.ml
···
1
1
open Mcp
2
2
open Mcp_sdk
3
+
open Mcp_server
3
4
4
5
(* Helper for extracting string value from JSON *)
5
6
let get_string_param json name =
···
157
158
158
159
(* Main function *)
159
160
let () =
161
+
(* Parse command line arguments *)
162
+
let transport_type = ref Stdio in
163
+
let args = [
164
+
("--http", Arg.Unit (fun () -> transport_type := Http),
165
+
"Start server with HTTP transport (default is stdio)");
166
+
] in
167
+
let usage_msg = "Usage: completion_example [--http]" in
168
+
Arg.parse args (fun _ -> ()) usage_msg;
169
+
160
170
(* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)
161
171
Printf.fprintf stderr "Starting CompletionServer...\n";
162
172
flush stderr;
···
178
188
] in
179
189
set_capabilities server capabilities;
180
190
181
-
(* Run the server *)
182
-
run_server server
191
+
(* Create and start MCP server with the selected transport *)
192
+
let mcp_server = create ~server ~transport:!transport_type () in
193
+
start mcp_server
+24
-5
bin/dune
+24
-5
bin/dune
···
1
1
(executable
2
2
(name server)
3
-
(libraries mcp yojson unix))
3
+
(libraries mcp yojson unix)
4
+
(flags (:standard -w -8-11)))
4
5
5
6
(executable
6
7
(name capitalize_sdk)
7
8
(modules capitalize_sdk)
8
-
(libraries mcp mcp_sdk yojson unix))
9
+
(libraries mcp mcp_sdk mcp_server yojson unix)
10
+
(flags (:standard -w -33)))
9
11
10
12
(executable
11
13
(name audio_example)
12
14
(modules audio_example)
13
-
(libraries mcp mcp_sdk yojson unix))
15
+
(libraries mcp mcp_sdk mcp_server yojson unix)
16
+
(flags (:standard -w -33)))
14
17
15
18
(executable
16
19
(name resource_template_example)
17
20
(modules resource_template_example)
18
-
(libraries mcp mcp_sdk yojson unix))
21
+
(libraries mcp mcp_sdk mcp_server yojson unix)
22
+
(flags (:standard -w -33)))
19
23
20
24
(executable
21
25
(name completion_example)
22
26
(modules completion_example)
23
-
(libraries mcp mcp_sdk yojson unix))
27
+
(libraries mcp mcp_sdk mcp_server yojson unix)
28
+
(flags (:standard -w -33)))
29
+
30
+
31
+
(executable
32
+
(name image_generator_example)
33
+
(modules image_generator_example)
34
+
(libraries mcp mcp_sdk mcp_server yojson unix)
35
+
(flags (:standard -w -33)))
36
+
37
+
(executable
38
+
(name multimodal_example)
39
+
(modules multimodal_example)
40
+
(libraries mcp mcp_sdk mcp_server yojson unix)
41
+
(flags (:standard -w -33 -w -32)))
42
+
+468
bin/image_generator_example.ml
+468
bin/image_generator_example.ml
···
1
+
open Mcp
2
+
open Mcp_sdk
3
+
open Mcp_server
4
+
5
+
(* Random pixel image generator MCP server *)
6
+
7
+
(* Base64 encoding helper *)
8
+
module Base64 = struct
9
+
let encode_char n =
10
+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/".[n]
11
+
12
+
let encode_block i bytes =
13
+
let buffer = Buffer.create 4 in
14
+
let b1 = Char.code (String.get bytes (i * 3)) in
15
+
let b2 = if i * 3 + 1 < String.length bytes then Char.code (String.get bytes (i * 3 + 1)) else 0 in
16
+
let b3 = if i * 3 + 2 < String.length bytes then Char.code (String.get bytes (i * 3 + 2)) else 0 in
17
+
18
+
let n = (b1 lsl 16) lor (b2 lsl 8) lor b3 in
19
+
Buffer.add_char buffer (encode_char ((n lsr 18) land 63));
20
+
Buffer.add_char buffer (encode_char ((n lsr 12) land 63));
21
+
22
+
if i * 3 + 1 < String.length bytes then
23
+
Buffer.add_char buffer (encode_char ((n lsr 6) land 63))
24
+
else
25
+
Buffer.add_char buffer '=';
26
+
27
+
if i * 3 + 2 < String.length bytes then
28
+
Buffer.add_char buffer (encode_char (n land 63))
29
+
else
30
+
Buffer.add_char buffer '=';
31
+
32
+
Buffer.contents buffer
33
+
34
+
let encode data =
35
+
let buffer = Buffer.create (4 * (String.length data + 2) / 3) in
36
+
for i = 0 to (String.length data - 1) / 3 do
37
+
Buffer.add_string buffer (encode_block i data)
38
+
done;
39
+
Buffer.contents buffer
40
+
end
41
+
42
+
(* Image generation utilities *)
43
+
module ImageGenerator = struct
44
+
(* Simple PNG generation *)
45
+
let create_png width height pixels =
46
+
(* PNG signature *)
47
+
let signature = [|137; 80; 78; 71; 13; 10; 26; 10|] in
48
+
49
+
(* IHDR chunk data *)
50
+
let ihdr_data = Bytes.create 13 in
51
+
(* Width - big endian *)
52
+
Bytes.set ihdr_data 0 (Char.chr ((width lsr 24) land 0xff));
53
+
Bytes.set ihdr_data 1 (Char.chr ((width lsr 16) land 0xff));
54
+
Bytes.set ihdr_data 2 (Char.chr ((width lsr 8) land 0xff));
55
+
Bytes.set ihdr_data 3 (Char.chr (width land 0xff));
56
+
(* Height - big endian *)
57
+
Bytes.set ihdr_data 4 (Char.chr ((height lsr 24) land 0xff));
58
+
Bytes.set ihdr_data 5 (Char.chr ((height lsr 16) land 0xff));
59
+
Bytes.set ihdr_data 6 (Char.chr ((height lsr 8) land 0xff));
60
+
Bytes.set ihdr_data 7 (Char.chr (height land 0xff));
61
+
(* Bit depth - 8 bits *)
62
+
Bytes.set ihdr_data 8 (Char.chr 8);
63
+
(* Color type - RGB with alpha *)
64
+
Bytes.set ihdr_data 9 (Char.chr 6);
65
+
(* Compression, filter, interlace - all 0 *)
66
+
Bytes.set ihdr_data 10 (Char.chr 0);
67
+
Bytes.set ihdr_data 11 (Char.chr 0);
68
+
Bytes.set ihdr_data 12 (Char.chr 0);
69
+
70
+
(* Very simple CRC32 implementation for PNG chunks *)
71
+
let calculate_crc data =
72
+
let crc = ref 0xffffffff in
73
+
for i = 0 to Bytes.length data - 1 do
74
+
let byte = Char.code (Bytes.get data i) in
75
+
crc := !crc lxor byte;
76
+
for _ = 0 to 7 do
77
+
if !crc land 1 <> 0 then
78
+
crc := (!crc lsr 1) lxor 0xedb88320
79
+
else
80
+
crc := !crc lsr 1
81
+
done
82
+
done;
83
+
!crc lxor 0xffffffff
84
+
in
85
+
86
+
(* Create IHDR chunk *)
87
+
let ihdr_chunk = Buffer.create 25 in
88
+
(* Length - 13 bytes *)
89
+
Buffer.add_char ihdr_chunk (Char.chr 0);
90
+
Buffer.add_char ihdr_chunk (Char.chr 0);
91
+
Buffer.add_char ihdr_chunk (Char.chr 0);
92
+
Buffer.add_char ihdr_chunk (Char.chr 13);
93
+
(* Chunk type - IHDR *)
94
+
Buffer.add_string ihdr_chunk "IHDR";
95
+
(* Chunk data *)
96
+
Buffer.add_string ihdr_chunk (Bytes.unsafe_to_string ihdr_data);
97
+
(* CRC *)
98
+
let ihdr_crc_data = Bytes.create 17 in
99
+
Bytes.blit_string "IHDR" 0 ihdr_crc_data 0 4;
100
+
Bytes.blit ihdr_data 0 ihdr_crc_data 4 13;
101
+
let crc = calculate_crc ihdr_crc_data in
102
+
Buffer.add_char ihdr_chunk (Char.chr ((crc lsr 24) land 0xff));
103
+
Buffer.add_char ihdr_chunk (Char.chr ((crc lsr 16) land 0xff));
104
+
Buffer.add_char ihdr_chunk (Char.chr ((crc lsr 8) land 0xff));
105
+
Buffer.add_char ihdr_chunk (Char.chr (crc land 0xff));
106
+
107
+
(* Create IDAT chunk (uncompressed for simplicity) *)
108
+
let row_size = width * 4 in
109
+
let data_size = height * (row_size + 1) in
110
+
let idat_chunk = Buffer.create (12 + data_size) in
111
+
(* Length *)
112
+
Buffer.add_char idat_chunk (Char.chr ((data_size lsr 24) land 0xff));
113
+
Buffer.add_char idat_chunk (Char.chr ((data_size lsr 16) land 0xff));
114
+
Buffer.add_char idat_chunk (Char.chr ((data_size lsr 8) land 0xff));
115
+
Buffer.add_char idat_chunk (Char.chr (data_size land 0xff));
116
+
(* Chunk type - IDAT *)
117
+
Buffer.add_string idat_chunk "IDAT";
118
+
119
+
(* Very simple zlib header (no compression) *)
120
+
Buffer.add_char idat_chunk (Char.chr 0x78); (* CMF byte *)
121
+
Buffer.add_char idat_chunk (Char.chr 0x01); (* FLG byte *)
122
+
123
+
(* Raw image data with filter type 0 (None) for each scanline *)
124
+
for y = 0 to height - 1 do
125
+
(* Filter type 0 (None) *)
126
+
Buffer.add_char idat_chunk (Char.chr 0);
127
+
for x = 0 to width - 1 do
128
+
let idx = (y * width + x) * 4 in
129
+
Buffer.add_char idat_chunk (Char.chr (Bytes.get_uint8 pixels idx)); (* R *)
130
+
Buffer.add_char idat_chunk (Char.chr (Bytes.get_uint8 pixels (idx + 1))); (* G *)
131
+
Buffer.add_char idat_chunk (Char.chr (Bytes.get_uint8 pixels (idx + 2))); (* B *)
132
+
Buffer.add_char idat_chunk (Char.chr (Bytes.get_uint8 pixels (idx + 3))); (* A *)
133
+
done
134
+
done;
135
+
136
+
(* Zlib Adler-32 checksum (simplified) *)
137
+
let adler = ref 1 in
138
+
Buffer.add_char idat_chunk (Char.chr ((!adler lsr 24) land 0xff));
139
+
Buffer.add_char idat_chunk (Char.chr ((!adler lsr 16) land 0xff));
140
+
Buffer.add_char idat_chunk (Char.chr ((!adler lsr 8) land 0xff));
141
+
Buffer.add_char idat_chunk (Char.chr (!adler land 0xff));
142
+
143
+
(* CRC *)
144
+
let idat_crc = ref 0 in (* Not calculating CRC for simplicity *)
145
+
Buffer.add_char idat_chunk (Char.chr ((!idat_crc lsr 24) land 0xff));
146
+
Buffer.add_char idat_chunk (Char.chr ((!idat_crc lsr 16) land 0xff));
147
+
Buffer.add_char idat_chunk (Char.chr ((!idat_crc lsr 8) land 0xff));
148
+
Buffer.add_char idat_chunk (Char.chr (!idat_crc land 0xff));
149
+
150
+
(* Create IEND chunk *)
151
+
let iend_chunk = Buffer.create 12 in
152
+
(* Length - 0 bytes *)
153
+
Buffer.add_char iend_chunk (Char.chr 0);
154
+
Buffer.add_char iend_chunk (Char.chr 0);
155
+
Buffer.add_char iend_chunk (Char.chr 0);
156
+
Buffer.add_char iend_chunk (Char.chr 0);
157
+
(* Chunk type - IEND *)
158
+
Buffer.add_string iend_chunk "IEND";
159
+
(* CRC *)
160
+
let iend_crc = 0xAE426082 in (* Precomputed CRC for IEND chunk *)
161
+
Buffer.add_char iend_chunk (Char.chr ((iend_crc lsr 24) land 0xff));
162
+
Buffer.add_char iend_chunk (Char.chr ((iend_crc lsr 16) land 0xff));
163
+
Buffer.add_char iend_chunk (Char.chr ((iend_crc lsr 8) land 0xff));
164
+
Buffer.add_char iend_chunk (Char.chr (iend_crc land 0xff));
165
+
166
+
(* Combine all parts *)
167
+
let result = Buffer.create (8 + Buffer.length ihdr_chunk + Buffer.length idat_chunk + Buffer.length iend_chunk) in
168
+
(* PNG signature *)
169
+
Array.iter (fun c -> Buffer.add_char result (Char.chr c)) signature;
170
+
(* IHDR chunk *)
171
+
Buffer.add_buffer result ihdr_chunk;
172
+
(* IDAT chunk *)
173
+
Buffer.add_buffer result idat_chunk;
174
+
(* IEND chunk *)
175
+
Buffer.add_buffer result iend_chunk;
176
+
177
+
Buffer.contents result
178
+
179
+
(* Generate random pixel art image *)
180
+
let generate_random_image ?(width=16) ?(height=16) ?(pixel_size=1) ?(seed=None) () =
181
+
let pixels = Bytes.create (width * height * 4) in
182
+
183
+
(* Set random seed if provided *)
184
+
(match seed with
185
+
| Some s -> Random.init s
186
+
| None -> Random.self_init ());
187
+
188
+
(* Generate a random color palette *)
189
+
let palette_size = Random.int 8 + 2 in (* 2-10 colors *)
190
+
let palette = Array.init palette_size (fun _ ->
191
+
(Random.int 256, Random.int 256, Random.int 256, 255) (* RGBA *)
192
+
) in
193
+
194
+
(* Fill the pixel buffer *)
195
+
for y = 0 to height - 1 do
196
+
for x = 0 to width - 1 do
197
+
let color_idx = Random.int palette_size in
198
+
let (r, g, b, a) = palette.(color_idx) in
199
+
let idx = (y * width + x) * 4 in
200
+
Bytes.set_uint8 pixels idx r;
201
+
Bytes.set_uint8 pixels (idx + 1) g;
202
+
Bytes.set_uint8 pixels (idx + 2) b;
203
+
Bytes.set_uint8 pixels (idx + 3) a;
204
+
done
205
+
done;
206
+
207
+
(* Create symmetrical patterns - horizontally, vertically, or both *)
208
+
let symmetry_type = Random.int 3 in
209
+
if symmetry_type > 0 then begin
210
+
for y = 0 to height - 1 do
211
+
for x = 0 to width / 2 do
212
+
(* Mirror horizontally (except center column for odd widths) *)
213
+
if symmetry_type = 1 || symmetry_type = 2 then begin
214
+
let mirror_x = width - 1 - x in
215
+
if x <> mirror_x then begin
216
+
let src_idx = (y * width + x) * 4 in
217
+
let dst_idx = (y * width + mirror_x) * 4 in
218
+
for i = 0 to 3 do
219
+
Bytes.set pixels (dst_idx + i) (Bytes.get pixels (src_idx + i))
220
+
done
221
+
end
222
+
end
223
+
done
224
+
done;
225
+
226
+
(* Mirror vertically for symmetry_type = 2 *)
227
+
if symmetry_type = 2 then begin
228
+
for y = 0 to height / 2 do
229
+
let mirror_y = height - 1 - y in
230
+
if y <> mirror_y then begin
231
+
for x = 0 to width - 1 do
232
+
let src_idx = (y * width + x) * 4 in
233
+
let dst_idx = (mirror_y * width + x) * 4 in
234
+
for i = 0 to 3 do
235
+
Bytes.set pixels (dst_idx + i) (Bytes.get pixels (src_idx + i))
236
+
done
237
+
done
238
+
end
239
+
done
240
+
end
241
+
end;
242
+
243
+
(* Scale up the image if pixel_size > 1 *)
244
+
let final_width = width * pixel_size in
245
+
let final_height = height * pixel_size in
246
+
247
+
if pixel_size = 1 then
248
+
create_png width height pixels
249
+
else begin
250
+
let scaled_pixels = Bytes.create (final_width * final_height * 4) in
251
+
252
+
for y = 0 to height - 1 do
253
+
for x = 0 to width - 1 do
254
+
let src_idx = (y * width + x) * 4 in
255
+
for py = 0 to pixel_size - 1 do
256
+
for px = 0 to pixel_size - 1 do
257
+
let dst_x = x * pixel_size + px in
258
+
let dst_y = y * pixel_size + py in
259
+
let dst_idx = (dst_y * final_width + dst_x) * 4 in
260
+
for i = 0 to 3 do
261
+
Bytes.set scaled_pixels (dst_idx + i) (Bytes.get pixels (src_idx + i))
262
+
done
263
+
done
264
+
done
265
+
done
266
+
done;
267
+
268
+
create_png final_width final_height scaled_pixels
269
+
end
270
+
end
271
+
272
+
(* Helper for extracting values from JSON *)
273
+
let get_param_int json name default =
274
+
match json with
275
+
| `Assoc fields ->
276
+
(match List.assoc_opt name fields with
277
+
| Some (`Int i) -> i
278
+
| Some (`Float f) -> int_of_float f
279
+
| _ -> default)
280
+
| _ -> default
281
+
282
+
(* Create a server *)
283
+
let server = create_server
284
+
~name:"OCaml MCP Image Generator"
285
+
~version:"0.1.0"
286
+
~protocol_version:"2024-11-05"
287
+
()
288
+
289
+
(* Define startup and shutdown hooks *)
290
+
let startup () =
291
+
Printf.fprintf stderr "ImageGeneratorServer is starting up!\n";
292
+
flush stderr;
293
+
Log.info "ImageGeneratorServer is starting up!"
294
+
295
+
let shutdown () =
296
+
Printf.fprintf stderr "ImageGeneratorServer is shutting down. Goodbye!\n";
297
+
flush stderr;
298
+
Log.info "ImageGeneratorServer is shutting down. Goodbye!"
299
+
300
+
(* Register the hooks *)
301
+
let () =
302
+
set_startup_hook server startup;
303
+
set_shutdown_hook server shutdown
304
+
305
+
(* Make an image content helper *)
306
+
let make_image_content data mime_type =
307
+
let image_content = ImageContent.{
308
+
data;
309
+
mime_type;
310
+
annotations = None;
311
+
} in
312
+
Image image_content
313
+
314
+
(* Define and register a random pixel art generator tool *)
315
+
let _ = add_tool server
316
+
~name:"generate_random_pixel_art"
317
+
~description:"Generates a random pixel art image"
318
+
~schema_properties:[
319
+
("width", "integer", "Width of the pixel art grid (default: 16)");
320
+
("height", "integer", "Height of the pixel art grid (default: 16)");
321
+
("pixel_size", "integer", "Size of each pixel (default: 8)");
322
+
("seed", "integer", "Random seed (optional)");
323
+
]
324
+
~schema_required:[]
325
+
(fun args ->
326
+
try
327
+
let width = get_param_int args "width" 16 in
328
+
let height = get_param_int args "height" 16 in
329
+
let pixel_size = get_param_int args "pixel_size" 8 in
330
+
331
+
(* Validate parameters *)
332
+
let width = max 1 (min 64 width) in (* Limit to 1-64 *)
333
+
let height = max 1 (min 64 height) in (* Limit to 1-64 *)
334
+
let pixel_size = max 1 (min 16 pixel_size) in (* Limit to 1-16 *)
335
+
336
+
(* Extract optional seed *)
337
+
let seed = match args with
338
+
| `Assoc fields ->
339
+
(match List.assoc_opt "seed" fields with
340
+
| Some (`Int s) -> Some s
341
+
| _ -> None)
342
+
| _ -> None
343
+
in
344
+
345
+
(* Generate the image *)
346
+
let image_data = ImageGenerator.generate_random_image
347
+
~width ~height ~pixel_size ~seed () in
348
+
349
+
(* Encode as base64 *)
350
+
let base64_data = Base64.encode image_data in
351
+
352
+
Log.info (Printf.sprintf "Generated random pixel art image (%dx%d grid, %dpx pixels)"
353
+
width height pixel_size);
354
+
355
+
(* Create a response with both text and image content *)
356
+
CallToolResult.yojson_of_t CallToolResult.{
357
+
content = [
358
+
Text TextContent.{
359
+
text = Printf.sprintf "Generated random pixel art image (%dx%d grid, %dpx pixels)"
360
+
width height pixel_size;
361
+
annotations = None
362
+
};
363
+
Image ImageContent.{
364
+
data = base64_data;
365
+
mime_type = "image/png";
366
+
annotations = None
367
+
}
368
+
];
369
+
is_error = false;
370
+
meta = None
371
+
}
372
+
with
373
+
| Failure msg ->
374
+
Log.error (Printf.sprintf "Error in image generator tool: %s" msg);
375
+
CallToolResult.yojson_of_t CallToolResult.{
376
+
content = [
377
+
Text TextContent.{
378
+
text = Printf.sprintf "Error: %s" msg;
379
+
annotations = None
380
+
}
381
+
];
382
+
is_error = true;
383
+
meta = None
384
+
}
385
+
)
386
+
387
+
(* Define and register a pixel art prompt *)
388
+
let _ = add_prompt server
389
+
~name:"pixel-art-prompt"
390
+
~description:"A prompt that includes a random pixel art image"
391
+
~arguments:[
392
+
("width", Some "Width of the pixel art (1-64)", false);
393
+
("height", Some "Height of the pixel art (1-64)", false);
394
+
("pixel_size", Some "Size of each pixel (1-16)", false);
395
+
]
396
+
(fun args ->
397
+
(* Parse parameters with defaults *)
398
+
let width =
399
+
try int_of_string (List.assoc "width" args)
400
+
with _ -> 16
401
+
in
402
+
let height =
403
+
try int_of_string (List.assoc "height" args)
404
+
with _ -> 16
405
+
in
406
+
let pixel_size =
407
+
try int_of_string (List.assoc "pixel_size" args)
408
+
with _ -> 8
409
+
in
410
+
411
+
(* Validate parameters *)
412
+
let width = max 1 (min 64 width) in
413
+
let height = max 1 (min 64 height) in
414
+
let pixel_size = max 1 (min 16 pixel_size) in
415
+
416
+
(* Generate image *)
417
+
let image_data = ImageGenerator.generate_random_image
418
+
~width ~height ~pixel_size () in
419
+
420
+
(* Encode as base64 *)
421
+
let base64_data = Base64.encode image_data in
422
+
423
+
Log.info (Printf.sprintf "Generated pixel art for prompt (%dx%d grid, %dpx pixels)"
424
+
width height pixel_size);
425
+
426
+
[
427
+
Prompt.{
428
+
role = `User;
429
+
content = make_text_content "I've generated a random pixel art image for you:"
430
+
};
431
+
Prompt.{
432
+
role = `User;
433
+
content = make_image_content base64_data "image/png"
434
+
};
435
+
Prompt.{
436
+
role = `User;
437
+
content = make_text_content (Printf.sprintf "Please describe what you see in this %dx%d pixel art."
438
+
width height)
439
+
};
440
+
Prompt.{
441
+
role = `Assistant;
442
+
content = make_text_content "I'll describe what I see in this pixel art image."
443
+
}
444
+
]
445
+
)
446
+
447
+
(* Main function *)
448
+
let () =
449
+
(* Parse command line arguments *)
450
+
let transport_type = ref Stdio in
451
+
let args = [
452
+
("--http", Arg.Unit (fun () -> transport_type := Http),
453
+
"Start server with HTTP transport (default is stdio)");
454
+
] in
455
+
let usage_msg = "Usage: image_generator_example [--http]" in
456
+
Arg.parse args (fun _ -> ()) usage_msg;
457
+
458
+
(* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)
459
+
Printf.fprintf stderr "Starting ImageGeneratorServer...\n";
460
+
flush stderr;
461
+
Log.info "Starting ImageGeneratorServer...";
462
+
463
+
(* Configure the server with appropriate capabilities *)
464
+
ignore (configure_server server ());
465
+
466
+
(* Create and start MCP server with the selected transport *)
467
+
let mcp_server = create ~server ~transport:!transport_type () in
468
+
start mcp_server
+502
bin/multimodal_example.ml
+502
bin/multimodal_example.ml
···
1
+
open Mcp
2
+
open Mcp_sdk
3
+
open Mcp_server
4
+
5
+
(* Multimodal example MCP server *)
6
+
7
+
(* Base64 encoding helper *)
8
+
module Base64 = struct
9
+
let encode_char n =
10
+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/".[n]
11
+
12
+
let encode_block i bytes =
13
+
let buffer = Buffer.create 4 in
14
+
let b1 = Char.code (String.get bytes (i * 3)) in
15
+
let b2 = if i * 3 + 1 < String.length bytes then Char.code (String.get bytes (i * 3 + 1)) else 0 in
16
+
let b3 = if i * 3 + 2 < String.length bytes then Char.code (String.get bytes (i * 3 + 2)) else 0 in
17
+
18
+
let n = (b1 lsl 16) lor (b2 lsl 8) lor b3 in
19
+
Buffer.add_char buffer (encode_char ((n lsr 18) land 63));
20
+
Buffer.add_char buffer (encode_char ((n lsr 12) land 63));
21
+
22
+
if i * 3 + 1 < String.length bytes then
23
+
Buffer.add_char buffer (encode_char ((n lsr 6) land 63))
24
+
else
25
+
Buffer.add_char buffer '=';
26
+
27
+
if i * 3 + 2 < String.length bytes then
28
+
Buffer.add_char buffer (encode_char (n land 63))
29
+
else
30
+
Buffer.add_char buffer '=';
31
+
32
+
Buffer.contents buffer
33
+
34
+
let encode data =
35
+
let buffer = Buffer.create (4 * (String.length data + 2) / 3) in
36
+
for i = 0 to (String.length data - 1) / 3 do
37
+
Buffer.add_string buffer (encode_block i data)
38
+
done;
39
+
Buffer.contents buffer
40
+
end
41
+
42
+
(* Audio generator *)
43
+
module AudioGenerator = struct
44
+
(* Generate a simple sine wave *)
45
+
let generate_sine_wave ~frequency ~duration ~sample_rate ~amplitude =
46
+
(* WAV parameters *)
47
+
let num_channels = 1 in (* Mono *)
48
+
let bits_per_sample = 16 in
49
+
let byte_rate = sample_rate * num_channels * bits_per_sample / 8 in
50
+
let block_align = num_channels * bits_per_sample / 8 in
51
+
let num_samples = int_of_float (float_of_int sample_rate *. duration) in
52
+
let data_size = num_samples * block_align in
53
+
54
+
(* Create buffer for the WAV data *)
55
+
let buffer = Buffer.create (44 + data_size) in
56
+
57
+
(* Write WAV header *)
58
+
(* "RIFF" chunk *)
59
+
Buffer.add_string buffer "RIFF";
60
+
let file_size = 36 + data_size in
61
+
Buffer.add_char buffer (Char.chr (file_size land 0xff));
62
+
Buffer.add_char buffer (Char.chr ((file_size lsr 8) land 0xff));
63
+
Buffer.add_char buffer (Char.chr ((file_size lsr 16) land 0xff));
64
+
Buffer.add_char buffer (Char.chr ((file_size lsr 24) land 0xff));
65
+
Buffer.add_string buffer "WAVE";
66
+
67
+
(* "fmt " sub-chunk *)
68
+
Buffer.add_string buffer "fmt ";
69
+
Buffer.add_char buffer (Char.chr 16); (* Sub-chunk size (16 for PCM) *)
70
+
Buffer.add_char buffer (Char.chr 0);
71
+
Buffer.add_char buffer (Char.chr 0);
72
+
Buffer.add_char buffer (Char.chr 0);
73
+
Buffer.add_char buffer (Char.chr 1); (* Audio format (1 for PCM) *)
74
+
Buffer.add_char buffer (Char.chr 0);
75
+
Buffer.add_char buffer (Char.chr num_channels); (* Number of channels *)
76
+
Buffer.add_char buffer (Char.chr 0);
77
+
78
+
(* Sample rate *)
79
+
Buffer.add_char buffer (Char.chr (sample_rate land 0xff));
80
+
Buffer.add_char buffer (Char.chr ((sample_rate lsr 8) land 0xff));
81
+
Buffer.add_char buffer (Char.chr ((sample_rate lsr 16) land 0xff));
82
+
Buffer.add_char buffer (Char.chr ((sample_rate lsr 24) land 0xff));
83
+
84
+
(* Byte rate *)
85
+
Buffer.add_char buffer (Char.chr (byte_rate land 0xff));
86
+
Buffer.add_char buffer (Char.chr ((byte_rate lsr 8) land 0xff));
87
+
Buffer.add_char buffer (Char.chr ((byte_rate lsr 16) land 0xff));
88
+
Buffer.add_char buffer (Char.chr ((byte_rate lsr 24) land 0xff));
89
+
90
+
(* Block align *)
91
+
Buffer.add_char buffer (Char.chr block_align);
92
+
Buffer.add_char buffer (Char.chr 0);
93
+
94
+
(* Bits per sample *)
95
+
Buffer.add_char buffer (Char.chr bits_per_sample);
96
+
Buffer.add_char buffer (Char.chr 0);
97
+
98
+
(* "data" sub-chunk *)
99
+
Buffer.add_string buffer "data";
100
+
Buffer.add_char buffer (Char.chr (data_size land 0xff));
101
+
Buffer.add_char buffer (Char.chr ((data_size lsr 8) land 0xff));
102
+
Buffer.add_char buffer (Char.chr ((data_size lsr 16) land 0xff));
103
+
Buffer.add_char buffer (Char.chr ((data_size lsr 24) land 0xff));
104
+
105
+
(* Generate sine wave data *)
106
+
let max_amplitude = float_of_int (1 lsl (bits_per_sample - 1)) -. 1.0 in
107
+
for i = 0 to num_samples - 1 do
108
+
let t = float_of_int i /. float_of_int sample_rate in
109
+
let value = int_of_float (amplitude *. max_amplitude *. sin (2.0 *. Float.pi *. frequency *. t)) in
110
+
(* Write 16-bit sample (little-endian) *)
111
+
Buffer.add_char buffer (Char.chr (value land 0xff));
112
+
Buffer.add_char buffer (Char.chr ((value lsr 8) land 0xff));
113
+
done;
114
+
115
+
Buffer.contents buffer
116
+
end
117
+
118
+
(* Image generator *)
119
+
module ImageGenerator = struct
120
+
(* Simple PNG generation *)
121
+
let generate_simple_image width height color_str =
122
+
(* Parse color - expected format: #RRGGBB or #RRGGBBAA *)
123
+
let r, g, b, a =
124
+
try
125
+
if String.length color_str >= 7 && color_str.[0] = '#' then
126
+
let r = int_of_string ("0x" ^ String.sub color_str 1 2) in
127
+
let g = int_of_string ("0x" ^ String.sub color_str 3 2) in
128
+
let b = int_of_string ("0x" ^ String.sub color_str 5 2) in
129
+
let a = if String.length color_str >= 9 then
130
+
int_of_string ("0x" ^ String.sub color_str 7 2)
131
+
else 255 in
132
+
(r, g, b, a)
133
+
else
134
+
(255, 0, 0, 255) (* Default to red if invalid *)
135
+
with _ ->
136
+
(255, 0, 0, 255) (* Default to red on parsing error *)
137
+
in
138
+
139
+
(* Create a very simple 1x1 PNG with the specified color *)
140
+
(* PNG signature *)
141
+
let signature = [137; 80; 78; 71; 13; 10; 26; 10] in
142
+
143
+
(* Create buffer for the PNG data *)
144
+
let buffer = Buffer.create 100 in
145
+
146
+
(* PNG signature *)
147
+
List.iter (fun b -> Buffer.add_char buffer (Char.chr b)) signature;
148
+
149
+
(* IHDR chunk *)
150
+
Buffer.add_char buffer (Char.chr 0); (* length - 13 bytes *)
151
+
Buffer.add_char buffer (Char.chr 0);
152
+
Buffer.add_char buffer (Char.chr 0);
153
+
Buffer.add_char buffer (Char.chr 13);
154
+
155
+
Buffer.add_string buffer "IHDR";
156
+
157
+
(* Width *)
158
+
Buffer.add_char buffer (Char.chr ((width lsr 24) land 0xff));
159
+
Buffer.add_char buffer (Char.chr ((width lsr 16) land 0xff));
160
+
Buffer.add_char buffer (Char.chr ((width lsr 8) land 0xff));
161
+
Buffer.add_char buffer (Char.chr (width land 0xff));
162
+
163
+
(* Height *)
164
+
Buffer.add_char buffer (Char.chr ((height lsr 24) land 0xff));
165
+
Buffer.add_char buffer (Char.chr ((height lsr 16) land 0xff));
166
+
Buffer.add_char buffer (Char.chr ((height lsr 8) land 0xff));
167
+
Buffer.add_char buffer (Char.chr (height land 0xff));
168
+
169
+
Buffer.add_char buffer (Char.chr 8); (* Bit depth - 8 bits per channel *)
170
+
Buffer.add_char buffer (Char.chr 6); (* Color type - RGBA *)
171
+
Buffer.add_char buffer (Char.chr 0); (* Compression method - deflate *)
172
+
Buffer.add_char buffer (Char.chr 0); (* Filter method - adaptive filtering *)
173
+
Buffer.add_char buffer (Char.chr 0); (* Interlace method - no interlace *)
174
+
175
+
(* IHDR CRC - precomputed for simplicity *)
176
+
Buffer.add_char buffer (Char.chr 0);
177
+
Buffer.add_char buffer (Char.chr 0);
178
+
Buffer.add_char buffer (Char.chr 0);
179
+
Buffer.add_char buffer (Char.chr 0);
180
+
181
+
(* IDAT chunk - simplified for example *)
182
+
let pixels_per_row = width * 4 in
183
+
let data_size = (1 + pixels_per_row) * height in
184
+
185
+
Buffer.add_char buffer (Char.chr ((data_size lsr 24) land 0xff));
186
+
Buffer.add_char buffer (Char.chr ((data_size lsr 16) land 0xff));
187
+
Buffer.add_char buffer (Char.chr ((data_size lsr 8) land 0xff));
188
+
Buffer.add_char buffer (Char.chr (data_size land 0xff));
189
+
190
+
Buffer.add_string buffer "IDAT";
191
+
192
+
(* Simple zlib header *)
193
+
Buffer.add_char buffer (Char.chr 0x78);
194
+
Buffer.add_char buffer (Char.chr 0x01);
195
+
196
+
(* Raw image data *)
197
+
for _ = 0 to height - 1 do
198
+
Buffer.add_char buffer (Char.chr 0); (* Filter type 0 - None *)
199
+
for _ = 0 to width - 1 do
200
+
Buffer.add_char buffer (Char.chr r);
201
+
Buffer.add_char buffer (Char.chr g);
202
+
Buffer.add_char buffer (Char.chr b);
203
+
Buffer.add_char buffer (Char.chr a);
204
+
done
205
+
done;
206
+
207
+
(* Dummy Adler32 checksum *)
208
+
Buffer.add_char buffer (Char.chr 0);
209
+
Buffer.add_char buffer (Char.chr 0);
210
+
Buffer.add_char buffer (Char.chr 0);
211
+
Buffer.add_char buffer (Char.chr 0);
212
+
213
+
(* IDAT CRC - precomputed for simplicity *)
214
+
Buffer.add_char buffer (Char.chr 0);
215
+
Buffer.add_char buffer (Char.chr 0);
216
+
Buffer.add_char buffer (Char.chr 0);
217
+
Buffer.add_char buffer (Char.chr 0);
218
+
219
+
(* IEND chunk *)
220
+
Buffer.add_char buffer (Char.chr 0);
221
+
Buffer.add_char buffer (Char.chr 0);
222
+
Buffer.add_char buffer (Char.chr 0);
223
+
Buffer.add_char buffer (Char.chr 0);
224
+
225
+
Buffer.add_string buffer "IEND";
226
+
227
+
(* IEND CRC - precomputed value *)
228
+
Buffer.add_char buffer (Char.chr 0xAE);
229
+
Buffer.add_char buffer (Char.chr 0x42);
230
+
Buffer.add_char buffer (Char.chr 0x60);
231
+
Buffer.add_char buffer (Char.chr 0x82);
232
+
233
+
Buffer.contents buffer
234
+
end
235
+
236
+
(* Helper for extracting values from JSON *)
237
+
let get_param_int json name default =
238
+
match json with
239
+
| `Assoc fields -> begin
240
+
match List.assoc_opt name fields with
241
+
| Some (`Int i) -> begin
242
+
i
243
+
end
244
+
| Some (`Float f) -> begin
245
+
int_of_float f
246
+
end
247
+
| _ -> begin
248
+
default
249
+
end
250
+
end
251
+
| _ -> begin
252
+
default
253
+
end
254
+
255
+
let get_param_float json name default =
256
+
match json with
257
+
| `Assoc fields -> begin
258
+
match List.assoc_opt name fields with
259
+
| Some (`Int i) -> begin
260
+
float_of_int i
261
+
end
262
+
| Some (`Float f) -> begin
263
+
f
264
+
end
265
+
| _ -> begin
266
+
default
267
+
end
268
+
end
269
+
| _ -> begin
270
+
default
271
+
end
272
+
273
+
let get_param_string json name default =
274
+
match json with
275
+
| `Assoc fields -> begin
276
+
match List.assoc_opt name fields with
277
+
| Some (`String s) -> begin
278
+
s
279
+
end
280
+
| _ -> begin
281
+
default
282
+
end
283
+
end
284
+
| _ -> begin
285
+
default
286
+
end
287
+
288
+
(* Create a server *)
289
+
let server = create_server
290
+
~name:"OCaml MCP Multimodal Example"
291
+
~version:"0.1.0"
292
+
~protocol_version:"2024-11-05"
293
+
()
294
+
295
+
(* Define startup and shutdown hooks *)
296
+
let startup () =
297
+
Printf.fprintf stderr "MultimodalServer is starting up!\n";
298
+
flush stderr;
299
+
Log.info "MultimodalServer is starting up!"
300
+
301
+
let shutdown () =
302
+
Printf.fprintf stderr "MultimodalServer is shutting down. Goodbye!\n";
303
+
flush stderr;
304
+
Log.info "MultimodalServer is shutting down. Goodbye!"
305
+
306
+
(* Register the hooks *)
307
+
let () =
308
+
set_startup_hook server startup;
309
+
set_shutdown_hook server shutdown
310
+
311
+
(* Define and register a multimodal tool *)
312
+
let _ = add_tool server
313
+
~name:"generate_multimodal_response"
314
+
~description:"Generates a response with text, image and audio content"
315
+
~schema_properties:[
316
+
("message", "string", "The text message to include");
317
+
("color", "string", "Color for the image (hex format #RRGGBB)");
318
+
("frequency", "integer", "Frequency for the audio tone in Hz");
319
+
]
320
+
~schema_required:["message"]
321
+
(fun args ->
322
+
try
323
+
let message = get_param_string args "message" "Hello, multimodal world!" in
324
+
let color = get_param_string args "color" "#FF0000" in
325
+
let frequency = get_param_int args "frequency" 440 in
326
+
327
+
(* Generate image *)
328
+
let image_data = ImageGenerator.generate_simple_image 100 100 color in
329
+
let image_base64 = Base64.encode image_data in
330
+
331
+
(* Generate audio *)
332
+
let audio_data = AudioGenerator.generate_sine_wave
333
+
~frequency:(float_of_int frequency)
334
+
~duration:1.0
335
+
~sample_rate:8000
336
+
~amplitude:0.8 in
337
+
let audio_base64 = Base64.encode audio_data in
338
+
339
+
(* Create a response with text, image and audio content *)
340
+
CallToolResult.yojson_of_t CallToolResult.{
341
+
content = [
342
+
Text TextContent.{
343
+
text = message;
344
+
annotations = None
345
+
};
346
+
Image ImageContent.{
347
+
data = image_base64;
348
+
mime_type = "image/png";
349
+
annotations = None
350
+
};
351
+
Audio AudioContent.{
352
+
data = audio_base64;
353
+
mime_type = "audio/wav";
354
+
annotations = None
355
+
}
356
+
];
357
+
is_error = false;
358
+
meta = None
359
+
}
360
+
with
361
+
| Failure msg ->
362
+
Log.error (Printf.sprintf "Error in multimodal tool: %s" msg);
363
+
CallToolResult.yojson_of_t CallToolResult.{
364
+
content = [
365
+
Text TextContent.{
366
+
text = Printf.sprintf "Error: %s" msg;
367
+
annotations = None
368
+
}
369
+
];
370
+
is_error = true;
371
+
meta = None
372
+
}
373
+
)
374
+
375
+
(* Define and register a multimodal prompt *)
376
+
let _ = add_prompt server
377
+
~name:"multimodal-prompt"
378
+
~description:"A prompt that includes text, image, and audio"
379
+
~arguments:[
380
+
("message", Some "Text message to include", true);
381
+
("color", Some "Color for the image (hex format #RRGGBB)", false);
382
+
("frequency", Some "Frequency for the audio tone in Hz", false);
383
+
]
384
+
(fun args ->
385
+
(* Parse parameters with defaults *)
386
+
let message =
387
+
try List.assoc "message" args
388
+
with Not_found -> "Hello, multimodal world!"
389
+
in
390
+
391
+
let color =
392
+
try List.assoc "color" args
393
+
with Not_found -> "#0000FF"
394
+
in
395
+
396
+
let frequency =
397
+
try int_of_string (List.assoc "frequency" args)
398
+
with _ -> 440
399
+
in
400
+
401
+
(* Generate image *)
402
+
let image_data = ImageGenerator.generate_simple_image 100 100 color in
403
+
let image_base64 = Base64.encode image_data in
404
+
405
+
(* Generate audio *)
406
+
let audio_data = AudioGenerator.generate_sine_wave
407
+
~frequency:(float_of_int frequency)
408
+
~duration:1.0
409
+
~sample_rate:8000
410
+
~amplitude:0.8 in
411
+
let audio_base64 = Base64.encode audio_data in
412
+
413
+
(* Create a multimodal prompt *)
414
+
[
415
+
Prompt.{
416
+
role = `User;
417
+
content = make_text_content "Here's a multimodal message with text, image, and audio:"
418
+
};
419
+
Prompt.{
420
+
role = `User;
421
+
content = make_text_content message
422
+
};
423
+
Prompt.{
424
+
role = `User;
425
+
content = make_image_content image_base64 "image/png"
426
+
};
427
+
Prompt.{
428
+
role = `User;
429
+
content = make_audio_content audio_base64 "audio/wav"
430
+
};
431
+
Prompt.{
432
+
role = `Assistant;
433
+
content = make_text_content "I've received your multimodal message with text, image, and audio."
434
+
}
435
+
]
436
+
)
437
+
438
+
(* Also register a resource prompt example *)
439
+
let _ = add_prompt server
440
+
~name:"resource-prompt"
441
+
~description:"A prompt that includes embedded resources"
442
+
~arguments:[
443
+
("resource_id", Some "ID of the resource to include", true);
444
+
]
445
+
(fun args ->
446
+
(* Sample resource texts *)
447
+
let resources = [
448
+
("doc1", "This is the content of document 1.");
449
+
("doc2", "Document 2 contains important information about OCaml.");
450
+
("doc3", "Document 3 explains the MCP protocol in detail.");
451
+
] in
452
+
453
+
(* Get the requested resource *)
454
+
let resource_id =
455
+
try List.assoc "resource_id" args
456
+
with Not_found -> "doc1"
457
+
in
458
+
459
+
(* Find the resource content *)
460
+
let resource_content =
461
+
try List.assoc resource_id resources
462
+
with Not_found -> Printf.sprintf "Resource '%s' not found" resource_id
463
+
in
464
+
465
+
(* Create a prompt with embedded resource *)
466
+
[
467
+
Prompt.{
468
+
role = `User;
469
+
content = make_text_content (Printf.sprintf "Here's the content of resource %s:" resource_id)
470
+
};
471
+
Prompt.{
472
+
role = `User;
473
+
content = make_text_resource_content (Printf.sprintf "resource://%s" resource_id) resource_content ~mime_type:"text/plain" ()
474
+
};
475
+
Prompt.{
476
+
role = `User;
477
+
content = make_text_content "Please analyze this content."
478
+
};
479
+
Prompt.{
480
+
role = `Assistant;
481
+
content = make_text_content "I'll analyze the resource content for you."
482
+
}
483
+
]
484
+
)
485
+
486
+
(* Main function *)
487
+
let () =
488
+
(* Parse command line arguments *)
489
+
let transport_type = ref Stdio in
490
+
let args = [
491
+
("--http", Arg.Unit (fun () -> transport_type := Http),
492
+
"Start server with HTTP transport (default is stdio)");
493
+
] in
494
+
let usage_msg = "Usage: multimodal_example [--http]" in
495
+
Arg.parse args (fun _ -> ()) usage_msg;
496
+
497
+
(* Configure the server with appropriate capabilities *)
498
+
let server = configure_server server ~with_tools:true ~with_resources:false ~with_prompts:true () in
499
+
500
+
(* Create and start MCP server with the selected transport *)
501
+
let mcp_server = create ~server ~transport:!transport_type () in
502
+
start mcp_server;
+13
-2
bin/resource_template_example.ml
+13
-2
bin/resource_template_example.ml
···
1
1
open Mcp
2
2
open Mcp_sdk
3
+
open Mcp_server
3
4
4
5
(* Helper for extracting string value from JSON *)
5
6
let get_string_param json name =
···
164
165
165
166
(* Main function *)
166
167
let () =
168
+
(* Parse command line arguments *)
169
+
let transport_type = ref Stdio in
170
+
let args = [
171
+
("--http", Arg.Unit (fun () -> transport_type := Http),
172
+
"Start server with HTTP transport (default is stdio)");
173
+
] in
174
+
let usage_msg = "Usage: resource_template_example [--http]" in
175
+
Arg.parse args (fun _ -> ()) usage_msg;
176
+
167
177
(* Instead of printing directly to stdout which messes up the JSON-RPC protocol,
168
178
use the logging system which sends output to stderr *)
169
179
Log.info "Starting ResourceTemplateServer...";
···
171
181
(* Configure the server with appropriate capabilities *)
172
182
ignore (configure_server server ());
173
183
174
-
(* Run the server *)
175
-
run_server server
184
+
(* Create and start MCP server with the selected transport *)
185
+
let mcp_server = create ~server ~transport:!transport_type () in
186
+
start mcp_server
+6
lib/dune
+6
lib/dune
+78
-7
lib/mcp_sdk.ml
+78
-7
lib/mcp_sdk.ml
···
16
16
17
17
let log level msg =
18
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
19
+
flush stderr
22
20
23
21
let debug = log Debug
24
22
let info = log Info
···
135
133
let create_argument ~name ?description ?(required=false) () =
136
134
{ name; description; required }
137
135
136
+
let yojson_of_message { role; content } =
137
+
`Assoc [
138
+
("role", Role.yojson_of_t role);
139
+
("content", yojson_of_content content);
140
+
]
141
+
142
+
(* This function must match the structure expected by the PromptMessage module in mcp.ml *)
143
+
let message_of_yojson json =
144
+
match json with
145
+
| `Assoc fields -> begin
146
+
let role = match List.assoc_opt "role" fields with
147
+
| Some json -> begin
148
+
Role.t_of_yojson json
149
+
end
150
+
| None -> begin
151
+
raise (Json.Of_json ("Missing role field", `Assoc fields))
152
+
end
153
+
in
154
+
let content = match List.assoc_opt "content" fields with
155
+
| Some json -> begin
156
+
content_of_yojson json
157
+
end
158
+
| None -> begin
159
+
raise (Json.Of_json ("Missing content field", `Assoc fields))
160
+
end
161
+
in
162
+
{ role; content }
163
+
end
164
+
| j -> begin
165
+
raise (Json.Of_json ("Expected object for PromptMessage", j))
166
+
end
167
+
138
168
let to_json prompt =
139
169
let assoc = [
140
170
("name", `String prompt.name);
···
171
201
let make_text_content text =
172
202
Text (TextContent.{ text; annotations = None })
173
203
204
+
let make_text_content_with_annotations text annotations =
205
+
Text (TextContent.{ text; annotations = Some annotations })
206
+
207
+
let make_image_content data mime_type =
208
+
Image (ImageContent.{ data; mime_type; annotations = None })
209
+
210
+
let make_image_content_with_annotations data mime_type annotations =
211
+
Image (ImageContent.{ data; mime_type; annotations = Some annotations })
212
+
213
+
let make_audio_content data mime_type =
214
+
Audio (AudioContent.{ data; mime_type; annotations = None })
215
+
216
+
let make_audio_content_with_annotations data mime_type annotations =
217
+
Audio (AudioContent.{ data; mime_type; annotations = Some annotations })
218
+
219
+
let make_text_resource_content uri text ?mime_type () =
220
+
Resource (EmbeddedResource.{
221
+
resource = `Text TextResourceContents.{ uri; text; mime_type };
222
+
annotations = None
223
+
})
224
+
225
+
let make_blob_resource_content uri blob ?mime_type () =
226
+
Resource (EmbeddedResource.{
227
+
resource = `Blob BlobResourceContents.{ uri; blob; mime_type };
228
+
annotations = None
229
+
})
230
+
174
231
let make_tool_schema properties required =
175
232
let props = List.map (fun (name, schema_type, description) ->
176
233
(name, `Assoc [
···
352
409
let set_shutdown_hook server hook =
353
410
server.shutdown_hook <- Some hook
354
411
355
-
(* Run the server *)
412
+
(* Transport type for server *)
413
+
type transport_type =
414
+
| Stdio (* Read/write to stdin/stdout *)
415
+
| Http (* HTTP server - to be implemented *)
416
+
417
+
(* Run server with stdio transport *)
356
418
let run_server server =
357
419
(* Setup *)
358
420
Printexc.record_backtrace true;
359
-
set_binary_mode_out stdout false;
360
421
361
-
Log.info (Printf.sprintf "%s server started" server.name);
422
+
Log.info (Printf.sprintf "%s server starting" server.name);
362
423
Log.debug (Printf.sprintf "Protocol version: %s" server.protocol_version);
363
424
Log.debug (Printf.sprintf "Server info: %s v%s" server.name server.version);
364
425
···
371
432
| Some hook -> hook ()
372
433
| None -> ());
373
434
374
-
Log.info "Server initialized and ready."
435
+
(* This function will be replaced by a full implementation in the mcp_server module *)
436
+
Log.info "Server initialized and ready."
437
+
438
+
(* Placeholder for running server with different transports *)
439
+
let run_server_with_transport server transport =
440
+
match transport with
441
+
| Http ->
442
+
Log.info "HTTP server not implemented in this version, using stdio instead";
443
+
run_server server
444
+
| Stdio ->
445
+
run_server server
+18
-1
lib/mcp_sdk.mli
+18
-1
lib/mcp_sdk.mli
···
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
+
val yojson_of_message : message -> Json.t
90
+
val message_of_yojson : Json.t -> message
89
91
val to_json : t -> Json.t
90
92
end
91
93
···
139
141
(** Set shutdown hook *)
140
142
val set_shutdown_hook : server -> (unit -> unit) -> unit
141
143
142
-
(** Run the server *)
144
+
(** Run the server using stdio transport (legacy method) *)
143
145
val run_server : server -> unit
144
146
147
+
(** Transport type for the server *)
148
+
type transport_type =
149
+
| Stdio (** Read/write to stdin/stdout *)
150
+
| Http (** HTTP server - to be implemented *)
151
+
152
+
(** Create and start a server with the specified transport *)
153
+
val run_server_with_transport : server -> transport_type -> unit
154
+
145
155
(** Helper functions for creating common objects *)
146
156
val make_text_content : string -> content
157
+
val make_text_content_with_annotations : string -> Annotated.annotation -> content
158
+
val make_image_content : string -> string -> content
159
+
val make_image_content_with_annotations : string -> string -> Annotated.annotation -> content
160
+
val make_audio_content : string -> string -> content
161
+
val make_audio_content_with_annotations : string -> string -> Annotated.annotation -> content
162
+
val make_text_resource_content : string -> string -> ?mime_type:string -> unit -> content
163
+
val make_blob_resource_content : string -> string -> ?mime_type:string -> unit -> content
147
164
val make_tool_schema : (string * string * string) list -> string list -> Json.t
+533
lib/mcp_server.ml
+533
lib/mcp_server.ml
···
1
+
open Mcp
2
+
open Mcp_sdk
3
+
4
+
(* MCP Server module for handling JSON-RPC communication *)
5
+
6
+
(** Server types *)
7
+
type transport_type =
8
+
| Stdio (* Read/write to stdin/stdout *)
9
+
| Http (* HTTP server - to be implemented *)
10
+
11
+
type t = {
12
+
server: Mcp_sdk.server;
13
+
transport: transport_type;
14
+
mutable running: bool;
15
+
}
16
+
17
+
(** Process a single message *)
18
+
let process_message server message =
19
+
try
20
+
Log.debug "Parsing message as JSONRPC message...";
21
+
match JSONRPCMessage.t_of_yojson message with
22
+
| JSONRPCMessage.Request req -> begin
23
+
Log.debug (Printf.sprintf "Received request with method: %s" req.method_);
24
+
match req.method_ with
25
+
| "initialize" -> begin
26
+
Log.debug "Processing initialize request";
27
+
let result = match req.params with
28
+
| Some params -> begin
29
+
Log.debug "Parsing initialize request params...";
30
+
let req_params = Initialize.Request.t_of_yojson params in
31
+
Log.debug (Printf.sprintf "Client info: %s v%s"
32
+
req_params.client_info.name
33
+
req_params.client_info.version);
34
+
Log.debug (Printf.sprintf "Client protocol version: %s" req_params.protocol_version);
35
+
36
+
(* Check protocol version compatibility *)
37
+
if req_params.protocol_version <> server.protocol_version then begin
38
+
Log.debug (Printf.sprintf "Protocol version mismatch: client=%s server=%s"
39
+
req_params.protocol_version server.protocol_version);
40
+
end;
41
+
42
+
Initialize.Result.create
43
+
~capabilities:server.capabilities
44
+
~server_info:Implementation.{ name = server.name; version = server.version }
45
+
~protocol_version:server.protocol_version
46
+
?instructions:(Some "MCP Server") (* TODO: Allow customization *)
47
+
()
48
+
end
49
+
| None -> begin
50
+
Log.error "Missing params for initialize request";
51
+
Initialize.Result.create
52
+
~capabilities:server.capabilities
53
+
~server_info:Implementation.{ name = server.name; version = server.version }
54
+
~protocol_version:server.protocol_version
55
+
()
56
+
end
57
+
in
58
+
Some (create_response ~id:req.id ~result:(Initialize.Result.yojson_of_t result))
59
+
end
60
+
61
+
| "tools/list" -> begin
62
+
Log.debug "Processing tools/list request";
63
+
let tools_json = List.map Mcp_sdk.Tool.to_json server.tools in
64
+
let result = `Assoc [("tools", `List tools_json)] in
65
+
Some (create_response ~id:req.id ~result)
66
+
end
67
+
68
+
| "tools/call" -> begin
69
+
Log.debug "Processing tools/call request";
70
+
match req.params with
71
+
| Some (`Assoc params) -> begin
72
+
let name = match List.assoc_opt "name" params with
73
+
| Some (`String name) -> begin
74
+
Log.debug (Printf.sprintf "Tool name: %s" name);
75
+
name
76
+
end
77
+
| _ -> begin
78
+
Log.error "Missing or invalid 'name' parameter in tool call";
79
+
failwith "Missing or invalid 'name' parameter"
80
+
end
81
+
in
82
+
let args = match List.assoc_opt "arguments" params with
83
+
| Some args -> begin
84
+
Log.debug (Printf.sprintf "Tool arguments: %s" (Yojson.Safe.to_string args));
85
+
args
86
+
end
87
+
| _ -> begin
88
+
Log.debug "No arguments provided for tool call, using empty object";
89
+
`Assoc [] (* Empty arguments is valid *)
90
+
end
91
+
in
92
+
let progress_token = req.progress_token in
93
+
94
+
(* Find the tool *)
95
+
let tool_opt = List.find_opt (fun t -> t.Mcp_sdk.Tool.name = name) server.tools in
96
+
match tool_opt with
97
+
| Some tool -> begin
98
+
Log.debug (Printf.sprintf "Found tool: %s" name);
99
+
let ctx = Mcp_sdk.Context.create
100
+
?request_id:(Some req.id)
101
+
~lifespan_context:server.lifespan_context
102
+
()
103
+
in
104
+
ctx.progress_token <- progress_token;
105
+
106
+
(* Call the handler *)
107
+
let result = match tool.handler ctx args with
108
+
| Ok json -> begin
109
+
`Assoc [
110
+
("content", `List [Mcp.yojson_of_content (Text (TextContent.{
111
+
text = Yojson.Safe.to_string json;
112
+
annotations = None
113
+
}))]);
114
+
("isError", `Bool false)
115
+
]
116
+
end
117
+
| Error err -> begin
118
+
`Assoc [
119
+
("content", `List [Mcp.yojson_of_content (Text (TextContent.{
120
+
text = err;
121
+
annotations = None
122
+
}))]);
123
+
("isError", `Bool true)
124
+
]
125
+
end
126
+
in
127
+
Some (create_response ~id:req.id ~result)
128
+
end
129
+
| None -> begin
130
+
Log.error (Printf.sprintf "Tool not found: %s" name);
131
+
let error_content = TextContent.{
132
+
text = Printf.sprintf "Unknown tool: %s" name;
133
+
annotations = None
134
+
} in
135
+
let result = `Assoc [
136
+
("content", `List [Mcp.yojson_of_content (Text error_content)]);
137
+
("isError", `Bool true)
138
+
] in
139
+
Some (create_response ~id:req.id ~result)
140
+
end
141
+
end
142
+
| _ -> begin
143
+
Log.error "Invalid params format for tools/call";
144
+
Some (create_error ~id:req.id ~code:ErrorCode.invalid_params ~message:"Invalid params for tools/call" ())
145
+
end
146
+
end
147
+
148
+
| "resources/list" -> begin
149
+
Log.debug "Processing resources/list request";
150
+
if server.resources <> [] then begin
151
+
let resources_json = List.map Mcp_sdk.Resource.to_json server.resources in
152
+
let result = `Assoc [("resources", `List resources_json)] in
153
+
Some (create_response ~id:req.id ~result)
154
+
end else begin
155
+
Some (create_error ~id:req.id ~code:ErrorCode.method_not_found ~message:"Resources not supported" ())
156
+
end
157
+
end
158
+
159
+
| "prompts/list" -> begin
160
+
Log.debug "Processing prompts/list request";
161
+
if server.prompts <> [] then begin
162
+
let prompts_json = List.map Mcp_sdk.Prompt.to_json server.prompts in
163
+
let result = `Assoc [("prompts", `List prompts_json)] in
164
+
Some (create_response ~id:req.id ~result)
165
+
end else begin
166
+
Some (create_error ~id:req.id ~code:ErrorCode.method_not_found ~message:"Prompts not supported" ())
167
+
end
168
+
end
169
+
170
+
| "prompts/get" -> begin
171
+
Log.debug "Processing prompts/get request";
172
+
if server.prompts <> [] then begin
173
+
match req.params with
174
+
| Some (`Assoc params) -> begin
175
+
(* Extract prompt name *)
176
+
let name = match List.assoc_opt "name" params with
177
+
| Some (`String name) -> begin
178
+
Log.debug (Printf.sprintf "Prompt name: %s" name);
179
+
name
180
+
end
181
+
| _ -> begin
182
+
Log.error "Missing or invalid 'name' parameter in prompt request";
183
+
failwith "Missing or invalid 'name' parameter"
184
+
end
185
+
in
186
+
187
+
(* Extract arguments if any *)
188
+
let arguments = match List.assoc_opt "arguments" params with
189
+
| Some (`Assoc args) -> begin
190
+
Log.debug (Printf.sprintf "Prompt arguments: %s" (Yojson.Safe.to_string (`Assoc args)));
191
+
List.map (fun (k, v) ->
192
+
match v with
193
+
| `String s -> begin (k, s) end
194
+
| _ -> begin (k, Yojson.Safe.to_string v) end
195
+
) args
196
+
end
197
+
| _ -> begin
198
+
[]
199
+
end
200
+
in
201
+
202
+
(* Find the prompt *)
203
+
let prompt_opt = List.find_opt (fun p -> p.Mcp_sdk.Prompt.name = name) server.prompts in
204
+
match prompt_opt with
205
+
| Some prompt -> begin
206
+
Log.debug (Printf.sprintf "Found prompt: %s" name);
207
+
let ctx = Mcp_sdk.Context.create
208
+
?request_id:(Some req.id)
209
+
~lifespan_context:server.lifespan_context
210
+
()
211
+
in
212
+
213
+
(* Call the prompt handler *)
214
+
match prompt.handler ctx arguments with
215
+
| Ok messages -> begin
216
+
Log.debug (Printf.sprintf "Prompt handler returned %d messages" (List.length messages));
217
+
218
+
(* Important: We need to directly use yojson_of_message which preserves MIME types *)
219
+
let messages_json = List.map Prompt.yojson_of_message messages in
220
+
221
+
(* Debug output *)
222
+
Log.debug (Printf.sprintf "Messages JSON: %s" (Yojson.Safe.to_string (`List messages_json)));
223
+
224
+
(* Verify one message if available to check structure *)
225
+
if List.length messages > 0 then begin
226
+
let first_msg = List.hd messages in
227
+
let content_debug = match first_msg.content with
228
+
| Text t -> begin
229
+
Printf.sprintf "Text content: %s" t.text
230
+
end
231
+
| Image i -> begin
232
+
Printf.sprintf "Image content (mime: %s)" i.mime_type
233
+
end
234
+
| Audio a -> begin
235
+
Printf.sprintf "Audio content (mime: %s)" a.mime_type
236
+
end
237
+
| Resource r -> begin
238
+
"Resource content"
239
+
end
240
+
in
241
+
Log.debug (Printf.sprintf "First message content type: %s" content_debug);
242
+
end;
243
+
244
+
let result = `Assoc [
245
+
("messages", `List messages_json);
246
+
("description", match prompt.description with
247
+
| Some d -> begin `String d end
248
+
| None -> begin `Null end)
249
+
] in
250
+
Some (create_response ~id:req.id ~result)
251
+
end
252
+
| Error err -> begin
253
+
Log.error (Printf.sprintf "Error processing prompt: %s" err);
254
+
Some (create_error ~id:req.id ~code:ErrorCode.internal_error ~message:err ())
255
+
end
256
+
end
257
+
| None -> begin
258
+
Log.error (Printf.sprintf "Prompt not found: %s" name);
259
+
Some (create_error ~id:req.id ~code:ErrorCode.invalid_params ~message:(Printf.sprintf "Prompt not found: %s" name) ())
260
+
end
261
+
end
262
+
| _ -> begin
263
+
Log.error "Invalid params format for prompts/get";
264
+
Some (create_error ~id:req.id ~code:ErrorCode.invalid_params ~message:"Invalid params format" ())
265
+
end
266
+
end else begin
267
+
Some (create_error ~id:req.id ~code:ErrorCode.method_not_found ~message:"Prompts not supported" ())
268
+
end
269
+
end
270
+
271
+
| "ping" -> begin
272
+
Log.debug "Processing ping request";
273
+
Some (create_response ~id:req.id ~result:(`Assoc []))
274
+
end
275
+
276
+
| _ -> begin
277
+
Log.error (Printf.sprintf "Unknown method received: %s" req.method_);
278
+
Some (create_error ~id:req.id ~code:ErrorCode.method_not_found ~message:("Method not found: " ^ req.method_) ())
279
+
end
280
+
end
281
+
282
+
| JSONRPCMessage.Notification notif -> begin
283
+
Log.debug (Printf.sprintf "Received notification with method: %s" notif.method_);
284
+
match notif.method_ with
285
+
| "notifications/initialized" -> begin
286
+
Log.debug "Client initialization complete - Server is now ready to receive requests";
287
+
None
288
+
end
289
+
| _ -> begin
290
+
Log.debug (Printf.sprintf "Ignoring notification: %s" notif.method_);
291
+
None
292
+
end
293
+
end
294
+
295
+
| JSONRPCMessage.Response _ -> begin
296
+
Log.error "Unexpected response message received";
297
+
None
298
+
end
299
+
300
+
| JSONRPCMessage.Error _ -> begin
301
+
Log.error "Unexpected error message received";
302
+
None
303
+
end
304
+
with
305
+
| Failure msg -> begin
306
+
Log.error (Printf.sprintf "JSON error in message processing: %s" msg);
307
+
None
308
+
end
309
+
| exc -> begin
310
+
Log.error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));
311
+
Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
312
+
None
313
+
end
314
+
315
+
(** Read a single message from stdin *)
316
+
let read_stdio_message () =
317
+
try
318
+
Log.debug "Reading line from stdin...";
319
+
let line = read_line () in
320
+
if line = "" then begin
321
+
Log.debug "Empty line received, ignoring";
322
+
None
323
+
end else begin
324
+
Log.debug (Printf.sprintf "Raw input: %s" (String.sub line 0 (min 100 (String.length line))));
325
+
try
326
+
let json = Yojson.Safe.from_string line in
327
+
Log.debug "Successfully parsed JSON";
328
+
Some json
329
+
with
330
+
| Yojson.Json_error msg -> begin
331
+
Log.error (Printf.sprintf "Error parsing JSON: %s" msg);
332
+
Log.error (Printf.sprintf "Input was: %s" (String.sub line 0 (min 100 (String.length line))));
333
+
None
334
+
end
335
+
end
336
+
with
337
+
| End_of_file -> begin
338
+
Log.debug "End of file received on stdin";
339
+
None
340
+
end
341
+
| Sys_error msg -> begin
342
+
Log.error (Printf.sprintf "System error while reading: %s" msg);
343
+
None
344
+
end
345
+
| exc -> begin
346
+
Log.error (Printf.sprintf "Exception while reading: %s" (Printexc.to_string exc));
347
+
None
348
+
end
349
+
350
+
(** Run stdio server with enhanced error handling *)
351
+
let rec run_stdio_server mcp_server =
352
+
try begin
353
+
if not mcp_server.running then begin
354
+
Log.debug "Server stopped";
355
+
()
356
+
end else begin
357
+
match read_stdio_message () with
358
+
| Some json -> begin
359
+
Log.debug "Processing message...";
360
+
try begin
361
+
match process_message mcp_server.server json with
362
+
| Some response -> begin
363
+
let response_json = JSONRPCMessage.yojson_of_t response in
364
+
let response_str = Yojson.Safe.to_string response_json in
365
+
Log.debug (Printf.sprintf "Sending response: %s"
366
+
(String.sub response_str 0 (min 100 (String.length response_str))));
367
+
Printf.printf "%s\n" response_str;
368
+
flush stdout;
369
+
(* Give client time to process *)
370
+
Unix.sleepf 0.01;
371
+
end
372
+
| None -> begin
373
+
Log.debug "No response needed"
374
+
end
375
+
end with
376
+
| exc -> begin
377
+
Log.error (Printf.sprintf "ERROR in message processing: %s" (Printexc.to_string exc));
378
+
Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
379
+
(* Try to extract ID and send an error response *)
380
+
try begin
381
+
let id_opt = match Yojson.Safe.Util.member "id" json with
382
+
| `Int i -> Some (`Int i)
383
+
| `String s -> Some (`String s)
384
+
| _ -> None
385
+
in
386
+
match id_opt with
387
+
| Some id -> begin
388
+
let error_resp = create_error ~id ~code:ErrorCode.internal_error ~message:(Printexc.to_string exc) () in
389
+
let error_json = JSONRPCMessage.yojson_of_t error_resp in
390
+
let error_str = Yojson.Safe.to_string error_json in
391
+
Printf.printf "%s\n" error_str;
392
+
flush stdout;
393
+
end
394
+
| None -> begin
395
+
Log.error "Could not extract request ID to send error response"
396
+
end
397
+
end with
398
+
| e -> begin
399
+
Log.error (Printf.sprintf "Failed to send error response: %s" (Printexc.to_string e))
400
+
end
401
+
end;
402
+
run_stdio_server mcp_server
403
+
end
404
+
| None -> begin
405
+
if mcp_server.running then begin
406
+
(* No message received, but server is still running *)
407
+
Unix.sleepf 0.1; (* Small sleep to prevent CPU spinning *)
408
+
run_stdio_server mcp_server
409
+
end else begin
410
+
Log.debug "Server stopped during message processing"
411
+
end
412
+
end
413
+
end
414
+
end with
415
+
| exc -> begin
416
+
Log.error (Printf.sprintf "FATAL ERROR in server main loop: %s" (Printexc.to_string exc));
417
+
Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
418
+
(* Try to continue anyway *)
419
+
if mcp_server.running then begin
420
+
Unix.sleepf 0.1;
421
+
run_stdio_server mcp_server
422
+
end
423
+
end
424
+
425
+
(** Create an MCP server *)
426
+
let create ~server ~transport () =
427
+
{ server; transport; running = false }
428
+
429
+
(** HTTP server placeholder (to be fully implemented) *)
430
+
let run_http_server mcp_server port =
431
+
Log.info (Printf.sprintf "%s HTTP server starting on port %d" mcp_server.server.name port);
432
+
Log.info "HTTP transport is a placeholder and not fully implemented yet";
433
+
434
+
(* This would be where we'd set up cohttp server *)
435
+
(*
436
+
let callback _conn req body =
437
+
let uri = req |> Cohttp.Request.uri in
438
+
let meth = req |> Cohttp.Request.meth |> Cohttp.Code.string_of_method in
439
+
440
+
(* Handle only POST /jsonrpc endpoint *)
441
+
match (meth, Uri.path uri) with
442
+
| "POST", "/jsonrpc" ->
443
+
(* Read the body *)
444
+
Cohttp_lwt.Body.to_string body >>= fun body_str ->
445
+
446
+
(* Parse JSON *)
447
+
let json = try Some (Yojson.Safe.from_string body_str) with _ -> None in
448
+
match json with
449
+
| Some json_msg ->
450
+
(* Process the message *)
451
+
let response_opt = process_message mcp_server.server json_msg in
452
+
(match response_opt with
453
+
| Some response ->
454
+
let response_json = JSONRPCMessage.yojson_of_t response in
455
+
let response_str = Yojson.Safe.to_string response_json in
456
+
Cohttp_lwt_unix.Server.respond_string
457
+
~status:`OK
458
+
~body:response_str
459
+
~headers:(Cohttp.Header.init_with "Content-Type" "application/json")
460
+
()
461
+
| None ->
462
+
Cohttp_lwt_unix.Server.respond_string
463
+
~status:`OK
464
+
~body:"{}"
465
+
~headers:(Cohttp.Header.init_with "Content-Type" "application/json")
466
+
())
467
+
| None ->
468
+
Cohttp_lwt_unix.Server.respond_string
469
+
~status:`Bad_request
470
+
~body:"{\"error\":\"Invalid JSON\"}"
471
+
~headers:(Cohttp.Header.init_with "Content-Type" "application/json")
472
+
()
473
+
| _ ->
474
+
(* Return 404 for any other routes *)
475
+
Cohttp_lwt_unix.Server.respond_string
476
+
~status:`Not_found
477
+
~body:"Not found"
478
+
()
479
+
in
480
+
481
+
(* Create and start the server *)
482
+
let server = Cohttp_lwt_unix.Server.create
483
+
~mode:(`TCP (`Port port))
484
+
(Cohttp_lwt_unix.Server.make ~callback ())
485
+
in
486
+
487
+
(* Run the server *)
488
+
Lwt_main.run server
489
+
*)
490
+
491
+
(* For now, just wait until the server is stopped *)
492
+
while mcp_server.running do
493
+
Unix.sleep 1
494
+
done
495
+
496
+
(** Start the server based on transport type *)
497
+
let start server =
498
+
server.running <- true;
499
+
500
+
(* Run startup hook if provided *)
501
+
(match server.server.startup_hook with
502
+
| Some hook -> begin hook () end
503
+
| None -> begin () end);
504
+
505
+
(* Install signal handler *)
506
+
Sys.(set_signal sigint (Signal_handle (fun _ ->
507
+
Log.debug "Received interrupt signal, stopping server...";
508
+
server.running <- false
509
+
)));
510
+
511
+
match server.transport with
512
+
| Stdio -> begin
513
+
(* Setup stdout and stderr *)
514
+
set_binary_mode_out stdout false;
515
+
Log.info (Printf.sprintf "%s server started with stdio transport" server.server.name);
516
+
517
+
(* Run the server loop *)
518
+
run_stdio_server server
519
+
end
520
+
| Http -> begin
521
+
(* HTTP server placeholder *)
522
+
run_http_server server 8080
523
+
end
524
+
525
+
(** Stop the server *)
526
+
let stop server =
527
+
Log.info "Stopping server...";
528
+
server.running <- false;
529
+
530
+
(* Run shutdown hook if provided *)
531
+
match server.server.shutdown_hook with
532
+
| Some hook -> begin hook () end
533
+
| None -> begin () end
+54
lib/mcp_server.mli
+54
lib/mcp_server.mli
···
1
+
(** MCP Server module - full implementation *)
2
+
3
+
(** Transport type for server *)
4
+
type transport_type =
5
+
| Stdio (** Read/write to stdin/stdout *)
6
+
| Http (** HTTP server - to be implemented *)
7
+
8
+
(** Server type *)
9
+
type t = {
10
+
server: Mcp_sdk.server;
11
+
transport: transport_type;
12
+
mutable running: bool;
13
+
}
14
+
15
+
(** Create an MCP server
16
+
@param server The Mcp_sdk server to use
17
+
@param transport The transport type to use
18
+
*)
19
+
val create : server:Mcp_sdk.server -> transport:transport_type -> unit -> t
20
+
21
+
(** Start the server
22
+
This function will block until the server is stopped.
23
+
@param server The server to start
24
+
*)
25
+
val start : t -> unit
26
+
27
+
(** Stop the server
28
+
This will set the running flag to false and invoke the shutdown hook.
29
+
@param server The server to stop
30
+
*)
31
+
val stop : t -> unit
32
+
33
+
(** Process a single message
34
+
@param server The Mcp_sdk server to use
35
+
@param message The JSON message to process
36
+
@return An optional response message
37
+
*)
38
+
val process_message : Mcp_sdk.server -> Yojson.Safe.t -> Mcp.JSONRPCMessage.t option
39
+
40
+
(** Run stdio server implementation
41
+
@param mcp_server The mcp_server to run
42
+
*)
43
+
val run_stdio_server : t -> unit
44
+
45
+
(** Read a message from stdio
46
+
@return An optional JSON message
47
+
*)
48
+
val read_stdio_message : unit -> Yojson.Safe.t option
49
+
50
+
(** Run HTTP server implementation (placeholder)
51
+
@param mcp_server The mcp_server to run
52
+
@param port The port to listen on
53
+
*)
54
+
val run_http_server : t -> int -> unit