commit 13d659f8d7f885659b2c325f17a44921fffe81c1 · anil.recoil.org/ocaml-mcp

+13 -2

bin/audio_example.ml

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       0
        
       
     

       3
        
       

     

       4
        
       (* WAV file format helper module *)

     

       5
        
       module Wav = struct

     
···

       307
        
       

     

       308
        
       (* Main function *)

     

       309
        
       let () =

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       310
        
         (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)

     

       311
        
         Printf.fprintf stderr "Starting AudioExampleServer...\n";

     

       312
        
         flush stderr;

     
···

       315
        
         (* Configure the server with appropriate capabilities *)

     

       316
        
         ignore (configure_server server ());

     

       317
        
         

     

       318
       -
         (* Run the server *)

     

       319
       -
         run_server server
     

       0

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       3
       +
       open Mcp_server

     

       4
        
       

     

       5
        
       (* WAV file format helper module *)

     

       6
        
       module Wav = struct

     
···

       308
        
       

     

       309
        
       (* Main function *)

     

       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
       +
       

     

       320
        
         (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)

     

       321
        
         Printf.fprintf stderr "Starting AudioExampleServer...\n";

     

       322
        
         flush stderr;

     
···

       325
        
         (* Configure the server with appropriate capabilities *)

     

       326
        
         ignore (configure_server server ());

     

       327
        
         

     

       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

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       0
        
       
     

       3
        
       

     

       4
        
       (* Helper for extracting string value from JSON *)

     

       5
        
       let get_string_param json name =

     
···

       106
        
       

     

       107
        
       (* Main function *)

     

       108
        
       let () =

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       109
        
         (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)

     

       110
        
         Printf.fprintf stderr "Starting CapitalizeServer...\n";

     

       111
        
         flush stderr;

     
···

       114
        
         (* Configure the server with appropriate capabilities *)

     

       115
        
         ignore (configure_server server ());

     

       116
        
         

     

       117
       -
         (* Run the server *)

     

       118
       -
         run_server server
     

       0

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       3
       +
       open Mcp_server

     

       4
        
       

     

       5
        
       (* Helper for extracting string value from JSON *)

     

       6
        
       let get_string_param json name =

     
···

       107
        
       

     

       108
        
       (* Main function *)

     

       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
       +
       

     

       119
        
         (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)

     

       120
        
         Printf.fprintf stderr "Starting CapitalizeServer...\n";

     

       121
        
         flush stderr;

     
···

       124
        
         (* Configure the server with appropriate capabilities *)

     

       125
        
         ignore (configure_server server ());

     

       126
        
         

     

       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

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       0
        
       
     

       3
        
       

     

       4
        
       (* Helper for extracting string value from JSON *)

     

       5
        
       let get_string_param json name =

     
···

       157
        
       

     

       158
        
       (* Main function *)

     

       159
        
       let () =

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       160
        
         (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)

     

       161
        
         Printf.fprintf stderr "Starting CompletionServer...\n";

     

       162
        
         flush stderr;

     
···

       178
        
         ] in

     

       179
        
         set_capabilities server capabilities;

     

       180
        
         

     

       181
       -
         (* Run the server *)

     

       182
       -
         run_server server
     

       0

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       3
       +
       open Mcp_server

     

       4
        
       

     

       5
        
       (* Helper for extracting string value from JSON *)

     

       6
        
       let get_string_param json name =

     
···

       158
        
       

     

       159
        
       (* Main function *)

     

       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
       +
       

     

       170
        
         (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)

     

       171
        
         Printf.fprintf stderr "Starting CompletionServer...\n";

     

       172
        
         flush stderr;

     
···

       188
        
         ] in

     

       189
        
         set_capabilities server capabilities;

     

       190
        
         

     

       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

