Model Context Protocol in OCaml
anil.recoil.org
1open Mcp_sdk
2
3(* Helper for extracting string value from JSON *)
4let get_string_param json name =
5 match json with
6 | `Assoc fields ->
7 (match List.assoc_opt name fields with
8 | Some (`String value) -> value
9 | _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
10 | _ -> raise (Failure "Expected JSON object")
11
12(* Helper for extracting integer value from JSON *)
13let get_int_param json name =
14 match json with
15 | `Assoc fields ->
16 (match List.assoc_opt name fields with
17 | Some (`Int value) -> value
18 | Some (`String value) -> int_of_string value
19 | _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
20 | _ -> raise (Failure "Expected JSON object")
21
22(* Base64 encoding - simplified version *)
23module Base64 = struct
24 let encode_char idx =
25 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/".[idx]
26
27 let encode s =
28 let len = String.length s in
29 let result = Bytes.create (((len + 2) / 3) * 4) in
30
31 let rec loop i j =
32 if i >= len then j
33 else
34 let n =
35 let n = Char.code s.[i] lsl 16 in
36 let n = if i + 1 < len then n lor (Char.code s.[i+1] lsl 8) else n in
37 if i + 2 < len then n lor Char.code s.[i+2] else n
38 in
39 Bytes.set result j (encode_char ((n lsr 18) land 63));
40 Bytes.set result (j+1) (encode_char ((n lsr 12) land 63));
41 Bytes.set result (j+2)
42 (if i + 1 < len then encode_char ((n lsr 6) land 63) else '=');
43 Bytes.set result (j+3)
44 (if i + 2 < len then encode_char (n land 63) else '=');
45 loop (i + 3) (j + 4)
46 in
47 Bytes.sub_string result 0 (loop 0 0)
48end
49
50(* Generate a simple GIF format image *)
51let generate_random_image width height =
52 (* Ensure dimensions are reasonable *)
53 let width = min 256 (max 16 width) in
54 let height = min 256 (max 16 height) in
55
56 (* Create a buffer for GIF data *)
57 let buf = Buffer.create 1024 in
58
59 (* GIF Header - "GIF89a" *)
60 Buffer.add_string buf "GIF89a";
61
62 (* Logical Screen Descriptor *)
63 (* Width - 2 bytes little endian *)
64 Buffer.add_char buf (Char.chr (width land 0xff));
65 Buffer.add_char buf (Char.chr ((width lsr 8) land 0xff));
66
67 (* Height - 2 bytes little endian *)
68 Buffer.add_char buf (Char.chr (height land 0xff));
69 Buffer.add_char buf (Char.chr ((height lsr 8) land 0xff));
70
71 (* Packed fields - 1 byte:
72 Global Color Table Flag - 1 bit (1)
73 Color Resolution - 3 bits (7 = 8 bits per color)
74 Sort Flag - 1 bit (0)
75 Size of Global Color Table - 3 bits (2 = 8 colors) *)
76 Buffer.add_char buf (Char.chr 0xF2);
77
78 (* Background color index - 1 byte *)
79 Buffer.add_char buf (Char.chr 0);
80
81 (* Pixel aspect ratio - 1 byte *)
82 Buffer.add_char buf (Char.chr 0);
83
84 (* Global Color Table - 8 colors x 3 bytes (R,G,B) *)
85 (* Simple 8-color palette *)
86 Buffer.add_string buf "\xFF\xFF\xFF"; (* White (0) *)
87 Buffer.add_string buf "\xFF\x00\x00"; (* Red (1) *)
88 Buffer.add_string buf "\x00\xFF\x00"; (* Green (2) *)
89 Buffer.add_string buf "\x00\x00\xFF"; (* Blue (3) *)
90 Buffer.add_string buf "\xFF\xFF\x00"; (* Yellow (4) *)
91 Buffer.add_string buf "\xFF\x00\xFF"; (* Magenta (5) *)
92 Buffer.add_string buf "\x00\xFF\xFF"; (* Cyan (6) *)
93 Buffer.add_string buf "\x00\x00\x00"; (* Black (7) *)
94
95 (* Graphics Control Extension (optional) *)
96 Buffer.add_char buf (Char.chr 0x21); (* Extension Introducer *)
97 Buffer.add_char buf (Char.chr 0xF9); (* Graphic Control Label *)
98 Buffer.add_char buf (Char.chr 0x04); (* Block Size *)
99 Buffer.add_char buf (Char.chr 0x01); (* Packed field: 1 bit for transparency *)
100 Buffer.add_char buf (Char.chr 0x00); (* Delay time (1/100s) - 2 bytes *)
101 Buffer.add_char buf (Char.chr 0x00);
102 Buffer.add_char buf (Char.chr 0x00); (* Transparent color index *)
103 Buffer.add_char buf (Char.chr 0x00); (* Block terminator *)
104
105 (* Image Descriptor *)
106 Buffer.add_char buf (Char.chr 0x2C); (* Image Separator *)
107 Buffer.add_char buf (Char.chr 0x00); (* Left position - 2 bytes *)
108 Buffer.add_char buf (Char.chr 0x00);
109 Buffer.add_char buf (Char.chr 0x00); (* Top position - 2 bytes *)
110 Buffer.add_char buf (Char.chr 0x00);
111
112 (* Image width - 2 bytes little endian *)
113 Buffer.add_char buf (Char.chr (width land 0xff));
114 Buffer.add_char buf (Char.chr ((width lsr 8) land 0xff));
115
116 (* Image height - 2 bytes little endian *)
117 Buffer.add_char buf (Char.chr (height land 0xff));
118 Buffer.add_char buf (Char.chr ((height lsr 8) land 0xff));
119
120 (* Packed fields - 1 byte - no local color table *)
121 Buffer.add_char buf (Char.chr 0x00);
122
123 (* LZW Minimum Code Size - 1 byte *)
124 Buffer.add_char buf (Char.chr 0x03); (* Minimum code size 3 for 8 colors *)
125
126 (* Generate a simple image - a checkerboard pattern *)
127 let step = width / 8 in
128 let image_data = Buffer.create (width * height / 4) in
129
130 (* Very simple LZW compression - just store raw clear codes and color indexes *)
131 (* Start with Clear code *)
132 Buffer.add_char image_data (Char.chr 0x08); (* Clear code 8 *)
133
134 (* For very simple encoding, we'll just use a sequence of color indexes *)
135 for y = 0 to height - 1 do
136 for x = 0 to width - 1 do
137 (* Checkerboard pattern with different colors *)
138 let color =
139 if ((x / step) + (y / step)) mod 2 = 0 then
140 3 (* Blue *)
141 else
142 1 (* Red *)
143 in
144 Buffer.add_char image_data (Char.chr color);
145 done
146 done;
147
148 (* End with End of Information code *)
149 Buffer.add_char image_data (Char.chr 0x09);
150
151 (* Add image data blocks - GIF uses 255-byte max chunks *)
152 let data = Buffer.contents image_data in
153 let data_len = String.length data in
154 let pos = ref 0 in
155
156 while !pos < data_len do
157 let chunk_size = min 255 (data_len - !pos) in
158 Buffer.add_char buf (Char.chr chunk_size);
159 for i = 0 to chunk_size - 1 do
160 Buffer.add_char buf (String.get data (!pos + i));
161 done;
162 pos := !pos + chunk_size;
163 done;
164
165 (* Zero-length block to end the image data *)
166 Buffer.add_char buf (Char.chr 0x00);
167
168 (* GIF Trailer *)
169 Buffer.add_char buf (Char.chr 0x3B);
170
171 (* Base64 encode the GIF data *)
172 Base64.encode (Buffer.contents buf)
173
174(* Helper to write 32-bit little endian integer *)
175let write_int32_le buf n =
176 Buffer.add_char buf (Char.chr (n land 0xff));
177 Buffer.add_char buf (Char.chr ((n lsr 8) land 0xff));
178 Buffer.add_char buf (Char.chr ((n lsr 16) land 0xff));
179 Buffer.add_char buf (Char.chr ((n lsr 24) land 0xff))
180
181(* Helper to write 16-bit little endian integer *)
182let write_int16_le buf n =
183 Buffer.add_char buf (Char.chr (n land 0xff));
184 Buffer.add_char buf (Char.chr ((n lsr 8) land 0xff))
185
186(* Generate a simple WAV file with sine wave *)
187let generate_sine_wave_audio frequency duration =
188 (* WAV header *)
189 let sample_rate = 8000 in
190 let num_samples = sample_rate * duration in
191 let header_buf = Buffer.create 44 in
192
193 (* Fill WAV header properly *)
194 Buffer.add_string header_buf "RIFF";
195 write_int32_le header_buf (36 + num_samples * 2); (* File size minus 8 *)
196 Buffer.add_string header_buf "WAVE";
197
198 (* Format chunk *)
199 Buffer.add_string header_buf "fmt ";
200 write_int32_le header_buf 16; (* Format chunk size *)
201 write_int16_le header_buf 1; (* PCM format *)
202 write_int16_le header_buf 1; (* Mono *)
203 write_int32_le header_buf sample_rate; (* Sample rate *)
204 write_int32_le header_buf (sample_rate * 2); (* Byte rate *)
205 write_int16_le header_buf 2; (* Block align *)
206 write_int16_le header_buf 16; (* Bits per sample *)
207
208 (* Data chunk *)
209 Buffer.add_string header_buf "data";
210 write_int32_le header_buf (num_samples * 2); (* Data size *)
211
212 (* Generate sine wave samples *)
213 let samples_buf = Buffer.create (num_samples * 2) in
214 let amplitude = 16384.0 in (* 16-bit with headroom *)
215
216 for i = 0 to num_samples - 1 do
217 let t = float_of_int i /. float_of_int sample_rate in
218 let value = amplitude *. sin (2.0 *. Float.pi *. frequency *. t) in
219 let sample = int_of_float value in
220
221 (* Convert to 16-bit little-endian *)
222 let sample = if sample < 0 then sample + 65536 else sample in
223 write_int16_le samples_buf sample;
224 done;
225
226 (* Combine header and samples, then encode as Base64 *)
227 let wav_data = Buffer.contents header_buf ^ Buffer.contents samples_buf in
228 Base64.encode wav_data
229
230(* Create a server *)
231let server = create_server
232 ~name:"OCaml MCP Multimodal Example"
233 ~version:"0.1.0"
234 ~protocol_version:"2024-11-05" () |>
235 fun server ->
236 (* Set default capabilities *)
237 configure_server server ~with_tools:true ~with_resources:true ~with_prompts:true ()
238
239(* Define and register a multimodal tool that returns text, images, and audio *)
240let _ = add_tool server
241 ~name:"multimodal_demo"
242 ~description:"Demonstrates multimodal content with text, image, and audio"
243 ~schema_properties:[
244 ("width", "integer", "Width of the generated image (pixels)");
245 ("height", "integer", "Height of the generated image (pixels)");
246 ("frequency", "integer", "Frequency of the generated audio tone (Hz)");
247 ("duration", "integer", "Duration of the generated audio (seconds)");
248 ("message", "string", "Text message to include")
249 ]
250 ~schema_required:["message"]
251 (fun args ->
252 try
253 (* Extract parameters with defaults if not provided *)
254 let message = get_string_param args "message" in
255 let width = try get_int_param args "width" with _ -> 128 in
256 let height = try get_int_param args "height" with _ -> 128 in
257 let frequency = try get_int_param args "frequency" with _ -> 440 in
258 let duration = try get_int_param args "duration" with _ -> 1 in
259
260 (* Generate image and audio data *)
261 let image_data = generate_random_image width height in
262 let audio_data = generate_sine_wave_audio (float_of_int frequency) duration in
263
264 (* Create a multimodal tool result *)
265 Tool.create_tool_result [
266 Mcp.make_text_content message;
267 Mcp.make_image_content image_data "image/gif";
268 Mcp.make_audio_content audio_data "audio/wav"
269 ] ~is_error:false
270 with
271 | Failure msg ->
272 Log.errorf "Error in multimodal tool: %s" msg;
273 Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
274 )
275
276(* Define and register a tool for generating only images *)
277let _ = add_tool server
278 ~name:"generate_image"
279 ~description:"Generates a random image with specified dimensions"
280 ~schema_properties:[
281 ("width", "integer", "Width of the generated image (pixels)");
282 ("height", "integer", "Height of the generated image (pixels)")
283 ]
284 ~schema_required:["width"; "height"]
285 (fun args ->
286 try
287 let width = get_int_param args "width" in
288 let height = get_int_param args "height" in
289
290 if width < 1 || width > 1024 || height < 1 || height > 1024 then
291 Tool.create_tool_result
292 [Mcp.make_text_content "Error: Dimensions must be between 1 and 1024 pixels"]
293 ~is_error:true
294 else
295 let image_data = generate_random_image width height in
296 Tool.create_tool_result
297 [Mcp.make_image_content image_data "image/gif"]
298 ~is_error:false
299 with
300 | Failure msg ->
301 Log.errorf "Error in generate_image tool: %s" msg;
302 Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
303 )
304
305(* Define and register a tool for generating only audio *)
306let _ = add_tool server
307 ~name:"generate_audio"
308 ~description:"Generates an audio tone with specified frequency and duration"
309 ~schema_properties:[
310 ("frequency", "integer", "Frequency of the tone in Hz (20-20000)");
311 ("duration", "integer", "Duration of the tone in seconds (1-10)")
312 ]
313 ~schema_required:["frequency"; "duration"]
314 (fun args ->
315 try
316 let frequency = get_int_param args "frequency" in
317 let duration = get_int_param args "duration" in
318
319 if frequency < 20 || frequency > 20000 then
320 Tool.create_tool_result
321 [Mcp.make_text_content "Error: Frequency must be between 20Hz and 20,000Hz"]
322 ~is_error:true
323 else if duration < 1 || duration > 10 then
324 Tool.create_tool_result
325 [Mcp.make_text_content "Error: Duration must be between 1 and 10 seconds"]
326 ~is_error:true
327 else
328 let audio_data = generate_sine_wave_audio (float_of_int frequency) duration in
329 Tool.create_tool_result
330 [Mcp.make_audio_content audio_data "audio/wav"]
331 ~is_error:false
332 with
333 | Failure msg ->
334 Log.errorf "Error in generate_audio tool: %s" msg;
335 Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
336 )
337
338(* Define and register a resource example with multimodal content *)
339let _ = add_resource server
340 ~uri_template:"multimodal://{name}"
341 ~description:"Get a multimodal greeting with text, image and audio"
342 ~mime_type:"application/json"
343 (fun params ->
344 match params with
345 | [name] ->
346 let greeting = Printf.sprintf "Hello, %s! Welcome to the multimodal MCP example." name in
347 let image_data = generate_random_image 128 128 in
348 let audio_data = generate_sine_wave_audio 440.0 1 in
349
350 Printf.sprintf {|
351 {
352 "greeting": "%s",
353 "image": {
354 "data": "%s",
355 "mimeType": "image/gif"
356 },
357 "audio": {
358 "data": "%s",
359 "mimeType": "audio/wav"
360 }
361 }
362 |} greeting image_data audio_data
363 | _ -> Printf.sprintf {|{"error": "Invalid parameters"}|}
364 )
365
366(* Run the server with the default scheduler *)
367let () =
368 Random.self_init(); (* Initialize random generator *)
369 Eio_main.run @@ fun env ->
370 Mcp_server.run_server env server