···

       1
        
       (executable

     

       2
        
        (name server)

     

       3
       -
        (libraries mcp yojson unix))

     

       0
        
       
     

       4
        
       

     

       5
        
       (executable

     

       6
        
        (name capitalize_sdk)

     

       7
        
        (modules capitalize_sdk)

     

       8
       -
        (libraries mcp mcp_sdk yojson unix))

     

       0
        
       
     

       9
        
       

     

       10
        
       (executable

     

       11
        
        (name audio_example)

     

       12
        
        (modules audio_example)

     

       13
       -
        (libraries mcp mcp_sdk yojson unix))

     

       0
        
       
     

       14
        
       

     

       15
        
       (executable

     

       16
        
        (name resource_template_example)

     

       17
        
        (modules resource_template_example)

     

       18
       -
        (libraries mcp mcp_sdk yojson unix))

     

       0
        
       
     

       19
        
       

     

       20
        
       (executable

     

       21
        
        (name completion_example)

     

       22
        
        (modules completion_example)

     

       23
       -
        (libraries mcp mcp_sdk yojson unix))
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

···

       1
        
       (executable

     

       2
        
        (name server)

     

       3
       +
        (libraries mcp yojson unix)

     

       4
       +
        (flags (:standard -w -8-11)))

     

       5
        
       

     

       6
        
       (executable

     

       7
        
        (name capitalize_sdk)

     

       8
        
        (modules capitalize_sdk)

     

       9
       +
        (libraries mcp mcp_sdk mcp_server yojson unix)

     

       10
       +
        (flags (:standard -w -33)))

     

       11
        
       

     

       12
        
       (executable

     

       13
        
        (name audio_example)

     

       14
        
        (modules audio_example)

     

       15
       +
        (libraries mcp mcp_sdk mcp_server yojson unix)

     

       16
       +
        (flags (:standard -w -33)))

     

       17
        
       

     

       18
        
       (executable

     

       19
        
        (name resource_template_example)

     

       20
        
        (modules resource_template_example)

     

       21
       +
        (libraries mcp mcp_sdk mcp_server yojson unix)

     

       22
       +
        (flags (:standard -w -33)))

     

       23
        
       

     

       24
        
       (executable

     

       25
        
        (name completion_example)

     

       26
        
        (modules completion_example)

     

       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

···

       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

···

       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

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       0
        
       
     

       3
        
       

     

       4
        
       (* Helper for extracting string value from JSON *)

     

       5
        
       let get_string_param json name =

     
···

       164
        
       

     

       165
        
       (* Main function *)

     

       166
        
       let () =

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       167
        
         (* Instead of printing directly to stdout which messes up the JSON-RPC protocol,

     

       168
        
            use the logging system which sends output to stderr *)

     

       169
        
         Log.info "Starting ResourceTemplateServer...";

     
···

       171
        
         (* Configure the server with appropriate capabilities *)

     

       172
        
         ignore (configure_server server ());

     

       173
        
         

     

       174
       -
         (* Run the server *)

     

       175
       -
         run_server server
     

       0

···

       1
        
       open Mcp

     

       2
        
       open Mcp_sdk

     

       3
       +
       open Mcp_server

     

       4
        
       

     

       5
        
       (* Helper for extracting string value from JSON *)

     

       6
        
       let get_string_param json name =

     
···

       165
        
       

     

       166
        
       (* Main function *)

     

       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
       +
       

     

       177
        
         (* Instead of printing directly to stdout which messes up the JSON-RPC protocol,

     

       178
        
            use the logging system which sends output to stderr *)

     

       179
        
         Log.info "Starting ResourceTemplateServer...";

     
···

       181
        
         (* Configure the server with appropriate capabilities *)

     

       182
        
         ignore (configure_server server ());

     

       183
        
         

     

       184
       +
         (* Create and start MCP server with the selected transport *)

     

       185
       +
         let mcp_server = create ~server ~transport:!transport_type () in

     

       186
       +
         start mcp_server

lib/dune

···

       8
        
         (libraries mcp jsonrpc unix yojson)

     

       9
        
         (modules mcp_sdk)

     

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

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

···

       8
        
         (libraries mcp jsonrpc unix yojson)

     

       9
        
         (modules mcp_sdk)

     

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

     

       11
       +
       

     

       12
       +
       (library

     

       13
       +
         (name mcp_server)

     

       14
       +
         (libraries mcp mcp_sdk jsonrpc unix yojson)

     

       15
       +
         (modules mcp_server)

     

       16
       +
         (flags (:standard -w -67 -w -27 -w -32 -w -8 -w -11 -w -33)))

+78 -7

lib/mcp_sdk.ml

···

       16
        
       

     

       17
        
         let log level msg =

     

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

     

       19
       -
           flush stderr;

     

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

     

       21
       -
           flush stdout

     

       22
        
       

     

       23
        
         let debug = log Debug

     

       24
        
         let info = log Info

     
···

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

     

       136
        
           { name; description; required }

     

       137
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       138
        
         let to_json prompt =

     

       139
        
           let assoc = [

     

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

     
···

       171
        
       let make_text_content text =

     

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

     

       173
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       174
        
       let make_tool_schema properties required =

     

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

     

       176
        
           (name, `Assoc [

     
···

       352
        
       let set_shutdown_hook server hook =

     

       353
        
         server.shutdown_hook <- Some hook

     

       354
        
       

     

       355
       -
       (* Run the server *)

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       356
        
       let run_server server =

     

       357
        
         (* Setup *)

     

       358
        
         Printexc.record_backtrace true;

     

       359
       -
         set_binary_mode_out stdout false;

     

       360
        
         

     

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

     

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

     

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

     

       364
        
         

     
···

       371
        
          | Some hook -> hook ()

     

       372
        
          | None -> ());

     

       373
        
         

     

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

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0

···

       16
        
       

     

       17
        
         let log level msg =

     

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

     

       19
       +
           flush stderr

     

       0
        
       
     

       0
        
       
     

       20
        
       

     

       21
        
         let debug = log Debug

     

       22
        
         let info = log Info

     
···

       133
        
         let create_argument ~name ?description ?(required=false) () =

     

       134
        
           { name; description; required }

     

       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
       +
       

     

       168
        
         let to_json prompt =

     

       169
        
           let assoc = [

     

       170
        
             ("name", `String prompt.name);

     
···

       201
        
       let make_text_content text =

     

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

     

       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
       +
       

     

       231
        
       let make_tool_schema properties required =

     

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

     

       233
        
           (name, `Assoc [

     
···

       409
        
       let set_shutdown_hook server hook =

     

       410
        
         server.shutdown_hook <- Some hook

     

       411
        
       

     

       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 *)

     

       418
        
       let run_server server =

     

       419
        
         (* Setup *)

     

       420
        
         Printexc.record_backtrace true;

     

       0
        
       
     

       421
        
         

     

       422
       +
         Log.info (Printf.sprintf "%s server starting" server.name);

     

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

     

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

     

       425
        
         

     
···

       432
        
          | Some hook -> hook ()

     

       433
        
          | None -> ());

     

       434
        
         

     

       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

···

       86
        
       

     

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

     

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

     

       0
        
       
     

       0
        
       
     

       89
        
         val to_json : t -> Json.t

     

       90
        
       end

     

       91
        
       

     
···

       139
        
       (** Set shutdown hook *)

     

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

     

       141
        
       

     

       142
       -
       (** Run the server *)

     

       143
        
       val run_server : server -> unit

     

       144
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

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

     

       146
        
       val make_text_content : string -> content

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

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

···

       86
        
       

     

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

     

       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

     

       91
        
         val to_json : t -> Json.t

     

       92
        
       end

     

       93
        
       

     
···

       141
        
       (** Set shutdown hook *)

     

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

     

       143
        
       

     

       144
       +
       (** Run the server using stdio transport (legacy method) *)

     

       145
        
       val run_server : server -> unit

     

       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
       +
       

     

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

     

       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

     

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

+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

···

       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