commit f3f0f54b12eeb8d322fb8a377e41fdbd24bee229 · anil.recoil.org/slop

claudeio/claude.opam

···

       7
       7
        
         "ocaml"

     

       8
       8
        
         "dune" {>= "3.0"}

     

       9
       9
        
         "eio"

     

       10
       10
       +
         "fmt"

     

       11
       11
       +
         "logs"

     

       10
       12
        
         "ezjsonm"

     

       11
       13
        
         "alcotest" {with-test}

     

       12
       14
        
         "odoc" {with-doc}

+3 -1

claudeio/dune-project

···

       10
       10
        
         ocaml

     

       11
       11
        
         dune

     

       12
       12
        
         eio

     

       13
       13
       +
         fmt

     

       14
       14
       +
         logs

     

       13
       15
        
         ezjsonm

     

       14
       14
       -
         (alcotest :with-test)))
     

       16
       16
       +
         (alcotest :with-test)))

+2 -1

claudeio/lib/claude.ml

···

       1
       1
       -
       module Types = Types

     

       1
       1
       +
       module Content_block = Content_block

     

       2
       2
        
       module Message = Message

     

       3
       3
       +
       module Control = Control

     

       3
       4
        
       module Permissions = Permissions

     

       4
       5
        
       module Options = Options

     

       5
       6
        
       module Transport = Transport

+165 -2

claudeio/lib/claude.mli

···

       1
       1
       -
       module Types = Types

     

       1
       1
       +
       (** OCaml Eio library for Claude Code CLI.

     

       2
       2
       +
       

     

       3
       3
       +
           This library provides an interface to the Claude Code command-line interface

     

       4
       4
       +
           using OCaml's Eio concurrency library. It wraps Claude CLI invocations with

     

       5
       5
       +
           JSON streaming for asynchronous communication.

     

       6
       6
       +
       

     

       7
       7
       +
           {1 Overview}

     

       8
       8
       +
       

     

       9
       9
       +
           The Claude library enables you to:

     

       10
       10
       +
           - Send messages to Claude and receive streaming responses

     

       11
       11
       +
           - Control tool permissions and execution

     

       12
       12
       +
           - Configure system prompts and model parameters

     

       13
       13
       +
           - Handle content blocks including text, tool use, and thinking blocks

     

       14
       14
       +
           - Manage sessions with proper resource cleanup

     

       15
       15
       +
       

     

       16
       16
       +
           {1 Architecture}

     

       17
       17
       +
       

     

       18
       18
       +
           The library is structured into several focused modules:

     

       19
       19
       +
       

     

       20
       20
       +
           - {!Content_block}: Defines content blocks (text, tool use, tool results, thinking)

     

       21
       21
       +
           - {!Message}: Messages exchanged with Claude (user, assistant, system, result)

     

       22
       22
       +
           - {!Control}: Control flow messages for session management

     

       23
       23
       +
           - {!Permissions}: Fine-grained permission system for tool usage

     

       24
       24
       +
           - {!Options}: Configuration options for Claude sessions

     

       25
       25
       +
           - {!Transport}: Low-level transport layer for CLI communication

     

       26
       26
       +
           - {!Client}: High-level client interface for interacting with Claude

     

       27
       27
       +
       

     

       28
       28
       +
           {1 Basic Usage}

     

       29
       29
       +
       

     

       30
       30
       +
           {[

     

       31
       31
       +
             open Claude

     

       32
       32
       +
             

     

       33
       33
       +
             (* Create a simple query *)

     

       34
       34
       +
             let query_claude ~sw env prompt =

     

       35
       35
       +
               let options = Options.default in

     

       36
       36
       +
               Client.query ~sw env ~options prompt

     

       37
       37
       +
             

     

       38
       38
       +
             (* Process streaming responses *)

     

       39
       39
       +
             let process_response messages =

     

       40
       40
       +
               Seq.iter (function

     

       41
       41
       +
                 | Message.Assistant msg ->

     

       42
       42
       +
                     List.iter (function

     

       43
       43
       +
                       | Content_block.Text t ->

     

       44
       44
       +
                           print_endline (Content_block.Text.text t)

     

       45
       45
       +
                       | _ -> ()

     

       46
       46
       +
                     ) (Message.Assistant.content msg)

     

       47
       47
       +
                 | _ -> ()

     

       48
       48
       +
               ) messages

     

       49
       49
       +
           ]}

     

       50
       50
       +
       

     

       51
       51
       +
           {1 Advanced Features}

     

       52
       52
       +
       

     

       53
       53
       +
           {2 Tool Permissions}

     

       54
       54
       +
       

     

       55
       55
       +
           Control which tools Claude can use and how:

     

       56
       56
       +
       

     

       57
       57
       +
           {[

     

       58
       58
       +
             let options = 

     

       59
       59
       +
               Options.default

     

       60
       60
       +
               |> Options.with_allowed_tools ["Read"; "Write"; "Bash"]

     

       61
       61
       +
               |> Options.with_permission_mode Permissions.Mode.Accept_edits

     

       62
       62
       +
           ]}

     

       63
       63
       +
       

     

       64
       64
       +
           {2 Custom Permission Callbacks}

     

       65
       65
       +
       

     

       66
       66
       +
           Implement custom logic for tool approval:

     

       67
       67
       +
       

     

       68
       68
       +
           {[

     

       69
       69
       +
             let my_callback ~tool_name ~input ~context =

     

       70
       70
       +
               if tool_name = "Bash" then

     

       71
       71
       +
                 Permissions.Result.deny ~message:"Bash not allowed" ~interrupt:false

     

       72
       72
       +
               else

     

       73
       73
       +
                 Permissions.Result.allow ()

     

       74
       74
       +
             

     

       75
       75
       +
             let options = Options.default |> Options.with_permission_callback my_callback

     

       76
       76
       +
           ]}

     

       77
       77
       +
       

     

       78
       78
       +
           {2 System Prompts}

     

       79
       79
       +
       

     

       80
       80
       +
           Customize Claude's behavior with system prompts:

     

       81
       81
       +
       

     

       82
       82
       +
           {[

     

       83
       83
       +
             let options = 

     

       84
       84
       +
               Options.default

     

       85
       85
       +
               |> Options.with_system_prompt "You are a helpful OCaml programming assistant."

     

       86
       86
       +
               |> Options.with_append_system_prompt "Always use Jane Street style."

     

       87
       87
       +
           ]}

     

       88
       88
       +
       

     

       89
       89
       +
           {1 Logging}

     

       90
       90
       +
       

     

       91
       91
       +
           The library uses the Logs library for structured logging. Each module has its

     

       92
       92
       +
           own log source (e.g., "claude.message", "claude.transport") allowing fine-grained

     

       93
       93
       +
           control over logging verbosity:

     

       94
       94
       +
       

     

       95
       95
       +
           {[

     

       96
       96
       +
             (* Enable debug logging for message handling *)

     

       97
       97
       +
             Logs.Src.set_level Message.src (Some Logs.Debug);

     

       98
       98
       +
             

     

       99
       99
       +
             (* Enable info logging for transport layer *)

     

       100
       100
       +
             Logs.Src.set_level Transport.src (Some Logs.Info);

     

       101
       101
       +
           ]}

     

       102
       102
       +
       

     

       103
       103
       +
           {1 Error Handling}

     

       104
       104
       +
       

     

       105
       105
       +
           The library uses exceptions for error handling. Common exceptions include:

     

       106
       106
       +
           - [Invalid_argument]: For malformed JSON or invalid parameters

     

       107
       107
       +
           - [Transport.Transport_error]: For CLI communication failures

     

       108
       108
       +
           - [Message.Message_parse_error]: For message parsing failures

     

       109
       109
       +
       

     

       110
       110
       +
           {1 Example: Complete Session}

     

       111
       111
       +
       

     

       112
       112
       +
           {[

     

       113
       113
       +
             let run_claude_session ~sw env =

     

       114
       114
       +
               let options = 

     

       115
       115
       +
                 Options.create

     

       116
       116
       +
                   ~allowed_tools:["Read"; "Write"]

     

       117
       117
       +
                   ~permission_mode:Permissions.Mode.Accept_edits

     

       118
       118
       +
                   ~system_prompt:"You are an OCaml expert."

     

       119
       119
       +
                   ~max_thinking_tokens:10000

     

       120
       120
       +
                   ()

     

       121
       121
       +
               in

     

       122
       122
       +
               

     

       123
       123
       +
               let prompt = "Write a function to calculate fibonacci numbers" in

     

       124
       124
       +
               let messages = Client.query ~sw env ~options prompt in

     

       125
       125
       +
               

     

       126
       126
       +
               Seq.iter (fun msg ->

     

       127
       127
       +
                 Message.log_received msg;

     

       128
       128
       +
                 match msg with

     

       129
       129
       +
                 | Message.Assistant assistant ->

     

       130
       130
       +
                     Printf.printf "Claude: %s\n" 

     

       131
       131
       +
                       (Message.Assistant.model assistant);

     

       132
       132
       +
                     List.iter (function

     

       133
       133
       +
                       | Content_block.Text t ->

     

       134
       134
       +
                           print_endline (Content_block.Text.text t)

     

       135
       135
       +
                       | Content_block.Tool_use t ->

     

       136
       136
       +
                           Printf.printf "Using tool: %s\n" 

     

       137
       137
       +
                             (Content_block.Tool_use.name t)

     

       138
       138
       +
                       | _ -> ()

     

       139
       139
       +
                     ) (Message.Assistant.content assistant)

     

       140
       140
       +
                 | Message.Result result ->

     

       141
       141
       +
                     Printf.printf "Session complete. Duration: %dms\n"

     

       142
       142
       +
                       (Message.Result.duration_ms result)

     

       143
       143
       +
                 | _ -> ()

     

       144
       144
       +
               ) messages

     

       145
       145
       +
           ]}

     

       146
       146
       +
       *)

     

       147
       147
       +
       

     

       148
       148
       +
       (** {1 Modules} *)

     

       149
       149
       +
       

     

       150
       150
       +
       module Content_block = Content_block

     

       151
       151
       +
       (** Content blocks for messages (text, tool use, tool results, thinking). *)

     

       152
       152
       +
       

     

       2
       153
        
       module Message = Message

     

       154
       154
       +
       (** Messages exchanged with Claude (user, assistant, system, result). *)

     

       155
       155
       +
       

     

       156
       156
       +
       module Control = Control

     

       157
       157
       +
       (** Control messages for session management. *)

     

       158
       158
       +
       

     

       3
       159
        
       module Permissions = Permissions

     

       160
       160
       +
       (** Permission system for tool invocations. *)

     

       161
       161
       +
       

     

       4
       162
        
       module Options = Options

     

       163
       163
       +
       (** Configuration options for Claude sessions. *)

     

       164
       164
       +
       

     

       5
       165
        
       module Transport = Transport

     

       6
       6
       -
       module Client = Client
     

       166
       166
       +
       (** Low-level transport layer for CLI communication. *)

     

       167
       167
       +
       

     

       168
       168
       +
       module Client = Client

     

       169
       169
       +
       (** High-level client interface for Claude interactions. *)

+58 -60

claudeio/lib/client.ml

···

       1
       1
       -
       open Eio.Std

     

       1
       1
       +
       let src = Logs.Src.create "claude.client" ~doc:"Claude client"

     

       2
       2
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       2
       3
        
       

     

       3
       4
        
       type t = {

     

       4
       5
        
         transport : Transport.t;

     

       5
       5
       -
         receive_stream : Types.message Eio.Stream.t;

     

       6
       6
       -
         receive_fiber : unit Eio.Promise.or_exn;

     

       7
       7
       -
         control_stream : Types.control_message Eio.Stream.t;

     

       8
       6
        
         permission_callback : Permissions.callback option;

     

       9
       9
       -
         permission_log : Permissions.rule list ref option;

     

       7
       7
       +
         permission_log : Permissions.Rule.t list ref option;

     

       10
       8
        
         mutable session_id : string option;

     

       11
       9
        
       }

     

       12
       10
        
       

     

       13
       11
        
       let handle_control_request t control_msg =

     

       14
       12
        
         let open Ezjsonm in

     

       15
       15
       -
         match find control_msg.Types.data ["request"; "subtype"] |> get_string with

     

       13
       13
       +
         let data = Control.data control_msg in

     

       14
       14
       +
         match find data ["request"; "subtype"] |> get_string with

     

       16
       15
        
         | "can_use_tool" ->

     

       17
       17
       -
             let tool_name = find control_msg.data ["request"; "tool_name"] |> get_string in

     

       18
       18
       -
             let input = find control_msg.data ["request"; "input"] in

     

       16
       16
       +
             let tool_name = find data ["request"; "tool_name"] |> get_string in

     

       17
       17
       +
             let input = find data ["request"; "input"] in

     

       19
       18
        
             let suggestions = 

     

       20
       19
        
               try

     

       21
       21
       -
                 let sugg_json = find control_msg.data ["request"; "permission_suggestions"] in

     

       20
       20
       +
                 let sugg_json = find data ["request"; "permission_suggestions"] in

     

       22
       21
        
                 match sugg_json with

     

       23
       22
        
                 | `A _ -> 

     

       24
       23
        
                     (* TODO: Parse permission suggestions *)

     
···

       26
       25
        
                 | _ -> []

     

       27
       26
        
               with Not_found -> []

     

       28
       27
        
             in

     

       29
       29
       -
             let context = Permissions.{ suggestions } in

     

       28
       28
       +
             let context = Permissions.Context.create ~suggestions () in

     

       30
       29
        
             

     

       31
       30
        
             let result = match t.permission_callback with

     

       32
       31
        
               | Some callback -> callback ~tool_name ~input ~context

     
···

       37
       36
        
               "type", string "control_response";

     

       38
       37
        
               "response", dict [

     

       39
       38
        
                 "subtype", string "success";

     

       40
       40
       -
                 "request_id", string control_msg.request_id;

     

       41
       41
       -
                 "response", Permissions.serialize_result result

     

       39
       39
       +
                 "request_id", string (Control.request_id control_msg);

     

       40
       40
       +
                 "response", Permissions.Result.to_json result

     

       42
       41
        
               ]

     

       43
       42
        
             ] in

     

       44
       43
        
             Transport.send t.transport response

     
···

       49
       48
        
               "type", string "control_response";

     

       50
       49
        
               "response", dict [

     

       51
       50
        
                 "subtype", string "error";

     

       52
       52
       -
                 "request_id", string control_msg.request_id;

     

       51
       51
       +
                 "request_id", string (Control.request_id control_msg);

     

       53
       52
        
                 "error", string (Printf.sprintf "Unsupported control request: %s" subtype)

     

       54
       53
        
               ]

     

       55
       54
        
             ] in

     

       56
       55
        
             Transport.send t.transport response

     

       57
       56
        
       

     

       58
       58
       -
       let receiver_loop t =

     

       57
       57
       +
       let handle_messages t =

     

       59
       58
        
         let rec loop () =

     

       60
       59
        
           match Transport.receive_line t.transport with

     

       61
       61
       -
           | None -> ()  (* EOF *)

     

       60
       60
       +
           | None -> 

     

       61
       61
       +
               (* EOF *)

     

       62
       62
       +
               Log.debug (fun m -> m "Handle messages: EOF received");

     

       63
       63
       +
               Seq.Nil

     

       62
       64
        
           | Some line ->

     

       63
       65
        
                 try

     

       64
       66
        
                   let json = Ezjsonm.value_from_string line in

     
···

       66
       68
        
                   (* Check if it's a control request *)

     

       67
       69
        
                   match Ezjsonm.find json ["type"] |> Ezjsonm.get_string with

     

       68
       70
        
                   | "control_request" ->

     

       69
       69
       -
                       let control_msg = Types.{

     

       70
       70
       -
                         request_id = Ezjsonm.find json ["request_id"] |> Ezjsonm.get_string;

     

       71
       71
       -
                         subtype = Ezjsonm.find json ["request"; "subtype"] |> Ezjsonm.get_string;

     

       72
       72
       -
                         data = json;

     

       73
       73
       -
                       } in

     

       74
       74
       -
                       Eio.Stream.add t.control_stream control_msg;

     

       75
       75
       -
                       handle_control_request t control_msg

     

       71
       71
       +
                       let control_msg = Control.create

     

       72
       72
       +
                         ~request_id:(Ezjsonm.find json ["request_id"] |> Ezjsonm.get_string)

     

       73
       73
       +
                         ~subtype:(Ezjsonm.find json ["request"; "subtype"] |> Ezjsonm.get_string)

     

       74
       74
       +
                         ~data:json in

     

       75
       75
       +
                       Log.debug (fun m -> m "Received control request: %s" (Control.subtype control_msg));

     

       76
       76
       +
                       handle_control_request t control_msg;

     

       77
       77
       +
                       loop ()

     

       76
       78
        
                   

     

       77
       79
        
                   | _ ->

     

       78
       80
        
                       (* Regular message *)

     

       79
       79
       -
                       let msg = Message.parse json in

     

       81
       81
       +
                       let msg = Message.of_json json in

     

       82
       82
       +
                       Log.debug (fun m -> m "Received message: %a" Message.pp msg);

     

       80
       83
        
                       

     

       81
       84
        
                       (* Extract session ID from system messages *)

     

       82
       85
        
                       (match msg with

     

       83
       83
       -
                       | Types.System { subtype = "init"; data } ->

     

       86
       86
       +
                       | Message.System sys when Message.System.subtype sys = "init" ->

     

       84
       87
        
                           (try

     

       85
       85
       -
                             t.session_id <- Some (Ezjsonm.find data ["session_id"] |> Ezjsonm.get_string)

     

       88
       88
       +
                             let data = Message.System.data sys in

     

       89
       89
       +
                             let session_id = Ezjsonm.find data ["session_id"] |> Ezjsonm.get_string in

     

       90
       90
       +
                             t.session_id <- Some session_id;

     

       91
       91
       +
                             Log.info (fun m -> m "Session ID: %s" session_id)

     

       86
       92
        
                           with Not_found -> ())

     

       87
       93
        
                       | _ -> ());

     

       88
       94
        
                       

     

       89
       89
       -
                       Eio.Stream.add t.receive_stream msg

     

       95
       95
       +
                       Seq.Cons (msg, loop)

     

       90
       96
        
                 with

     

       91
       97
        
                 | exn ->

     

       92
       92
       -
                     traceln "Failed to parse message: %s\nLine: %s" 

     

       93
       93
       -
                       (Printexc.to_string exn) line;

     

       94
       94
       -
                 loop ()

     

       98
       98
       +
                     Log.err (fun m -> m "Failed to parse message: %s\nLine: %s" 

     

       99
       99
       +
                       (Printexc.to_string exn) line);

     

       100
       100
       +
                     loop ()

     

       95
       101
        
         in

     

       96
       96
       -
         try

     

       97
       97
       -
           loop ()

     

       98
       98
       -
         with

     

       99
       99
       -
         | exn ->

     

       100
       100
       -
             traceln "Receiver loop error: %s" (Printexc.to_string exn);

     

       101
       101
       -
             raise exn

     

       102
       102
       +
         Log.debug (fun m -> m "Starting message handler");

     

       103
       103
       +
         loop

     

       102
       104
        
       

     

       103
       103
       -
       let create ?(options = Options.default) ~sw ~process_mgr ~fs () =

     

       104
       104
       -
         let transport = Transport.create ~sw ~process_mgr ~fs ~options () in

     

       105
       105
       -
         let receive_stream = Eio.Stream.create 100 in

     

       106
       106
       -
         let control_stream = Eio.Stream.create 10 in

     

       107
       107
       -
         

     

       108
       108
       -
         let t = {

     

       105
       105
       +
       let create ?(options = Options.default) ~sw ~process_mgr () =

     

       106
       106
       +
         let transport = Transport.create ~sw ~process_mgr ~options () in

     

       107
       107
       +
         {

     

       109
       108
        
           transport;

     

       110
       110
       -
           receive_stream;

     

       111
       111
       -
           receive_fiber = Eio.Promise.create_resolved (Ok ());  (* Placeholder *)

     

       112
       112
       -
           control_stream;

     

       113
       113
       -
           permission_callback = options.permission_callback;

     

       109
       109
       +
           permission_callback = Options.permission_callback options;

     

       114
       110
        
           permission_log = None;

     

       115
       111
        
           session_id = None;

     

       116
       116
       -
         } in

     

       117
       117
       -
         

     

       118
       118
       -
         (* Start receiver fiber *)

     

       119
       119
       -
         let receive_fiber = Fiber.fork_promise ~sw (fun () -> receiver_loop t) in

     

       120
       120
       -
         

     

       121
       121
       -
         { t with receive_fiber }

     

       112
       112
       +
         }

     

       122
       113
        
       

     

       123
       114
        
       let query t prompt =

     

       124
       124
       -
         let msg = Message.serialize_user_message (`String prompt) in

     

       125
       125
       -
         Transport.send t.transport msg

     

       115
       115
       +
         let msg = Message.user_string prompt in

     

       116
       116
       +
         Transport.send t.transport (Message.to_json msg)

     

       126
       117
        
       

     

       127
       118
        
       let send_message t json =

     

       128
       119
        
         Transport.send t.transport json

     

       129
       120
        
       

     

       130
       121
        
       let receive t =

     

       131
       131
       -
         t.receive_stream

     

       122
       122
       +
         handle_messages t

     

       132
       123
        
       

     

       133
       124
        
       let receive_all t =

     

       134
       134
       -
         let rec collect acc =

     

       135
       135
       -
           match Eio.Stream.take t.receive_stream with

     

       136
       136
       -
           | Types.Result _ as msg -> List.rev (msg :: acc)

     

       137
       137
       -
           | msg -> collect (msg :: acc)

     

       125
       125
       +
         let rec collect acc seq =

     

       126
       126
       +
           match seq () with

     

       127
       127
       +
           | Seq.Nil -> 

     

       128
       128
       +
               Log.debug (fun m -> m "receive_all: end of sequence, returning %d messages" (List.length acc));

     

       129
       129
       +
               List.rev acc

     

       130
       130
       +
           | Seq.Cons (Message.Result _ as msg, _) ->

     

       131
       131
       +
               Log.debug (fun m -> m "receive_all: got Result message, returning %d messages" (List.length acc + 1));

     

       132
       132
       +
               List.rev (msg :: acc)

     

       133
       133
       +
           | Seq.Cons (msg, rest) ->

     

       134
       134
       +
               Log.debug (fun m -> m "receive_all: got %a, continuing" Message.pp msg);

     

       135
       135
       +
               collect (msg :: acc) rest

     

       138
       136
        
         in

     

       139
       139
       -
         collect []

     

       137
       137
       +
         collect [] (handle_messages t)

     

       140
       138
        
       

     

       141
       139
        
       let interrupt t =

     

       142
       140
        
         Transport.interrupt t.transport

     
···

       150
       148
        
         }

     

       151
       149
        
       

     

       152
       150
        
       let with_permission_callback t callback =

     

       153
       153
       -
         { t with permission_callback = Some callback }
     

       151
       151
       +
         { t with permission_callback = Some callback }

+6 -4

claudeio/lib/client.mli

···

       1
       1
       +
       (** The log source for client operations *)

     

       2
       2
       +
       val src : Logs.Src.t

     

       3
       3
       +
       

     

       1
       4
        
       type t

     

       2
       5
        
       

     

       3
       6
        
       val create : 

     

       4
       7
        
         ?options:Options.t -> 

     

       5
       8
        
         sw:Eio.Switch.t -> 

     

       6
       9
        
         process_mgr:_ Eio.Process.mgr ->

     

       7
       7
       -
         fs:Eio.Fs.dir_ty Eio.Path.t ->

     

       8
       10
        
         unit -> t

     

       9
       11
        
       

     

       10
       12
        
       val query : t -> string -> unit

     

       11
       13
        
       val send_message : t -> Ezjsonm.value -> unit

     

       12
       14
        
       

     

       13
       13
       -
       val receive : t -> Types.message Eio.Stream.t

     

       14
       14
       -
       val receive_all : t -> Types.message list

     

       15
       15
       +
       val receive : t -> Message.t Seq.t

     

       16
       16
       +
       val receive_all : t -> Message.t list

     

       15
       17
        
       

     

       16
       18
        
       val interrupt : t -> unit

     

       17
       19
        
       

     

       18
       20
        
       val discover_permissions : t -> t

     

       19
       19
       -
       val with_permission_callback : t -> Permissions.callback -> t
     

       21
       21
       +
       val with_permission_callback : t -> Permissions.callback -> t

+182

claudeio/lib/content_block.ml

···

       1
       1
       +
       open Ezjsonm

     

       2
       2
       +
       

     

       3
       3
       +
       let src = Logs.Src.create "claude.content_block" ~doc:"Claude content blocks"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       5
       5
       +
       

     

       6
       6
       +
       (* Helper for pretty-printing JSON *)

     

       7
       7
       +
       let pp_json fmt json =

     

       8
       8
       +
         Fmt.string fmt (value_to_string json)

     

       9
       9
       +
       

     

       10
       10
       +
       module Text = struct

     

       11
       11
       +
         type t = { text : string }

     

       12
       12
       +
         

     

       13
       13
       +
         let create text = { text }

     

       14
       14
       +
         let text t = t.text

     

       15
       15
       +
         

     

       16
       16
       +
         let to_json t = 

     

       17
       17
       +
           `O [("type", `String "text"); ("text", `String t.text)]

     

       18
       18
       +
         

     

       19
       19
       +
         let of_json = function

     

       20
       20
       +
           | `O fields ->

     

       21
       21
       +
               let text = get_string (List.assoc "text" fields) in

     

       22
       22
       +
               { text }

     

       23
       23
       +
           | _ -> raise (Invalid_argument "Text.of_json: expected object")

     

       24
       24
       +
         

     

       25
       25
       +
         let pp fmt t = 

     

       26
       26
       +
           Fmt.pf fmt "@[<2>Text@ { text = %S }@]" t.text

     

       27
       27
       +
       end

     

       28
       28
       +
       

     

       29
       29
       +
       module Tool_use = struct

     

       30
       30
       +
         type t = {

     

       31
       31
       +
           id : string;

     

       32
       32
       +
           name : string;

     

       33
       33
       +
           input : value;

     

       34
       34
       +
         }

     

       35
       35
       +
         

     

       36
       36
       +
         let create ~id ~name ~input = { id; name; input }

     

       37
       37
       +
         let id t = t.id

     

       38
       38
       +
         let name t = t.name

     

       39
       39
       +
         let input t = t.input

     

       40
       40
       +
         

     

       41
       41
       +
         let to_json t =

     

       42
       42
       +
           `O [

     

       43
       43
       +
             ("type", `String "tool_use");

     

       44
       44
       +
             ("id", `String t.id);

     

       45
       45
       +
             ("name", `String t.name);

     

       46
       46
       +
             ("input", t.input);

     

       47
       47
       +
           ]

     

       48
       48
       +
         

     

       49
       49
       +
         let of_json = function

     

       50
       50
       +
           | `O fields ->

     

       51
       51
       +
               let id = get_string (List.assoc "id" fields) in

     

       52
       52
       +
               let name = get_string (List.assoc "name" fields) in

     

       53
       53
       +
               let input = List.assoc "input" fields in

     

       54
       54
       +
               { id; name; input }

     

       55
       55
       +
           | _ -> raise (Invalid_argument "Tool_use.of_json: expected object")

     

       56
       56
       +
         

     

       57
       57
       +
         let pp fmt t =

     

       58
       58
       +
           Fmt.pf fmt "@[<2>Tool_use@ { id = %S;@ name = %S;@ input = %a }@]"

     

       59
       59
       +
             t.id t.name pp_json t.input

     

       60
       60
       +
       end

     

       61
       61
       +
       

     

       62
       62
       +
       module Tool_result = struct

     

       63
       63
       +
         type t = {

     

       64
       64
       +
           tool_use_id : string;

     

       65
       65
       +
           content : string option;

     

       66
       66
       +
           is_error : bool option;

     

       67
       67
       +
         }

     

       68
       68
       +
         

     

       69
       69
       +
         let create ~tool_use_id ?content ?is_error () = 

     

       70
       70
       +
           { tool_use_id; content; is_error }

     

       71
       71
       +
         

     

       72
       72
       +
         let tool_use_id t = t.tool_use_id

     

       73
       73
       +
         let content t = t.content

     

       74
       74
       +
         let is_error t = t.is_error

     

       75
       75
       +
         

     

       76
       76
       +
         let to_json t =

     

       77
       77
       +
           let fields = [

     

       78
       78
       +
             ("type", `String "tool_result");

     

       79
       79
       +
             ("tool_use_id", `String t.tool_use_id);

     

       80
       80
       +
           ] in

     

       81
       81
       +
           let fields = match t.content with

     

       82
       82
       +
             | Some c -> ("content", `String c) :: fields

     

       83
       83
       +
             | None -> fields

     

       84
       84
       +
           in

     

       85
       85
       +
           let fields = match t.is_error with

     

       86
       86
       +
             | Some e -> ("is_error", `Bool e) :: fields

     

       87
       87
       +
             | None -> fields

     

       88
       88
       +
           in

     

       89
       89
       +
           `O fields

     

       90
       90
       +
         

     

       91
       91
       +
         let of_json = function

     

       92
       92
       +
           | `O fields ->

     

       93
       93
       +
               let tool_use_id = get_string (List.assoc "tool_use_id" fields) in

     

       94
       94
       +
               let content = 

     

       95
       95
       +
                 try Some (get_string (List.assoc "content" fields))

     

       96
       96
       +
                 with Not_found -> None

     

       97
       97
       +
               in

     

       98
       98
       +
               let is_error =

     

       99
       99
       +
                 try Some (get_bool (List.assoc "is_error" fields))

     

       100
       100
       +
                 with Not_found -> None

     

       101
       101
       +
               in

     

       102
       102
       +
               { tool_use_id; content; is_error }

     

       103
       103
       +
           | _ -> raise (Invalid_argument "Tool_result.of_json: expected object")

     

       104
       104
       +
         

     

       105
       105
       +
         let pp fmt t =

     

       106
       106
       +
           Fmt.pf fmt "@[<2>Tool_result@ { tool_use_id = %S;@ content = %a;@ is_error = %a }@]"

     

       107
       107
       +
             t.tool_use_id

     

       108
       108
       +
             Fmt.(option string) t.content

     

       109
       109
       +
             Fmt.(option bool) t.is_error

     

       110
       110
       +
       end

     

       111
       111
       +
       

     

       112
       112
       +
       module Thinking = struct

     

       113
       113
       +
         type t = {

     

       114
       114
       +
           thinking : string;

     

       115
       115
       +
           signature : string;

     

       116
       116
       +
         }

     

       117
       117
       +
         

     

       118
       118
       +
         let create ~thinking ~signature = { thinking; signature }

     

       119
       119
       +
         let thinking t = t.thinking

     

       120
       120
       +
         let signature t = t.signature

     

       121
       121
       +
         

     

       122
       122
       +
         let to_json t =

     

       123
       123
       +
           `O [

     

       124
       124
       +
             ("type", `String "thinking");

     

       125
       125
       +
             ("thinking", `String t.thinking);

     

       126
       126
       +
             ("signature", `String t.signature);

     

       127
       127
       +
           ]

     

       128
       128
       +
         

     

       129
       129
       +
         let of_json = function

     

       130
       130
       +
           | `O fields ->

     

       131
       131
       +
               let thinking = get_string (List.assoc "thinking" fields) in

     

       132
       132
       +
               let signature = get_string (List.assoc "signature" fields) in

     

       133
       133
       +
               { thinking; signature }

     

       134
       134
       +
           | _ -> raise (Invalid_argument "Thinking.of_json: expected object")

     

       135
       135
       +
         

     

       136
       136
       +
         let pp fmt t =

     

       137
       137
       +
           Fmt.pf fmt "@[<2>Thinking@ { thinking = %S;@ signature = %S }@]"

     

       138
       138
       +
             t.thinking t.signature

     

       139
       139
       +
       end

     

       140
       140
       +
       

     

       141
       141
       +
       type t =

     

       142
       142
       +
         | Text of Text.t

     

       143
       143
       +
         | Tool_use of Tool_use.t

     

       144
       144
       +
         | Tool_result of Tool_result.t

     

       145
       145
       +
         | Thinking of Thinking.t

     

       146
       146
       +
       

     

       147
       147
       +
       let text s = Text (Text.create s)

     

       148
       148
       +
       let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)

     

       149
       149
       +
       let tool_result ~tool_use_id ?content ?is_error () = 

     

       150
       150
       +
         Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())

     

       151
       151
       +
       let thinking ~thinking ~signature = 

     

       152
       152
       +
         Thinking (Thinking.create ~thinking ~signature)

     

       153
       153
       +
       

     

       154
       154
       +
       let to_json = function

     

       155
       155
       +
         | Text t -> Text.to_json t

     

       156
       156
       +
         | Tool_use t -> Tool_use.to_json t

     

       157
       157
       +
         | Tool_result t -> Tool_result.to_json t

     

       158
       158
       +
         | Thinking t -> Thinking.to_json t

     

       159
       159
       +
       

     

       160
       160
       +
       let of_json json =

     

       161
       161
       +
         match json with

     

       162
       162
       +
         | `O fields -> (

     

       163
       163
       +
             match List.assoc_opt "type" fields with

     

       164
       164
       +
             | Some (`String "text") -> Text (Text.of_json json)

     

       165
       165
       +
             | Some (`String "tool_use") -> Tool_use (Tool_use.of_json json)

     

       166
       166
       +
             | Some (`String "tool_result") -> Tool_result (Tool_result.of_json json)

     

       167
       167
       +
             | Some (`String "thinking") -> Thinking (Thinking.of_json json)

     

       168
       168
       +
             | _ -> raise (Invalid_argument "Content_block.of_json: unknown type")

     

       169
       169
       +
           )

     

       170
       170
       +
         | _ -> raise (Invalid_argument "Content_block.of_json: expected object")

     

       171
       171
       +
       

     

       172
       172
       +
       let pp fmt = function

     

       173
       173
       +
         | Text t -> Text.pp fmt t

     

       174
       174
       +
         | Tool_use t -> Tool_use.pp fmt t

     

       175
       175
       +
         | Tool_result t -> Tool_result.pp fmt t

     

       176
       176
       +
         | Thinking t -> Thinking.pp fmt t

     

       177
       177
       +
       

     

       178
       178
       +
       let log_received t =

     

       179
       179
       +
         Log.debug (fun m -> m "Received content block: %a" pp t)

     

       180
       180
       +
       

     

       181
       181
       +
       let log_sending t =

     

       182
       182
       +
         Log.debug (fun m -> m "Sending content block: %a" pp t)

+171

claudeio/lib/content_block.mli

···

       1
       1
       +
       (** Content blocks for Claude messages.

     

       2
       2
       +
           

     

       3
       3
       +
           This module defines the various types of content blocks that can appear

     

       4
       4
       +
           in Claude messages, including text, tool use, tool results, and thinking blocks. *)

     

       5
       5
       +
       

     

       6
       6
       +
       open Ezjsonm

     

       7
       7
       +
       

     

       8
       8
       +
       (** The log source for content block operations *)

     

       9
       9
       +
       val src : Logs.Src.t

     

       10
       10
       +
       

     

       11
       11
       +
       (** {1 Text Blocks} *)

     

       12
       12
       +
       

     

       13
       13
       +
       module Text : sig

     

       14
       14
       +
         (** Plain text content blocks. *)

     

       15
       15
       +
         

     

       16
       16
       +
         type t

     

       17
       17
       +
         (** The type of text blocks. *)

     

       18
       18
       +
         

     

       19
       19
       +
         val create : string -> t

     

       20
       20
       +
         (** [create text] creates a new text block with the given text content. *)

     

       21
       21
       +
         

     

       22
       22
       +
         val text : t -> string

     

       23
       23
       +
         (** [text t] returns the text content of the block. *)

     

       24
       24
       +
         

     

       25
       25
       +
         val to_json : t -> value

     

       26
       26
       +
         (** [to_json t] converts the text block to its JSON representation. *)

     

       27
       27
       +
         

     

       28
       28
       +
         val of_json : value -> t

     

       29
       29
       +
         (** [of_json json] parses a text block from JSON. 

     

       30
       30
       +
             @raise Invalid_argument if the JSON is not a valid text block. *)

     

       31
       31
       +
         

     

       32
       32
       +
         val pp : Format.formatter -> t -> unit

     

       33
       33
       +
         (** [pp fmt t] pretty-prints the text block. *)

     

       34
       34
       +
       end

     

       35
       35
       +
       

     

       36
       36
       +
       (** {1 Tool Use Blocks} *)

     

       37
       37
       +
       

     

       38
       38
       +
       module Tool_use : sig

     

       39
       39
       +
         (** Tool invocation requests from the assistant. *)

     

       40
       40
       +
         

     

       41
       41
       +
         type t

     

       42
       42
       +
         (** The type of tool use blocks. *)

     

       43
       43
       +
         

     

       44
       44
       +
         val create : id:string -> name:string -> input:value -> t

     

       45
       45
       +
         (** [create ~id ~name ~input] creates a new tool use block.

     

       46
       46
       +
             @param id Unique identifier for this tool invocation

     

       47
       47
       +
             @param name Name of the tool to invoke

     

       48
       48
       +
             @param input JSON parameters for the tool *)

     

       49
       49
       +
         

     

       50
       50
       +
         val id : t -> string

     

       51
       51
       +
         (** [id t] returns the unique identifier of the tool use. *)

     

       52
       52
       +
         

     

       53
       53
       +
         val name : t -> string

     

       54
       54
       +
         (** [name t] returns the name of the tool being invoked. *)

     

       55
       55
       +
         

     

       56
       56
       +
         val input : t -> value

     

       57
       57
       +
         (** [input t] returns the JSON input parameters for the tool. *)

     

       58
       58
       +
         

     

       59
       59
       +
         val to_json : t -> value

     

       60
       60
       +
         (** [to_json t] converts the tool use block to its JSON representation. *)

     

       61
       61
       +
         

     

       62
       62
       +
         val of_json : value -> t

     

       63
       63
       +
         (** [of_json json] parses a tool use block from JSON.

     

       64
       64
       +
             @raise Invalid_argument if the JSON is not a valid tool use block. *)

     

       65
       65
       +
         

     

       66
       66
       +
         val pp : Format.formatter -> t -> unit

     

       67
       67
       +
         (** [pp fmt t] pretty-prints the tool use block. *)

     

       68
       68
       +
       end

     

       69
       69
       +
       

     

       70
       70
       +
       (** {1 Tool Result Blocks} *)

     

       71
       71
       +
       

     

       72
       72
       +
       module Tool_result : sig

     

       73
       73
       +
         (** Results from tool invocations. *)

     

       74
       74
       +
         

     

       75
       75
       +
         type t

     

       76
       76
       +
         (** The type of tool result blocks. *)

     

       77
       77
       +
         

     

       78
       78
       +
         val create : tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t

     

       79
       79
       +
         (** [create ~tool_use_id ?content ?is_error ()] creates a new tool result block.

     

       80
       80
       +
             @param tool_use_id The ID of the corresponding tool use block

     

       81
       81
       +
             @param content Optional result content

     

       82
       82
       +
             @param is_error Whether the tool execution resulted in an error *)

     

       83
       83
       +
         

     

       84
       84
       +
         val tool_use_id : t -> string

     

       85
       85
       +
         (** [tool_use_id t] returns the ID of the corresponding tool use. *)

     

       86
       86
       +
         

     

       87
       87
       +
         val content : t -> string option

     

       88
       88
       +
         (** [content t] returns the optional result content. *)

     

       89
       89
       +
         

     

       90
       90
       +
         val is_error : t -> bool option

     

       91
       91
       +
         (** [is_error t] returns whether this result represents an error. *)

     

       92
       92
       +
         

     

       93
       93
       +
         val to_json : t -> value

     

       94
       94
       +
         (** [to_json t] converts the tool result block to its JSON representation. *)

     

       95
       95
       +
         

     

       96
       96
       +
         val of_json : value -> t

     

       97
       97
       +
         (** [of_json json] parses a tool result block from JSON.

     

       98
       98
       +
             @raise Invalid_argument if the JSON is not a valid tool result block. *)

     

       99
       99
       +
         

     

       100
       100
       +
         val pp : Format.formatter -> t -> unit

     

       101
       101
       +
         (** [pp fmt t] pretty-prints the tool result block. *)

     

       102
       102
       +
       end

     

       103
       103
       +
       

     

       104
       104
       +
       (** {1 Thinking Blocks} *)

     

       105
       105
       +
       

     

       106
       106
       +
       module Thinking : sig

     

       107
       107
       +
         (** Assistant's internal reasoning blocks. *)

     

       108
       108
       +
         

     

       109
       109
       +
         type t

     

       110
       110
       +
         (** The type of thinking blocks. *)

     

       111
       111
       +
         

     

       112
       112
       +
         val create : thinking:string -> signature:string -> t

     

       113
       113
       +
         (** [create ~thinking ~signature] creates a new thinking block.

     

       114
       114
       +
             @param thinking The assistant's internal reasoning

     

       115
       115
       +
             @param signature Cryptographic signature for verification *)

     

       116
       116
       +
         

     

       117
       117
       +
         val thinking : t -> string

     

       118
       118
       +
         (** [thinking t] returns the thinking content. *)

     

       119
       119
       +
         

     

       120
       120
       +
         val signature : t -> string

     

       121
       121
       +
         (** [signature t] returns the cryptographic signature. *)

     

       122
       122
       +
         

     

       123
       123
       +
         val to_json : t -> value

     

       124
       124
       +
         (** [to_json t] converts the thinking block to its JSON representation. *)

     

       125
       125
       +
         

     

       126
       126
       +
         val of_json : value -> t

     

       127
       127
       +
         (** [of_json json] parses a thinking block from JSON.

     

       128
       128
       +
             @raise Invalid_argument if the JSON is not a valid thinking block. *)

     

       129
       129
       +
         

     

       130
       130
       +
         val pp : Format.formatter -> t -> unit

     

       131
       131
       +
         (** [pp fmt t] pretty-prints the thinking block. *)

     

       132
       132
       +
       end

     

       133
       133
       +
       

     

       134
       134
       +
       (** {1 Content Block Union Type} *)

     

       135
       135
       +
       

     

       136
       136
       +
       type t =

     

       137
       137
       +
         | Text of Text.t

     

       138
       138
       +
         | Tool_use of Tool_use.t

     

       139
       139
       +
         | Tool_result of Tool_result.t

     

       140
       140
       +
         | Thinking of Thinking.t

     

       141
       141
       +
       (** The type of content blocks, which can be text, tool use, tool result, or thinking. *)

     

       142
       142
       +
       

     

       143
       143
       +
       val text : string -> t

     

       144
       144
       +
       (** [text s] creates a text content block. *)

     

       145
       145
       +
       

     

       146
       146
       +
       val tool_use : id:string -> name:string -> input:value -> t

     

       147
       147
       +
       (** [tool_use ~id ~name ~input] creates a tool use content block. *)

     

       148
       148
       +
       

     

       149
       149
       +
       val tool_result : tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t

     

       150
       150
       +
       (** [tool_result ~tool_use_id ?content ?is_error ()] creates a tool result content block. *)

     

       151
       151
       +
       

     

       152
       152
       +
       val thinking : thinking:string -> signature:string -> t

     

       153
       153
       +
       (** [thinking ~thinking ~signature] creates a thinking content block. *)

     

       154
       154
       +
       

     

       155
       155
       +
       val to_json : t -> value

     

       156
       156
       +
       (** [to_json t] converts any content block to its JSON representation. *)

     

       157
       157
       +
       

     

       158
       158
       +
       val of_json : value -> t

     

       159
       159
       +
       (** [of_json json] parses a content block from JSON.

     

       160
       160
       +
           @raise Invalid_argument if the JSON is not a valid content block. *)

     

       161
       161
       +
       

     

       162
       162
       +
       val pp : Format.formatter -> t -> unit

     

       163
       163
       +
       (** [pp fmt t] pretty-prints any content block. *)

     

       164
       164
       +
       

     

       165
       165
       +
       (** {1 Logging} *)

     

       166
       166
       +
       

     

       167
       167
       +
       val log_received : t -> unit

     

       168
       168
       +
       (** [log_received t] logs that a content block was received. *)

     

       169
       169
       +
       

     

       170
       170
       +
       val log_sending : t -> unit

     

       171
       171
       +
       (** [log_sending t] logs that a content block is being sent. *)

+46

claudeio/lib/control.ml

···

       1
       1
       +
       open Ezjsonm

     

       2
       2
       +
       

     

       3
       3
       +
       let src = Logs.Src.create "claude.control" ~doc:"Claude control messages"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       5
       5
       +
       

     

       6
       6
       +
       (* Helper for pretty-printing JSON *)

     

       7
       7
       +
       let pp_json fmt json =

     

       8
       8
       +
         Fmt.string fmt (value_to_string json)

     

       9
       9
       +
       

     

       10
       10
       +
       type t = {

     

       11
       11
       +
         request_id : string;

     

       12
       12
       +
         subtype : string;

     

       13
       13
       +
         data : value;

     

       14
       14
       +
       }

     

       15
       15
       +
       

     

       16
       16
       +
       let create ~request_id ~subtype ~data = { request_id; subtype; data }

     

       17
       17
       +
       

     

       18
       18
       +
       let request_id t = t.request_id

     

       19
       19
       +
       let subtype t = t.subtype

     

       20
       20
       +
       let data t = t.data

     

       21
       21
       +
       

     

       22
       22
       +
       let to_json t =

     

       23
       23
       +
         `O [

     

       24
       24
       +
           ("type", `String "control");

     

       25
       25
       +
           ("request_id", `String t.request_id);

     

       26
       26
       +
           ("subtype", `String t.subtype);

     

       27
       27
       +
           ("data", t.data);

     

       28
       28
       +
         ]

     

       29
       29
       +
       

     

       30
       30
       +
       let of_json = function

     

       31
       31
       +
         | `O fields ->

     

       32
       32
       +
             let request_id = get_string (List.assoc "request_id" fields) in

     

       33
       33
       +
             let subtype = get_string (List.assoc "subtype" fields) in

     

       34
       34
       +
             let data = List.assoc "data" fields in

     

       35
       35
       +
             { request_id; subtype; data }

     

       36
       36
       +
         | _ -> raise (Invalid_argument "Control.of_json: expected object")

     

       37
       37
       +
       

     

       38
       38
       +
       let pp fmt t =

     

       39
       39
       +
         Fmt.pf fmt "@[<2>Control@ { request_id = %S;@ subtype = %S;@ data = %a }@]"

     

       40
       40
       +
           t.request_id t.subtype pp_json t.data

     

       41
       41
       +
       

     

       42
       42
       +
       let log_received t =

     

       43
       43
       +
         Log.debug (fun m -> m "Received control message: %a" pp t)

     

       44
       44
       +
       

     

       45
       45
       +
       let log_sending t =

     

       46
       46
       +
         Log.debug (fun m -> m "Sending control message: %a" pp t)

+46

claudeio/lib/control.mli

···

       1
       1
       +
       (** Control messages for Claude session management.

     

       2
       2
       +
           

     

       3
       3
       +
           Control messages are used to manage the interaction flow with Claude,

     

       4
       4
       +
           including session control, cancellation requests, and other operational

     

       5
       5
       +
           commands. *)

     

       6
       6
       +
       

     

       7
       7
       +
       open Ezjsonm

     

       8
       8
       +
       

     

       9
       9
       +
       (** The log source for control message operations *)

     

       10
       10
       +
       val src : Logs.Src.t

     

       11
       11
       +
       

     

       12
       12
       +
       type t

     

       13
       13
       +
       (** The type of control messages. *)

     

       14
       14
       +
       

     

       15
       15
       +
       val create : request_id:string -> subtype:string -> data:value -> t

     

       16
       16
       +
       (** [create ~request_id ~subtype ~data] creates a new control message.

     

       17
       17
       +
           @param request_id Unique identifier for this control request

     

       18
       18
       +
           @param subtype The specific type of control message

     

       19
       19
       +
           @param data Additional JSON data for the control message *)

     

       20
       20
       +
       

     

       21
       21
       +
       val request_id : t -> string

     

       22
       22
       +
       (** [request_id t] returns the unique request identifier. *)

     

       23
       23
       +
       

     

       24
       24
       +
       val subtype : t -> string

     

       25
       25
       +
       (** [subtype t] returns the control message subtype. *)

     

       26
       26
       +
       

     

       27
       27
       +
       val data : t -> value

     

       28
       28
       +
       (** [data t] returns the additional data associated with the control message. *)

     

       29
       29
       +
       

     

       30
       30
       +
       val to_json : t -> value

     

       31
       31
       +
       (** [to_json t] converts the control message to its JSON representation. *)

     

       32
       32
       +
       

     

       33
       33
       +
       val of_json : value -> t

     

       34
       34
       +
       (** [of_json json] parses a control message from JSON.

     

       35
       35
       +
           @raise Invalid_argument if the JSON is not a valid control message. *)

     

       36
       36
       +
       

     

       37
       37
       +
       val pp : Format.formatter -> t -> unit

     

       38
       38
       +
       (** [pp fmt t] pretty-prints the control message. *)

     

       39
       39
       +
       

     

       40
       40
       +
       (** {1 Logging} *)

     

       41
       41
       +
       

     

       42
       42
       +
       val log_received : t -> unit

     

       43
       43
       +
       (** [log_received t] logs that a control message was received. *)

     

       44
       44
       +
       

     

       45
       45
       +
       val log_sending : t -> unit

     

       46
       46
       +
       (** [log_sending t] logs that a control message is being sent. *)

+1 -1

claudeio/lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (public_name claude)

     

       3
       3
        
        (name claude)

     

       4
       4
       -
        (libraries eio eio.unix ezjsonm))
     

       4
       4
       +
        (libraries eio eio.unix ezjsonm fmt logs))

+252 -101

claudeio/lib/message.ml

···

       1
       1
       -
       open Types

     

       1
       1
       +
       open Ezjsonm

     

       2
       2
        
       

     

       3
       3
       -
       exception Message_parse_error of string * Ezjsonm.value

     

       3
       3
       +
       let src = Logs.Src.create "claude.message" ~doc:"Claude messages"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       4
       5
        
       

     

       5
       5
       -
       let parse_content_block json =

     

       6
       6
       -
         let open Ezjsonm in

     

       7
       7
       -
         match find json ["type"] |> get_string with

     

       8
       8
       -
         | "text" ->

     

       9
       9
       -
             Text { text = find json ["text"] |> get_string }

     

       10
       10
       -
         | "tool_use" ->

     

       11
       11
       -
             ToolUse {

     

       12
       12
       -
               id = find json ["id"] |> get_string;

     

       13
       13
       -
               name = find json ["name"] |> get_string;

     

       14
       14
       -
               input = find json ["input"];

     

       15
       15
       -
             }

     

       16
       16
       -
         | "tool_result" ->

     

       17
       17
       -
             ToolResult {

     

       18
       18
       -
               tool_use_id = find json ["tool_use_id"] |> get_string;

     

       19
       19
       -
               content = (try Some (find json ["content"] |> get_string) with Not_found -> None);

     

       20
       20
       -
               is_error = (try Some (find json ["is_error"] |> get_bool) with Not_found -> None);

     

       21
       21
       -
             }

     

       22
       22
       -
         | "thinking" ->

     

       23
       23
       -
             Thinking {

     

       24
       24
       -
               thinking = find json ["thinking"] |> get_string;

     

       25
       25
       -
               signature = find json ["signature"] |> get_string;

     

       26
       26
       -
             }

     

       27
       27
       -
         | t -> raise (Message_parse_error (Printf.sprintf "Unknown content block type: %s" t, json))

     

       6
       6
       +
       (* Helper for pretty-printing JSON *)

     

       7
       7
       +
       let pp_json fmt json =

     

       8
       8
       +
         Fmt.string fmt (value_to_string json)

     

       28
       9
        
       

     

       29
       29
       -
       let parse json =

     

       30
       30
       -
         let open Ezjsonm in

     

       31
       31
       -
         try

     

       32
       32
       -
           match find json ["type"] |> get_string with

     

       33
       33
       -
           | "user" ->

     

       34
       34
       -
               let message = find json ["message"] in

     

       35
       35
       -
               let content_json = find message ["content"] in

     

       36
       36
       -
               let content = 

     

       37
       37
       -
                 match content_json with

     

       38
       38
       -
                 | `String s -> `String s

     

       39
       39
       -
                 | `A blocks ->

     

       40
       40
       -
                     let parsed_blocks = List.map parse_content_block blocks in

     

       41
       41
       -
                     `Blocks parsed_blocks

     

       42
       42
       -
                 | _ -> `String (value_to_string content_json)

     

       10
       10
       +
       module User = struct

     

       11
       11
       +
         type content = 

     

       12
       12
       +
           | String of string

     

       13
       13
       +
           | Blocks of Content_block.t list

     

       14
       14
       +
         

     

       15
       15
       +
         type t = { content : content }

     

       16
       16
       +
         

     

       17
       17
       +
         let create_string s = { content = String s }

     

       18
       18
       +
         let create_blocks blocks = { content = Blocks blocks }

     

       19
       19
       +
         let content t = t.content

     

       20
       20
       +
         

     

       21
       21
       +
         let to_json t =

     

       22
       22
       +
           let content_json = match t.content with

     

       23
       23
       +
             | String s -> `String s

     

       24
       24
       +
             | Blocks blocks -> 

     

       25
       25
       +
                 `A (List.map Content_block.to_json blocks)

     

       26
       26
       +
           in

     

       27
       27
       +
           `O [

     

       28
       28
       +
             ("type", `String "user");

     

       29
       29
       +
             ("message", `O [

     

       30
       30
       +
               ("role", `String "user");

     

       31
       31
       +
               ("content", content_json);

     

       32
       32
       +
             ]);

     

       33
       33
       +
           ]

     

       34
       34
       +
         

     

       35
       35
       +
         let of_json = function

     

       36
       36
       +
           | `O fields ->

     

       37
       37
       +
               let message = List.assoc "message" fields in

     

       38
       38
       +
               let content = match message with

     

       39
       39
       +
                 | `O msg_fields ->

     

       40
       40
       +
                     (match List.assoc "content" msg_fields with

     

       41
       41
       +
                      | `String s -> String s

     

       42
       42
       +
                      | `A blocks -> Blocks (List.map Content_block.of_json blocks)

     

       43
       43
       +
                      | _ -> raise (Invalid_argument "User.of_json: invalid content"))

     

       44
       44
       +
                 | _ -> raise (Invalid_argument "User.of_json: invalid message")

     

       43
       45
        
               in

     

       44
       44
       -
               User { content }

     

       45
       45
       -
           

     

       46
       46
       -
           | "assistant" ->

     

       47
       47
       -
               let message = find json ["message"] in

     

       48
       48
       -
               let content_blocks = find message ["content"] |> get_list parse_content_block in

     

       49
       49
       -
               let model = find message ["model"] |> get_string in

     

       50
       50
       -
               Assistant { content = content_blocks; model }

     

       51
       51
       -
           

     

       52
       52
       -
           | "system" ->

     

       53
       53
       -
               let subtype = find json ["subtype"] |> get_string in

     

       54
       54
       -
               System { subtype; data = json }

     

       55
       55
       -
           

     

       56
       56
       -
           | "result" ->

     

       57
       57
       -
               Result {

     

       58
       58
       -
                 subtype = find json ["subtype"] |> get_string;

     

       59
       59
       -
                 duration_ms = find json ["duration_ms"] |> get_int;

     

       60
       60
       -
                 duration_api_ms = find json ["duration_api_ms"] |> get_int;

     

       61
       61
       -
                 is_error = find json ["is_error"] |> get_bool;

     

       62
       62
       -
                 num_turns = find json ["num_turns"] |> get_int;

     

       63
       63
       -
                 session_id = find json ["session_id"] |> get_string;

     

       64
       64
       -
                 total_cost_usd = (try Some (find json ["total_cost_usd"] |> get_float) with Not_found -> None);

     

       65
       65
       -
                 usage = (try Some (find json ["usage"]) with Not_found -> None);

     

       66
       66
       -
                 result = (try Some (find json ["result"] |> get_string) with Not_found -> None);

     

       67
       67
       -
               }

     

       68
       68
       -
           

     

       69
       69
       -
           | msg_type -> 

     

       70
       70
       -
               raise (Message_parse_error (Printf.sprintf "Unknown message type: %s" msg_type, json))

     

       71
       71
       -
         with

     

       72
       72
       -
         | Message_parse_error _ as e -> raise e

     

       73
       73
       -
         | e -> 

     

       74
       74
       -
             raise (Message_parse_error (Printf.sprintf "Failed to parse message: %s" (Printexc.to_string e), json))

     

       46
       46
       +
               { content }

     

       47
       47
       +
           | _ -> raise (Invalid_argument "User.of_json: expected object")

     

       48
       48
       +
         

     

       49
       49
       +
         let pp fmt t =

     

       50
       50
       +
           match t.content with

     

       51
       51
       +
           | String s -> Fmt.pf fmt "@[<2>User@ { content = %S }@]" s

     

       52
       52
       +
           | Blocks blocks ->

     

       53
       53
       +
               Fmt.pf fmt "@[<2>User@ { content = @[<v>%a@] }@]"

     

       54
       54
       +
                 Fmt.(list ~sep:(any "@,") Content_block.pp) blocks

     

       55
       55
       +
       end

     

       75
       56
        
       

     

       76
       76
       -
       let serialize_user_message content =

     

       77
       77
       -
         let open Ezjsonm in

     

       78
       78
       -
         let content_json = 

     

       79
       79
       -
           match content with

     

       80
       80
       -
           | `String s -> string s

     

       81
       81
       -
           | `Blocks blocks ->

     

       82
       82
       -
               let serialize_block = function

     

       83
       83
       -
                 | Text { text } ->

     

       84
       84
       -
                     dict [ "type", string "text"; "text", string text ]

     

       85
       85
       -
                 | ToolUse { id; name; input } ->

     

       86
       86
       -
                     dict [ "type", string "tool_use"; "id", string id; "name", string name; "input", input ]

     

       87
       87
       -
                 | ToolResult { tool_use_id; content; is_error } ->

     

       88
       88
       -
                     let fields = [ "type", string "tool_result"; "tool_use_id", string tool_use_id ] in

     

       89
       89
       -
                     let fields = match content with

     

       90
       90
       -
                       | Some c -> ("content", string c) :: fields

     

       91
       91
       -
                       | None -> fields

     

       92
       92
       -
                     in

     

       93
       93
       -
                     let fields = match is_error with

     

       94
       94
       -
                       | Some e -> ("is_error", bool e) :: fields

     

       95
       95
       -
                       | None -> fields

     

       57
       57
       +
       module Assistant = struct

     

       58
       58
       +
         type t = {

     

       59
       59
       +
           content : Content_block.t list;

     

       60
       60
       +
           model : string;

     

       61
       61
       +
         }

     

       62
       62
       +
         

     

       63
       63
       +
         let create ~content ~model = { content; model }

     

       64
       64
       +
         let content t = t.content

     

       65
       65
       +
         let model t = t.model

     

       66
       66
       +
         

     

       67
       67
       +
         let to_json t =

     

       68
       68
       +
           `O [

     

       69
       69
       +
             ("type", `String "assistant");

     

       70
       70
       +
             ("message", `O [

     

       71
       71
       +
               ("content", `A (List.map Content_block.to_json t.content));

     

       72
       72
       +
               ("model", `String t.model);

     

       73
       73
       +
             ]);

     

       74
       74
       +
           ]

     

       75
       75
       +
         

     

       76
       76
       +
         let of_json = function

     

       77
       77
       +
           | `O fields ->

     

       78
       78
       +
               let message = List.assoc "message" fields in

     

       79
       79
       +
               let content, model = match message with

     

       80
       80
       +
                 | `O msg_fields ->

     

       81
       81
       +
                     let content = 

     

       82
       82
       +
                       match List.assoc "content" msg_fields with

     

       83
       83
       +
                       | `A blocks -> List.map Content_block.of_json blocks

     

       84
       84
       +
                       | _ -> raise (Invalid_argument "Assistant.of_json: invalid content")

     

       96
       85
        
                     in

     

       97
       97
       -
                     dict fields

     

       98
       98
       -
                 | Thinking { thinking; signature } ->

     

       99
       99
       -
                     dict [ "type", string "thinking"; "thinking", string thinking; "signature", string signature ]

     

       86
       86
       +
                     let model = get_string (List.assoc "model" msg_fields) in

     

       87
       87
       +
                     content, model

     

       88
       88
       +
                 | _ -> raise (Invalid_argument "Assistant.of_json: invalid message")

     

       100
       89
        
               in

     

       101
       101
       -
               list serialize_block blocks

     

       102
       102
       -
         in

     

       103
       103
       -
         dict [

     

       104
       104
       -
           "type", string "user";

     

       105
       105
       -
           "message", dict [

     

       106
       106
       -
             "role", string "user";

     

       107
       107
       -
             "content", content_json

     

       90
       90
       +
               { content; model }

     

       91
       91
       +
           | _ -> raise (Invalid_argument "Assistant.of_json: expected object")

     

       92
       92
       +
         

     

       93
       93
       +
         let pp fmt t =

     

       94
       94
       +
           Fmt.pf fmt "@[<2>Assistant@ { model = %S;@ content = @[<v>%a@] }@]"

     

       95
       95
       +
             t.model

     

       96
       96
       +
             Fmt.(list ~sep:(any "@,") Content_block.pp) t.content

     

       97
       97
       +
       end

     

       98
       98
       +
       

     

       99
       99
       +
       module System = struct

     

       100
       100
       +
         type t = {

     

       101
       101
       +
           subtype : string;

     

       102
       102
       +
           data : value;

     

       103
       103
       +
         }

     

       104
       104
       +
         

     

       105
       105
       +
         let create ~subtype ~data = { subtype; data }

     

       106
       106
       +
         let subtype t = t.subtype

     

       107
       107
       +
         let data t = t.data

     

       108
       108
       +
         

     

       109
       109
       +
         let to_json t =

     

       110
       110
       +
           `O [

     

       111
       111
       +
             ("type", `String "system");

     

       112
       112
       +
             ("subtype", `String t.subtype);

     

       113
       113
       +
             ("data", t.data);

     

       108
       114
        
           ]

     

       109
       109
       -
         ]
     

       115
       115
       +
         

     

       116
       116
       +
         let of_json = function

     

       117
       117
       +
           | `O fields ->

     

       118
       118
       +
               let subtype = get_string (List.assoc "subtype" fields) in

     

       119
       119
       +
               let data = try List.assoc "data" fields with Not_found -> `O fields in

     

       120
       120
       +
               { subtype; data }

     

       121
       121
       +
           | _ -> raise (Invalid_argument "System.of_json: expected object")

     

       122
       122
       +
         

     

       123
       123
       +
         let pp fmt t =

     

       124
       124
       +
           Fmt.pf fmt "@[<2>System@ { subtype = %S;@ data = %a }@]"

     

       125
       125
       +
             t.subtype

     

       126
       126
       +
             pp_json t.data

     

       127
       127
       +
       end

     

       128
       128
       +
       

     

       129
       129
       +
       module Result = struct

     

       130
       130
       +
         type t = {

     

       131
       131
       +
           subtype : string;

     

       132
       132
       +
           duration_ms : int;

     

       133
       133
       +
           duration_api_ms : int;

     

       134
       134
       +
           is_error : bool;

     

       135
       135
       +
           num_turns : int;

     

       136
       136
       +
           session_id : string;

     

       137
       137
       +
           total_cost_usd : float option;

     

       138
       138
       +
           usage : value option;

     

       139
       139
       +
           result : string option;

     

       140
       140
       +
         }

     

       141
       141
       +
         

     

       142
       142
       +
         let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       143
       143
       +
             ~session_id ?total_cost_usd ?usage ?result () =

     

       144
       144
       +
           { subtype; duration_ms; duration_api_ms; is_error; num_turns;

     

       145
       145
       +
             session_id; total_cost_usd; usage; result }

     

       146
       146
       +
         

     

       147
       147
       +
         let subtype t = t.subtype

     

       148
       148
       +
         let duration_ms t = t.duration_ms

     

       149
       149
       +
         let duration_api_ms t = t.duration_api_ms

     

       150
       150
       +
         let is_error t = t.is_error

     

       151
       151
       +
         let num_turns t = t.num_turns

     

       152
       152
       +
         let session_id t = t.session_id

     

       153
       153
       +
         let total_cost_usd t = t.total_cost_usd

     

       154
       154
       +
         let usage t = t.usage

     

       155
       155
       +
         let result t = t.result

     

       156
       156
       +
         

     

       157
       157
       +
         let to_json t =

     

       158
       158
       +
           let fields = [

     

       159
       159
       +
             ("type", `String "result");

     

       160
       160
       +
             ("subtype", `String t.subtype);

     

       161
       161
       +
             ("duration_ms", `Float (float_of_int t.duration_ms));

     

       162
       162
       +
             ("duration_api_ms", `Float (float_of_int t.duration_api_ms));

     

       163
       163
       +
             ("is_error", `Bool t.is_error);

     

       164
       164
       +
             ("num_turns", `Float (float_of_int t.num_turns));

     

       165
       165
       +
             ("session_id", `String t.session_id);

     

       166
       166
       +
           ] in

     

       167
       167
       +
           let fields = match t.total_cost_usd with

     

       168
       168
       +
             | Some cost -> ("total_cost_usd", `Float cost) :: fields

     

       169
       169
       +
             | None -> fields

     

       170
       170
       +
           in

     

       171
       171
       +
           let fields = match t.usage with

     

       172
       172
       +
             | Some usage -> ("usage", usage) :: fields

     

       173
       173
       +
             | None -> fields

     

       174
       174
       +
           in

     

       175
       175
       +
           let fields = match t.result with

     

       176
       176
       +
             | Some result -> ("result", `String result) :: fields

     

       177
       177
       +
             | None -> fields

     

       178
       178
       +
           in

     

       179
       179
       +
           `O fields

     

       180
       180
       +
         

     

       181
       181
       +
         let of_json = function

     

       182
       182
       +
           | `O fields ->

     

       183
       183
       +
               let subtype = get_string (List.assoc "subtype" fields) in

     

       184
       184
       +
               let duration_ms = int_of_float (get_float (List.assoc "duration_ms" fields)) in

     

       185
       185
       +
               let duration_api_ms = int_of_float (get_float (List.assoc "duration_api_ms" fields)) in

     

       186
       186
       +
               let is_error = get_bool (List.assoc "is_error" fields) in

     

       187
       187
       +
               let num_turns = int_of_float (get_float (List.assoc "num_turns" fields)) in

     

       188
       188
       +
               let session_id = get_string (List.assoc "session_id" fields) in

     

       189
       189
       +
               let total_cost_usd = 

     

       190
       190
       +
                 try Some (get_float (List.assoc "total_cost_usd" fields))

     

       191
       191
       +
                 with Not_found -> None

     

       192
       192
       +
               in

     

       193
       193
       +
               let usage = List.assoc_opt "usage" fields in

     

       194
       194
       +
               let result = 

     

       195
       195
       +
                 try Some (get_string (List.assoc "result" fields))

     

       196
       196
       +
                 with Not_found -> None

     

       197
       197
       +
               in

     

       198
       198
       +
               { subtype; duration_ms; duration_api_ms; is_error; num_turns;

     

       199
       199
       +
                 session_id; total_cost_usd; usage; result }

     

       200
       200
       +
           | _ -> raise (Invalid_argument "Result.of_json: expected object")

     

       201
       201
       +
         

     

       202
       202
       +
         let pp fmt t =

     

       203
       203
       +
           Fmt.pf fmt "@[<2>Result@ { subtype = %S;@ duration_ms = %d;@ \

     

       204
       204
       +
                       duration_api_ms = %d;@ is_error = %b;@ num_turns = %d;@ \

     

       205
       205
       +
                       session_id = %S;@ total_cost_usd = %a;@ usage = %a;@ result = %a }@]"

     

       206
       206
       +
             t.subtype t.duration_ms t.duration_api_ms t.is_error t.num_turns

     

       207
       207
       +
             t.session_id

     

       208
       208
       +
             Fmt.(option float) t.total_cost_usd

     

       209
       209
       +
             Fmt.(option pp_json) t.usage

     

       210
       210
       +
             Fmt.(option string) t.result

     

       211
       211
       +
       end

     

       212
       212
       +
       

     

       213
       213
       +
       type t =

     

       214
       214
       +
         | User of User.t

     

       215
       215
       +
         | Assistant of Assistant.t

     

       216
       216
       +
         | System of System.t

     

       217
       217
       +
         | Result of Result.t

     

       218
       218
       +
       

     

       219
       219
       +
       let user_string s = User (User.create_string s)

     

       220
       220
       +
       let user_blocks blocks = User (User.create_blocks blocks)

     

       221
       221
       +
       let assistant ~content ~model = Assistant (Assistant.create ~content ~model)

     

       222
       222
       +
       let system ~subtype ~data = System (System.create ~subtype ~data)

     

       223
       223
       +
       let result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       224
       224
       +
           ~session_id ?total_cost_usd ?usage ?result () =

     

       225
       225
       +
         Result (Result.create ~subtype ~duration_ms ~duration_api_ms ~is_error 

     

       226
       226
       +
           ~num_turns ~session_id ?total_cost_usd ?usage ?result ())

     

       227
       227
       +
       

     

       228
       228
       +
       let to_json = function

     

       229
       229
       +
         | User t -> User.to_json t

     

       230
       230
       +
         | Assistant t -> Assistant.to_json t

     

       231
       231
       +
         | System t -> System.to_json t

     

       232
       232
       +
         | Result t -> Result.to_json t

     

       233
       233
       +
       

     

       234
       234
       +
       let of_json json =

     

       235
       235
       +
         match json with

     

       236
       236
       +
         | `O fields -> (

     

       237
       237
       +
             match List.assoc_opt "type" fields with

     

       238
       238
       +
             | Some (`String "user") -> User (User.of_json json)

     

       239
       239
       +
             | Some (`String "assistant") -> Assistant (Assistant.of_json json)

     

       240
       240
       +
             | Some (`String "system") -> System (System.of_json json)

     

       241
       241
       +
             | Some (`String "result") -> Result (Result.of_json json)

     

       242
       242
       +
             | _ -> raise (Invalid_argument "Message.of_json: unknown type")

     

       243
       243
       +
           )

     

       244
       244
       +
         | _ -> raise (Invalid_argument "Message.of_json: expected object")

     

       245
       245
       +
       

     

       246
       246
       +
       let pp fmt = function

     

       247
       247
       +
         | User t -> User.pp fmt t

     

       248
       248
       +
         | Assistant t -> Assistant.pp fmt t

     

       249
       249
       +
         | System t -> System.pp fmt t

     

       250
       250
       +
         | Result t -> Result.pp fmt t

     

       251
       251
       +
       

     

       252
       252
       +
       let log_received t =

     

       253
       253
       +
         Log.info (fun m -> m "Received message: %a" pp t)

     

       254
       254
       +
       

     

       255
       255
       +
       let log_sending t =

     

       256
       256
       +
         Log.info (fun m -> m "Sending message: %a" pp t)

     

       257
       257
       +
       

     

       258
       258
       +
       let log_error msg t =

     

       259
       259
       +
         Log.err (fun m -> m "%s: %a" msg pp t)

     

       260
       260
       +

+227 -5

claudeio/lib/message.mli

···

       1
       1
       -
       exception Message_parse_error of string * Ezjsonm.value

     

       1
       1
       +
       (** Messages exchanged with Claude.

     

       2
       2
       +
           

     

       3
       3
       +
           This module defines the various types of messages that can be sent to and 

     

       4
       4
       +
           received from Claude, including user input, assistant responses, system 

     

       5
       5
       +
           messages, and result metadata. *)

     

       6
       6
       +
       

     

       7
       7
       +
       open Ezjsonm

     

       8
       8
       +
       

     

       9
       9
       +
       (** The log source for message operations *)

     

       10
       10
       +
       val src : Logs.Src.t

     

       2
       11
        
       

     

       3
       3
       -
       val parse : Ezjsonm.value -> Types.message

     

       12
       12
       +
       (** {1 User Messages} *)

     

       4
       13
        
       

     

       5
       5
       -
       val serialize_user_message : 

     

       6
       6
       -
         [ `String of string | `Blocks of Types.content_block list ] -> 

     

       7
       7
       -
         Ezjsonm.value
     

       14
       14
       +
       module User : sig

     

       15
       15
       +
         (** Messages sent by the user. *)

     

       16
       16
       +
         

     

       17
       17
       +
         type content = 

     

       18
       18
       +
           | String of string  (** Simple text message *)

     

       19
       19
       +
           | Blocks of Content_block.t list  (** Complex message with multiple content blocks *)

     

       20
       20
       +
         (** The content of a user message. *)

     

       21
       21
       +
         

     

       22
       22
       +
         type t

     

       23
       23
       +
         (** The type of user messages. *)

     

       24
       24
       +
         

     

       25
       25
       +
         val create_string : string -> t

     

       26
       26
       +
         (** [create_string s] creates a user message with simple text content. *)

     

       27
       27
       +
         

     

       28
       28
       +
         val create_blocks : Content_block.t list -> t

     

       29
       29
       +
         (** [create_blocks blocks] creates a user message with content blocks. *)

     

       30
       30
       +
         

     

       31
       31
       +
         val content : t -> content

     

       32
       32
       +
         (** [content t] returns the content of the user message. *)

     

       33
       33
       +
         

     

       34
       34
       +
         val to_json : t -> value

     

       35
       35
       +
         (** [to_json t] converts the user message to its JSON representation. *)

     

       36
       36
       +
         

     

       37
       37
       +
         val of_json : value -> t

     

       38
       38
       +
         (** [of_json json] parses a user message from JSON.

     

       39
       39
       +
             @raise Invalid_argument if the JSON is not a valid user message. *)

     

       40
       40
       +
         

     

       41
       41
       +
         val pp : Format.formatter -> t -> unit

     

       42
       42
       +
         (** [pp fmt t] pretty-prints the user message. *)

     

       43
       43
       +
       end

     

       44
       44
       +
       

     

       45
       45
       +
       (** {1 Assistant Messages} *)

     

       46
       46
       +
       

     

       47
       47
       +
       module Assistant : sig

     

       48
       48
       +
         (** Messages from Claude assistant. *)

     

       49
       49
       +
         

     

       50
       50
       +
         type t

     

       51
       51
       +
         (** The type of assistant messages. *)

     

       52
       52
       +
         

     

       53
       53
       +
         val create : content:Content_block.t list -> model:string -> t

     

       54
       54
       +
         (** [create ~content ~model] creates an assistant message.

     

       55
       55
       +
             @param content List of content blocks in the response

     

       56
       56
       +
             @param model The model identifier used for the response *)

     

       57
       57
       +
         

     

       58
       58
       +
         val content : t -> Content_block.t list

     

       59
       59
       +
         (** [content t] returns the content blocks of the assistant message. *)

     

       60
       60
       +
         

     

       61
       61
       +
         val model : t -> string

     

       62
       62
       +
         (** [model t] returns the model identifier. *)

     

       63
       63
       +
         

     

       64
       64
       +
         val to_json : t -> value

     

       65
       65
       +
         (** [to_json t] converts the assistant message to its JSON representation. *)

     

       66
       66
       +
         

     

       67
       67
       +
         val of_json : value -> t

     

       68
       68
       +
         (** [of_json json] parses an assistant message from JSON.

     

       69
       69
       +
             @raise Invalid_argument if the JSON is not a valid assistant message. *)

     

       70
       70
       +
         

     

       71
       71
       +
         val pp : Format.formatter -> t -> unit

     

       72
       72
       +
         (** [pp fmt t] pretty-prints the assistant message. *)

     

       73
       73
       +
       end

     

       74
       74
       +
       

     

       75
       75
       +
       (** {1 System Messages} *)

     

       76
       76
       +
       

     

       77
       77
       +
       module System : sig

     

       78
       78
       +
         (** System control and status messages. *)

     

       79
       79
       +
         

     

       80
       80
       +
         type t

     

       81
       81
       +
         (** The type of system messages. *)

     

       82
       82
       +
         

     

       83
       83
       +
         val create : subtype:string -> data:value -> t

     

       84
       84
       +
         (** [create ~subtype ~data] creates a system message.

     

       85
       85
       +
             @param subtype The subtype of the system message

     

       86
       86
       +
             @param data Additional JSON data for the message *)

     

       87
       87
       +
         

     

       88
       88
       +
         val subtype : t -> string

     

       89
       89
       +
         (** [subtype t] returns the subtype of the system message. *)

     

       90
       90
       +
         

     

       91
       91
       +
         val data : t -> value

     

       92
       92
       +
         (** [data t] returns the additional data of the system message. *)

     

       93
       93
       +
         

     

       94
       94
       +
         val to_json : t -> value

     

       95
       95
       +
         (** [to_json t] converts the system message to its JSON representation. *)

     

       96
       96
       +
         

     

       97
       97
       +
         val of_json : value -> t

     

       98
       98
       +
         (** [of_json json] parses a system message from JSON.

     

       99
       99
       +
             @raise Invalid_argument if the JSON is not a valid system message. *)

     

       100
       100
       +
         

     

       101
       101
       +
         val pp : Format.formatter -> t -> unit

     

       102
       102
       +
         (** [pp fmt t] pretty-prints the system message. *)

     

       103
       103
       +
       end

     

       104
       104
       +
       

     

       105
       105
       +
       (** {1 Result Messages} *)

     

       106
       106
       +
       

     

       107
       107
       +
       module Result : sig

     

       108
       108
       +
         (** Final result messages with metadata about the conversation. *)

     

       109
       109
       +
         

     

       110
       110
       +
         type t

     

       111
       111
       +
         (** The type of result messages. *)

     

       112
       112
       +
         

     

       113
       113
       +
         val create : 

     

       114
       114
       +
           subtype:string -> 

     

       115
       115
       +
           duration_ms:int -> 

     

       116
       116
       +
           duration_api_ms:int -> 

     

       117
       117
       +
           is_error:bool -> 

     

       118
       118
       +
           num_turns:int -> 

     

       119
       119
       +
           session_id:string -> 

     

       120
       120
       +
           ?total_cost_usd:float -> 

     

       121
       121
       +
           ?usage:value -> 

     

       122
       122
       +
           ?result:string -> 

     

       123
       123
       +
           unit -> t

     

       124
       124
       +
         (** [create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       125
       125
       +
             ~session_id ?total_cost_usd ?usage ?result ()] creates a result message.

     

       126
       126
       +
             @param subtype The subtype of the result

     

       127
       127
       +
             @param duration_ms Total duration in milliseconds

     

       128
       128
       +
             @param duration_api_ms API duration in milliseconds

     

       129
       129
       +
             @param is_error Whether the result represents an error

     

       130
       130
       +
             @param num_turns Number of conversation turns

     

       131
       131
       +
             @param session_id Unique session identifier

     

       132
       132
       +
             @param total_cost_usd Optional total cost in USD

     

       133
       133
       +
             @param usage Optional usage statistics as JSON

     

       134
       134
       +
             @param result Optional result string *)

     

       135
       135
       +
         

     

       136
       136
       +
         val subtype : t -> string

     

       137
       137
       +
         (** [subtype t] returns the subtype of the result. *)

     

       138
       138
       +
         

     

       139
       139
       +
         val duration_ms : t -> int

     

       140
       140
       +
         (** [duration_ms t] returns the total duration in milliseconds. *)

     

       141
       141
       +
         

     

       142
       142
       +
         val duration_api_ms : t -> int

     

       143
       143
       +
         (** [duration_api_ms t] returns the API duration in milliseconds. *)

     

       144
       144
       +
         

     

       145
       145
       +
         val is_error : t -> bool

     

       146
       146
       +
         (** [is_error t] returns whether this result represents an error. *)

     

       147
       147
       +
         

     

       148
       148
       +
         val num_turns : t -> int

     

       149
       149
       +
         (** [num_turns t] returns the number of conversation turns. *)

     

       150
       150
       +
         

     

       151
       151
       +
         val session_id : t -> string

     

       152
       152
       +
         (** [session_id t] returns the session identifier. *)

     

       153
       153
       +
         

     

       154
       154
       +
         val total_cost_usd : t -> float option

     

       155
       155
       +
         (** [total_cost_usd t] returns the optional total cost in USD. *)

     

       156
       156
       +
         

     

       157
       157
       +
         val usage : t -> value option

     

       158
       158
       +
         (** [usage t] returns the optional usage statistics. *)

     

       159
       159
       +
         

     

       160
       160
       +
         val result : t -> string option

     

       161
       161
       +
         (** [result t] returns the optional result string. *)

     

       162
       162
       +
         

     

       163
       163
       +
         val to_json : t -> value

     

       164
       164
       +
         (** [to_json t] converts the result message to its JSON representation. *)

     

       165
       165
       +
         

     

       166
       166
       +
         val of_json : value -> t

     

       167
       167
       +
         (** [of_json json] parses a result message from JSON.

     

       168
       168
       +
             @raise Invalid_argument if the JSON is not a valid result message. *)

     

       169
       169
       +
         

     

       170
       170
       +
         val pp : Format.formatter -> t -> unit

     

       171
       171
       +
         (** [pp fmt t] pretty-prints the result message. *)

     

       172
       172
       +
       end

     

       173
       173
       +
       

     

       174
       174
       +
       (** {1 Message Union Type} *)

     

       175
       175
       +
       

     

       176
       176
       +
       type t =

     

       177
       177
       +
         | User of User.t

     

       178
       178
       +
         | Assistant of Assistant.t

     

       179
       179
       +
         | System of System.t

     

       180
       180
       +
         | Result of Result.t

     

       181
       181
       +
       (** The type of messages, which can be user, assistant, system, or result. *)

     

       182
       182
       +
       

     

       183
       183
       +
       val user_string : string -> t

     

       184
       184
       +
       (** [user_string s] creates a user message with text content. *)

     

       185
       185
       +
       

     

       186
       186
       +
       val user_blocks : Content_block.t list -> t

     

       187
       187
       +
       (** [user_blocks blocks] creates a user message with content blocks. *)

     

       188
       188
       +
       

     

       189
       189
       +
       val assistant : content:Content_block.t list -> model:string -> t

     

       190
       190
       +
       (** [assistant ~content ~model] creates an assistant message. *)

     

       191
       191
       +
       

     

       192
       192
       +
       val system : subtype:string -> data:value -> t

     

       193
       193
       +
       (** [system ~subtype ~data] creates a system message. *)

     

       194
       194
       +
       

     

       195
       195
       +
       val result : 

     

       196
       196
       +
         subtype:string -> 

     

       197
       197
       +
         duration_ms:int -> 

     

       198
       198
       +
         duration_api_ms:int -> 

     

       199
       199
       +
         is_error:bool -> 

     

       200
       200
       +
         num_turns:int -> 

     

       201
       201
       +
         session_id:string -> 

     

       202
       202
       +
         ?total_cost_usd:float -> 

     

       203
       203
       +
         ?usage:value -> 

     

       204
       204
       +
         ?result:string -> 

     

       205
       205
       +
         unit -> t

     

       206
       206
       +
       (** [result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       207
       207
       +
           ~session_id ?total_cost_usd ?usage ?result ()] creates a result message. *)

     

       208
       208
       +
       

     

       209
       209
       +
       val to_json : t -> value

     

       210
       210
       +
       (** [to_json t] converts any message to its JSON representation. *)

     

       211
       211
       +
       

     

       212
       212
       +
       val of_json : value -> t

     

       213
       213
       +
       (** [of_json json] parses a message from JSON.

     

       214
       214
       +
           @raise Invalid_argument if the JSON is not a valid message. *)

     

       215
       215
       +
       

     

       216
       216
       +
       val pp : Format.formatter -> t -> unit

     

       217
       217
       +
       (** [pp fmt t] pretty-prints any message. *)

     

       218
       218
       +
       

     

       219
       219
       +
       (** {1 Logging} *)

     

       220
       220
       +
       

     

       221
       221
       +
       val log_received : t -> unit

     

       222
       222
       +
       (** [log_received t] logs that a message was received. *)

     

       223
       223
       +
       

     

       224
       224
       +
       val log_sending : t -> unit

     

       225
       225
       +
       (** [log_sending t] logs that a message is being sent. *)

     

       226
       226
       +
       

     

       227
       227
       +
       val log_error : string -> t -> unit

     

       228
       228
       +
       (** [log_error msg t] logs an error with the given message and context. *)

     

       229
       229
       +

+152 -2

claudeio/lib/options.ml

···

       1
       1
       +
       open Ezjsonm

     

       2
       2
       +
       

     

       3
       3
       +
       let src = Logs.Src.create "claude.options" ~doc:"Claude configuration options"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       5
       5
       +
       

     

       1
       6
        
       type t = {

     

       2
       7
        
         allowed_tools : string list;

     

       3
       8
        
         disallowed_tools : string list;

     

       4
       9
        
         max_thinking_tokens : int;

     

       5
       10
        
         system_prompt : string option;

     

       6
       11
        
         append_system_prompt : string option;

     

       7
       7
       -
         permission_mode : [ `Default | `AcceptEdits | `Plan | `BypassPermissions ] option;

     

       12
       12
       +
         permission_mode : Permissions.Mode.t option;

     

       8
       13
        
         permission_callback : Permissions.callback option;

     

       9
       14
        
         model : string option;

     

       10
       15
        
         cwd : Eio.Fs.dir_ty Eio.Path.t option;

     
···

       22
       27
        
         model = None;

     

       23
       28
        
         cwd = None;

     

       24
       29
        
         env = [];

     

       25
       25
       -
       }
     

       30
       30
       +
       }

     

       31
       31
       +
       

     

       32
       32
       +
       let create 

     

       33
       33
       +
           ?(allowed_tools = [])

     

       34
       34
       +
           ?(disallowed_tools = [])

     

       35
       35
       +
           ?(max_thinking_tokens = 8000)

     

       36
       36
       +
           ?system_prompt

     

       37
       37
       +
           ?append_system_prompt

     

       38
       38
       +
           ?permission_mode

     

       39
       39
       +
           ?permission_callback

     

       40
       40
       +
           ?model

     

       41
       41
       +
           ?cwd

     

       42
       42
       +
           ?(env = [])

     

       43
       43
       +
           () =

     

       44
       44
       +
         { allowed_tools; disallowed_tools; max_thinking_tokens;

     

       45
       45
       +
           system_prompt; append_system_prompt; permission_mode;

     

       46
       46
       +
           permission_callback; model; cwd; env }

     

       47
       47
       +
       

     

       48
       48
       +
       let allowed_tools t = t.allowed_tools

     

       49
       49
       +
       let disallowed_tools t = t.disallowed_tools

     

       50
       50
       +
       let max_thinking_tokens t = t.max_thinking_tokens

     

       51
       51
       +
       let system_prompt t = t.system_prompt

     

       52
       52
       +
       let append_system_prompt t = t.append_system_prompt

     

       53
       53
       +
       let permission_mode t = t.permission_mode

     

       54
       54
       +
       let permission_callback t = t.permission_callback

     

       55
       55
       +
       let model t = t.model

     

       56
       56
       +
       let cwd t = t.cwd

     

       57
       57
       +
       let env t = t.env

     

       58
       58
       +
       

     

       59
       59
       +
       let with_allowed_tools tools t = { t with allowed_tools = tools }

     

       60
       60
       +
       let with_disallowed_tools tools t = { t with disallowed_tools = tools }

     

       61
       61
       +
       let with_max_thinking_tokens tokens t = { t with max_thinking_tokens = tokens }

     

       62
       62
       +
       let with_system_prompt prompt t = { t with system_prompt = Some prompt }

     

       63
       63
       +
       let with_append_system_prompt prompt t = { t with append_system_prompt = Some prompt }

     

       64
       64
       +
       let with_permission_mode mode t = { t with permission_mode = Some mode }

     

       65
       65
       +
       let with_permission_callback callback t = { t with permission_callback = Some callback }

     

       66
       66
       +
       let with_model model t = { t with model = Some model }

     

       67
       67
       +
       let with_cwd cwd t = { t with cwd = Some cwd }

     

       68
       68
       +
       let with_env env t = { t with env }

     

       69
       69
       +
       

     

       70
       70
       +
       let to_json t =

     

       71
       71
       +
         let fields = [] in

     

       72
       72
       +
         let fields = 

     

       73
       73
       +
           if t.allowed_tools <> [] then 

     

       74
       74
       +
             ("allowed_tools", `A (List.map (fun s -> `String s) t.allowed_tools)) :: fields

     

       75
       75
       +
           else fields

     

       76
       76
       +
         in

     

       77
       77
       +
         let fields = 

     

       78
       78
       +
           if t.disallowed_tools <> [] then 

     

       79
       79
       +
             ("disallowed_tools", `A (List.map (fun s -> `String s) t.disallowed_tools)) :: fields

     

       80
       80
       +
           else fields

     

       81
       81
       +
         in

     

       82
       82
       +
         let fields = 

     

       83
       83
       +
           if t.max_thinking_tokens <> 8000 then

     

       84
       84
       +
             ("max_thinking_tokens", `Float (float_of_int t.max_thinking_tokens)) :: fields

     

       85
       85
       +
           else fields

     

       86
       86
       +
         in

     

       87
       87
       +
         let fields = match t.system_prompt with

     

       88
       88
       +
           | Some p -> ("system_prompt", `String p) :: fields

     

       89
       89
       +
           | None -> fields

     

       90
       90
       +
         in

     

       91
       91
       +
         let fields = match t.append_system_prompt with

     

       92
       92
       +
           | Some p -> ("append_system_prompt", `String p) :: fields

     

       93
       93
       +
           | None -> fields

     

       94
       94
       +
         in

     

       95
       95
       +
         let fields = match t.permission_mode with

     

       96
       96
       +
           | Some m -> ("permission_mode", Permissions.Mode.to_json m) :: fields

     

       97
       97
       +
           | None -> fields

     

       98
       98
       +
         in

     

       99
       99
       +
         let fields = match t.model with

     

       100
       100
       +
           | Some m -> ("model", `String m) :: fields

     

       101
       101
       +
           | None -> fields

     

       102
       102
       +
         in

     

       103
       103
       +
         let fields = 

     

       104
       104
       +
           if t.env <> [] then

     

       105
       105
       +
             let env_obj = `O (List.map (fun (k, v) -> (k, `String v)) t.env) in

     

       106
       106
       +
             ("env", env_obj) :: fields

     

       107
       107
       +
           else fields

     

       108
       108
       +
         in

     

       109
       109
       +
         `O fields

     

       110
       110
       +
       

     

       111
       111
       +
       let of_json = function

     

       112
       112
       +
         | `O fields ->

     

       113
       113
       +
             let allowed_tools = 

     

       114
       114
       +
               try get_list get_string (List.assoc "allowed_tools" fields)

     

       115
       115
       +
               with Not_found -> []

     

       116
       116
       +
             in

     

       117
       117
       +
             let disallowed_tools = 

     

       118
       118
       +
               try get_list get_string (List.assoc "disallowed_tools" fields)

     

       119
       119
       +
               with Not_found -> []

     

       120
       120
       +
             in

     

       121
       121
       +
             let max_thinking_tokens =

     

       122
       122
       +
               try int_of_float (get_float (List.assoc "max_thinking_tokens" fields))

     

       123
       123
       +
               with Not_found -> 8000

     

       124
       124
       +
             in

     

       125
       125
       +
             let system_prompt = 

     

       126
       126
       +
               try Some (get_string (List.assoc "system_prompt" fields))

     

       127
       127
       +
               with Not_found -> None

     

       128
       128
       +
             in

     

       129
       129
       +
             let append_system_prompt = 

     

       130
       130
       +
               try Some (get_string (List.assoc "append_system_prompt" fields))

     

       131
       131
       +
               with Not_found -> None

     

       132
       132
       +
             in

     

       133
       133
       +
             let permission_mode = 

     

       134
       134
       +
               try Some (Permissions.Mode.of_json (List.assoc "permission_mode" fields))

     

       135
       135
       +
               with Not_found -> None

     

       136
       136
       +
             in

     

       137
       137
       +
             let model = 

     

       138
       138
       +
               try Some (get_string (List.assoc "model" fields))

     

       139
       139
       +
               with Not_found -> None

     

       140
       140
       +
             in

     

       141
       141
       +
             let env = 

     

       142
       142
       +
               try 

     

       143
       143
       +
                 match List.assoc "env" fields with

     

       144
       144
       +
                 | `O pairs -> List.map (fun (k, v) -> (k, get_string v)) pairs

     

       145
       145
       +
                 | _ -> []

     

       146
       146
       +
               with Not_found -> []

     

       147
       147
       +
             in

     

       148
       148
       +
             { allowed_tools; disallowed_tools; max_thinking_tokens;

     

       149
       149
       +
               system_prompt; append_system_prompt; permission_mode;

     

       150
       150
       +
               permission_callback = Some Permissions.default_allow_callback;

     

       151
       151
       +
               model; cwd = None; env }

     

       152
       152
       +
         | _ -> raise (Invalid_argument "Options.of_json: expected object")

     

       153
       153
       +
       

     

       154
       154
       +
       let pp fmt t =

     

       155
       155
       +
         Fmt.pf fmt "@[<v>Options {@ \

     

       156
       156
       +
           allowed_tools = %a;@ \

     

       157
       157
       +
           disallowed_tools = %a;@ \

     

       158
       158
       +
           max_thinking_tokens = %d;@ \

     

       159
       159
       +
           system_prompt = %a;@ \

     

       160
       160
       +
           append_system_prompt = %a;@ \

     

       161
       161
       +
           permission_mode = %a;@ \

     

       162
       162
       +
           model = %a;@ \

     

       163
       163
       +
           env = %a@ \

     

       164
       164
       +
         }@]"

     

       165
       165
       +
           Fmt.(list string) t.allowed_tools

     

       166
       166
       +
           Fmt.(list string) t.disallowed_tools

     

       167
       167
       +
           t.max_thinking_tokens

     

       168
       168
       +
           Fmt.(option string) t.system_prompt

     

       169
       169
       +
           Fmt.(option string) t.append_system_prompt

     

       170
       170
       +
           Fmt.(option Permissions.Mode.pp) t.permission_mode

     

       171
       171
       +
           Fmt.(option string) t.model

     

       172
       172
       +
           Fmt.(list (pair string string)) t.env

     

       173
       173
       +
       

     

       174
       174
       +
       let log_options t =

     

       175
       175
       +
         Log.debug (fun m -> m "Claude options: %a" pp t)

+126 -13

claudeio/lib/options.mli

···

       1
       1
       -
       type t = {

     

       2
       2
       -
         allowed_tools : string list;

     

       3
       3
       -
         disallowed_tools : string list;

     

       4
       4
       -
         max_thinking_tokens : int;

     

       5
       5
       -
         system_prompt : string option;

     

       6
       6
       -
         append_system_prompt : string option;

     

       7
       7
       -
         permission_mode : [ `Default | `AcceptEdits | `Plan | `BypassPermissions ] option;

     

       8
       8
       -
         permission_callback : Permissions.callback option;

     

       9
       9
       -
         model : string option;

     

       10
       10
       -
         cwd : Eio.Fs.dir_ty Eio.Path.t option;

     

       11
       11
       -
         env : (string * string) list;

     

       12
       12
       -
       }

     

       1
       1
       +
       (** Configuration options for Claude sessions.

     

       2
       2
       +
           

     

       3
       3
       +
           This module provides configuration options for controlling Claude's

     

       4
       4
       +
           behavior, including tool permissions, system prompts, models, and

     

       5
       5
       +
           execution environment. *)

     

       6
       6
       +
       

     

       7
       7
       +
       open Ezjsonm

     

       8
       8
       +
       

     

       9
       9
       +
       (** The log source for options operations *)

     

       10
       10
       +
       val src : Logs.Src.t

     

       11
       11
       +
       

     

       12
       12
       +
       type t

     

       13
       13
       +
       (** The type of configuration options. *)

     

       14
       14
       +
       

     

       15
       15
       +
       val default : t

     

       16
       16
       +
       (** [default] returns the default configuration with sensible defaults:

     

       17
       17
       +
           - No tool restrictions

     

       18
       18
       +
           - 8000 max thinking tokens

     

       19
       19
       +
           - Default allow permission callback

     

       20
       20
       +
           - No custom prompts or model override *)

     

       21
       21
       +
       

     

       22
       22
       +
       val create :

     

       23
       23
       +
         ?allowed_tools:string list ->

     

       24
       24
       +
         ?disallowed_tools:string list ->

     

       25
       25
       +
         ?max_thinking_tokens:int ->

     

       26
       26
       +
         ?system_prompt:string ->

     

       27
       27
       +
         ?append_system_prompt:string ->

     

       28
       28
       +
         ?permission_mode:Permissions.Mode.t ->

     

       29
       29
       +
         ?permission_callback:Permissions.callback ->

     

       30
       30
       +
         ?model:string ->

     

       31
       31
       +
         ?cwd:Eio.Fs.dir_ty Eio.Path.t ->

     

       32
       32
       +
         ?env:(string * string) list ->

     

       33
       33
       +
         unit -> t

     

       34
       34
       +
       (** [create ?allowed_tools ?disallowed_tools ?max_thinking_tokens ?system_prompt

     

       35
       35
       +
           ?append_system_prompt ?permission_mode ?permission_callback ?model ?cwd ?env ()]

     

       36
       36
       +
           creates a new configuration.

     

       37
       37
       +
           @param allowed_tools List of explicitly allowed tool names

     

       38
       38
       +
           @param disallowed_tools List of explicitly disallowed tool names

     

       39
       39
       +
           @param max_thinking_tokens Maximum tokens for thinking blocks (default: 8000)

     

       40
       40
       +
           @param system_prompt Replace the default system prompt

     

       41
       41
       +
           @param append_system_prompt Append to the default system prompt

     

       42
       42
       +
           @param permission_mode Permission mode to use

     

       43
       43
       +
           @param permission_callback Custom permission callback

     

       44
       44
       +
           @param model Override the default model

     

       45
       45
       +
           @param cwd Working directory for file operations

     

       46
       46
       +
           @param env Environment variables to set *)

     

       47
       47
       +
       

     

       48
       48
       +
       (** {1 Accessors} *)

     

       49
       49
       +
       

     

       50
       50
       +
       val allowed_tools : t -> string list

     

       51
       51
       +
       (** [allowed_tools t] returns the list of allowed tools. *)

     

       52
       52
       +
       

     

       53
       53
       +
       val disallowed_tools : t -> string list

     

       54
       54
       +
       (** [disallowed_tools t] returns the list of disallowed tools. *)

     

       55
       55
       +
       

     

       56
       56
       +
       val max_thinking_tokens : t -> int

     

       57
       57
       +
       (** [max_thinking_tokens t] returns the maximum thinking tokens. *)

     

       58
       58
       +
       

     

       59
       59
       +
       val system_prompt : t -> string option

     

       60
       60
       +
       (** [system_prompt t] returns the optional system prompt override. *)

     

       61
       61
       +
       

     

       62
       62
       +
       val append_system_prompt : t -> string option

     

       63
       63
       +
       (** [append_system_prompt t] returns the optional system prompt append. *)

     

       64
       64
       +
       

     

       65
       65
       +
       val permission_mode : t -> Permissions.Mode.t option

     

       66
       66
       +
       (** [permission_mode t] returns the optional permission mode. *)

     

       67
       67
       +
       

     

       68
       68
       +
       val permission_callback : t -> Permissions.callback option

     

       69
       69
       +
       (** [permission_callback t] returns the optional permission callback. *)

     

       70
       70
       +
       

     

       71
       71
       +
       val model : t -> string option

     

       72
       72
       +
       (** [model t] returns the optional model override. *)

     

       73
       73
       +
       

     

       74
       74
       +
       val cwd : t -> Eio.Fs.dir_ty Eio.Path.t option

     

       75
       75
       +
       (** [cwd t] returns the optional working directory. *)

     

       76
       76
       +
       

     

       77
       77
       +
       val env : t -> (string * string) list

     

       78
       78
       +
       (** [env t] returns the environment variables. *)

     

       79
       79
       +
       

     

       80
       80
       +
       (** {1 Builders} *)

     

       81
       81
       +
       

     

       82
       82
       +
       val with_allowed_tools : string list -> t -> t

     

       83
       83
       +
       (** [with_allowed_tools tools t] sets the allowed tools. *)

     

       84
       84
       +
       

     

       85
       85
       +
       val with_disallowed_tools : string list -> t -> t

     

       86
       86
       +
       (** [with_disallowed_tools tools t] sets the disallowed tools. *)

     

       87
       87
       +
       

     

       88
       88
       +
       val with_max_thinking_tokens : int -> t -> t

     

       89
       89
       +
       (** [with_max_thinking_tokens tokens t] sets the maximum thinking tokens. *)

     

       90
       90
       +
       

     

       91
       91
       +
       val with_system_prompt : string -> t -> t

     

       92
       92
       +
       (** [with_system_prompt prompt t] sets the system prompt override. *)

     

       93
       93
       +
       

     

       94
       94
       +
       val with_append_system_prompt : string -> t -> t

     

       95
       95
       +
       (** [with_append_system_prompt prompt t] sets the system prompt append. *)

     

       96
       96
       +
       

     

       97
       97
       +
       val with_permission_mode : Permissions.Mode.t -> t -> t

     

       98
       98
       +
       (** [with_permission_mode mode t] sets the permission mode. *)

     

       99
       99
       +
       

     

       100
       100
       +
       val with_permission_callback : Permissions.callback -> t -> t

     

       101
       101
       +
       (** [with_permission_callback callback t] sets the permission callback. *)

     

       102
       102
       +
       

     

       103
       103
       +
       val with_model : string -> t -> t

     

       104
       104
       +
       (** [with_model model t] sets the model override. *)

     

       105
       105
       +
       

     

       106
       106
       +
       val with_cwd : Eio.Fs.dir_ty Eio.Path.t -> t -> t

     

       107
       107
       +
       (** [with_cwd cwd t] sets the working directory. *)

     

       13
       108
        
       

     

       14
       14
       -
       val default : t
     

       109
       109
       +
       val with_env : (string * string) list -> t -> t

     

       110
       110
       +
       (** [with_env env t] sets the environment variables. *)

     

       111
       111
       +
       

     

       112
       112
       +
       (** {1 Serialization} *)

     

       113
       113
       +
       

     

       114
       114
       +
       val to_json : t -> value

     

       115
       115
       +
       (** [to_json t] converts options to JSON representation. *)

     

       116
       116
       +
       

     

       117
       117
       +
       val of_json : value -> t

     

       118
       118
       +
       (** [of_json json] parses options from JSON.

     

       119
       119
       +
           @raise Invalid_argument if the JSON is not valid options. *)

     

       120
       120
       +
       

     

       121
       121
       +
       val pp : Format.formatter -> t -> unit

     

       122
       122
       +
       (** [pp fmt t] pretty-prints the options. *)

     

       123
       123
       +
       

     

       124
       124
       +
       (** {1 Logging} *)

     

       125
       125
       +
       

     

       126
       126
       +
       val log_options : t -> unit

     

       127
       127
       +
       (** [log_options t] logs the current options configuration. *)

+329 -47

claudeio/lib/permissions.ml

···

       1
       1
       -
       type behavior = Allow | Deny | Ask

     

       1
       1
       +
       open Ezjsonm

     

       2
       2
        
       

     

       3
       3
       -
       type rule = {

     

       4
       4
       -
         tool_name : string;

     

       5
       5
       -
         rule_content : string option;

     

       6
       6
       -
       }

     

       3
       3
       +
       let src = Logs.Src.create "claude.permission" ~doc:"Claude permission system"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       7
       5
        
       

     

       8
       8
       -
       type update = {

     

       9
       9
       -
         behavior : behavior;

     

       10
       10
       -
         rules : rule list;

     

       11
       11
       -
       }

     

       6
       6
       +
       (* Helper for pretty-printing JSON *)

     

       7
       7
       +
       let pp_json fmt json =

     

       8
       8
       +
         Fmt.string fmt (value_to_string json)

     

       12
       9
        
       

     

       13
       13
       -
       type context = {

     

       14
       14
       -
         suggestions : update list;

     

       15
       15
       -
       }

     

       10
       10
       +
       (** Permission modes *)

     

       11
       11
       +
       module Mode = struct

     

       12
       12
       +
         type t = 

     

       13
       13
       +
           | Default

     

       14
       14
       +
           | Accept_edits

     

       15
       15
       +
           | Plan

     

       16
       16
       +
           | Bypass_permissions

     

       17
       17
       +
         

     

       18
       18
       +
         let to_string = function

     

       19
       19
       +
           | Default -> "default"

     

       20
       20
       +
           | Accept_edits -> "acceptEdits"

     

       21
       21
       +
           | Plan -> "plan"

     

       22
       22
       +
           | Bypass_permissions -> "bypassPermissions"

     

       23
       23
       +
         

     

       24
       24
       +
         let of_string = function

     

       25
       25
       +
           | "default" -> Default

     

       26
       26
       +
           | "acceptEdits" -> Accept_edits

     

       27
       27
       +
           | "plan" -> Plan

     

       28
       28
       +
           | "bypassPermissions" -> Bypass_permissions

     

       29
       29
       +
           | s -> raise (Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))

     

       30
       30
       +
         

     

       31
       31
       +
         let to_json t = `String (to_string t)

     

       32
       32
       +
         

     

       33
       33
       +
         let of_json = function

     

       34
       34
       +
           | `String s -> of_string s

     

       35
       35
       +
           | _ -> raise (Invalid_argument "Mode.of_json: expected string")

     

       36
       36
       +
         

     

       37
       37
       +
         let pp fmt t = Fmt.string fmt (to_string t)

     

       38
       38
       +
       end

     

       16
       39
        
       

     

       17
       17
       -
       type result =

     

       18
       18
       -
         | Allow of {

     

       19
       19
       -
             updated_input : Ezjsonm.value option;

     

       20
       20
       -
             updated_permissions : update list option;

     

       21
       21
       -
           }

     

       22
       22
       -
         | Deny of {

     

       23
       23
       -
             message : string;

     

       24
       24
       -
             interrupt : bool;

     

       25
       25
       -
           }

     

       40
       40
       +
       (** Permission behaviors *)

     

       41
       41
       +
       module Behavior = struct

     

       42
       42
       +
         type t = Allow | Deny | Ask

     

       43
       43
       +
         

     

       44
       44
       +
         let to_string = function

     

       45
       45
       +
           | Allow -> "allow"

     

       46
       46
       +
           | Deny -> "deny"

     

       47
       47
       +
           | Ask -> "ask"

     

       48
       48
       +
         

     

       49
       49
       +
         let of_string = function

     

       50
       50
       +
           | "allow" -> Allow

     

       51
       51
       +
           | "deny" -> Deny

     

       52
       52
       +
           | "ask" -> Ask

     

       53
       53
       +
           | s -> raise (Invalid_argument (Printf.sprintf "Behavior.of_string: unknown behavior %s" s))

     

       54
       54
       +
         

     

       55
       55
       +
         let to_json t = `String (to_string t)

     

       56
       56
       +
         

     

       57
       57
       +
         let of_json = function

     

       58
       58
       +
           | `String s -> of_string s

     

       59
       59
       +
           | _ -> raise (Invalid_argument "Behavior.of_json: expected string")

     

       60
       60
       +
         

     

       61
       61
       +
         let pp fmt t = Fmt.string fmt (to_string t)

     

       62
       62
       +
       end

     

       26
       63
        
       

     

       64
       64
       +
       (** Permission rules *)

     

       65
       65
       +
       module Rule = struct

     

       66
       66
       +
         type t = {

     

       67
       67
       +
           tool_name : string;

     

       68
       68
       +
           rule_content : string option;

     

       69
       69
       +
         }

     

       70
       70
       +
         

     

       71
       71
       +
         let create ~tool_name ?rule_content () = { tool_name; rule_content }

     

       72
       72
       +
         let tool_name t = t.tool_name

     

       73
       73
       +
         let rule_content t = t.rule_content

     

       74
       74
       +
         

     

       75
       75
       +
         let to_json t =

     

       76
       76
       +
           let fields = [("tool_name", `String t.tool_name)] in

     

       77
       77
       +
           let fields = match t.rule_content with

     

       78
       78
       +
             | Some c -> ("rule_content", `String c) :: fields

     

       79
       79
       +
             | None -> fields

     

       80
       80
       +
           in

     

       81
       81
       +
           `O fields

     

       82
       82
       +
         

     

       83
       83
       +
         let of_json = function

     

       84
       84
       +
           | `O fields ->

     

       85
       85
       +
               let tool_name = get_string (List.assoc "tool_name" fields) in

     

       86
       86
       +
               let rule_content = 

     

       87
       87
       +
                 try Some (get_string (List.assoc "rule_content" fields))

     

       88
       88
       +
                 with Not_found -> None

     

       89
       89
       +
               in

     

       90
       90
       +
               { tool_name; rule_content }

     

       91
       91
       +
           | _ -> raise (Invalid_argument "Rule.of_json: expected object")

     

       92
       92
       +
         

     

       93
       93
       +
         let pp fmt t =

     

       94
       94
       +
           Fmt.pf fmt "@[<2>Rule@ { tool_name = %S;@ rule_content = %a }@]"

     

       95
       95
       +
             t.tool_name Fmt.(option string) t.rule_content

     

       96
       96
       +
       end

     

       97
       97
       +
       

     

       98
       98
       +
       (** Permission updates *)

     

       99
       99
       +
       module Update = struct

     

       100
       100
       +
         type destination = 

     

       101
       101
       +
           | User_settings

     

       102
       102
       +
           | Project_settings

     

       103
       103
       +
           | Local_settings

     

       104
       104
       +
           | Session

     

       105
       105
       +
         

     

       106
       106
       +
         let destination_to_string = function

     

       107
       107
       +
           | User_settings -> "userSettings"

     

       108
       108
       +
           | Project_settings -> "projectSettings"

     

       109
       109
       +
           | Local_settings -> "localSettings"

     

       110
       110
       +
           | Session -> "session"

     

       111
       111
       +
         

     

       112
       112
       +
         let destination_of_string = function

     

       113
       113
       +
           | "userSettings" -> User_settings

     

       114
       114
       +
           | "projectSettings" -> Project_settings

     

       115
       115
       +
           | "localSettings" -> Local_settings

     

       116
       116
       +
           | "session" -> Session

     

       117
       117
       +
           | s -> raise (Invalid_argument (Printf.sprintf "destination_of_string: unknown %s" s))

     

       118
       118
       +
         

     

       119
       119
       +
         type update_type =

     

       120
       120
       +
           | Add_rules

     

       121
       121
       +
           | Replace_rules

     

       122
       122
       +
           | Remove_rules

     

       123
       123
       +
           | Set_mode

     

       124
       124
       +
           | Add_directories

     

       125
       125
       +
           | Remove_directories

     

       126
       126
       +
         

     

       127
       127
       +
         let update_type_to_string = function

     

       128
       128
       +
           | Add_rules -> "addRules"

     

       129
       129
       +
           | Replace_rules -> "replaceRules"

     

       130
       130
       +
           | Remove_rules -> "removeRules"

     

       131
       131
       +
           | Set_mode -> "setMode"

     

       132
       132
       +
           | Add_directories -> "addDirectories"

     

       133
       133
       +
           | Remove_directories -> "removeDirectories"

     

       134
       134
       +
         

     

       135
       135
       +
         let update_type_of_string = function

     

       136
       136
       +
           | "addRules" -> Add_rules

     

       137
       137
       +
           | "replaceRules" -> Replace_rules

     

       138
       138
       +
           | "removeRules" -> Remove_rules

     

       139
       139
       +
           | "setMode" -> Set_mode

     

       140
       140
       +
           | "addDirectories" -> Add_directories

     

       141
       141
       +
           | "removeDirectories" -> Remove_directories

     

       142
       142
       +
           | s -> raise (Invalid_argument (Printf.sprintf "update_type_of_string: unknown %s" s))

     

       143
       143
       +
         

     

       144
       144
       +
         type t = {

     

       145
       145
       +
           update_type : update_type;

     

       146
       146
       +
           rules : Rule.t list option;

     

       147
       147
       +
           behavior : Behavior.t option;

     

       148
       148
       +
           mode : Mode.t option;

     

       149
       149
       +
           directories : string list option;

     

       150
       150
       +
           destination : destination option;

     

       151
       151
       +
         }

     

       152
       152
       +
         

     

       153
       153
       +
         let create ~update_type ?rules ?behavior ?mode ?directories ?destination () =

     

       154
       154
       +
           { update_type; rules; behavior; mode; directories; destination }

     

       155
       155
       +
         

     

       156
       156
       +
         let update_type t = t.update_type

     

       157
       157
       +
         let rules t = t.rules

     

       158
       158
       +
         let behavior t = t.behavior

     

       159
       159
       +
         let mode t = t.mode

     

       160
       160
       +
         let directories t = t.directories

     

       161
       161
       +
         let destination t = t.destination

     

       162
       162
       +
         

     

       163
       163
       +
         let to_json t =

     

       164
       164
       +
           let fields = [("type", `String (update_type_to_string t.update_type))] in

     

       165
       165
       +
           let fields = match t.rules with

     

       166
       166
       +
             | Some rules -> ("rules", `A (List.map Rule.to_json rules)) :: fields

     

       167
       167
       +
             | None -> fields

     

       168
       168
       +
           in

     

       169
       169
       +
           let fields = match t.behavior with

     

       170
       170
       +
             | Some b -> ("behavior", Behavior.to_json b) :: fields

     

       171
       171
       +
             | None -> fields

     

       172
       172
       +
           in

     

       173
       173
       +
           let fields = match t.mode with

     

       174
       174
       +
             | Some m -> ("mode", Mode.to_json m) :: fields

     

       175
       175
       +
             | None -> fields

     

       176
       176
       +
           in

     

       177
       177
       +
           let fields = match t.directories with

     

       178
       178
       +
             | Some dirs -> ("directories", `A (List.map (fun s -> `String s) dirs)) :: fields

     

       179
       179
       +
             | None -> fields

     

       180
       180
       +
           in

     

       181
       181
       +
           let fields = match t.destination with

     

       182
       182
       +
             | Some d -> ("destination", `String (destination_to_string d)) :: fields

     

       183
       183
       +
             | None -> fields

     

       184
       184
       +
           in

     

       185
       185
       +
           `O fields

     

       186
       186
       +
         

     

       187
       187
       +
         let of_json = function

     

       188
       188
       +
           | `O fields ->

     

       189
       189
       +
               let update_type = update_type_of_string (get_string (List.assoc "type" fields)) in

     

       190
       190
       +
               let rules = 

     

       191
       191
       +
                 try Some (get_list Rule.of_json (List.assoc "rules" fields))

     

       192
       192
       +
                 with Not_found -> None

     

       193
       193
       +
               in

     

       194
       194
       +
               let behavior = 

     

       195
       195
       +
                 try Some (Behavior.of_json (List.assoc "behavior" fields))

     

       196
       196
       +
                 with Not_found -> None

     

       197
       197
       +
               in

     

       198
       198
       +
               let mode = 

     

       199
       199
       +
                 try Some (Mode.of_json (List.assoc "mode" fields))

     

       200
       200
       +
                 with Not_found -> None

     

       201
       201
       +
               in

     

       202
       202
       +
               let directories = 

     

       203
       203
       +
                 try Some (get_list get_string (List.assoc "directories" fields))

     

       204
       204
       +
                 with Not_found -> None

     

       205
       205
       +
               in

     

       206
       206
       +
               let destination = 

     

       207
       207
       +
                 try Some (destination_of_string (get_string (List.assoc "destination" fields)))

     

       208
       208
       +
                 with Not_found -> None

     

       209
       209
       +
               in

     

       210
       210
       +
               { update_type; rules; behavior; mode; directories; destination }

     

       211
       211
       +
           | _ -> raise (Invalid_argument "Update.of_json: expected object")

     

       212
       212
       +
         

     

       213
       213
       +
         let pp fmt t =

     

       214
       214
       +
           Fmt.pf fmt "@[<2>Update@ { type = %s;@ rules = %a;@ behavior = %a;@ \

     

       215
       215
       +
                       mode = %a;@ directories = %a;@ destination = %a }@]"

     

       216
       216
       +
             (update_type_to_string t.update_type)

     

       217
       217
       +
             Fmt.(option (list Rule.pp)) t.rules

     

       218
       218
       +
             Fmt.(option Behavior.pp) t.behavior

     

       219
       219
       +
             Fmt.(option Mode.pp) t.mode

     

       220
       220
       +
             Fmt.(option (list string)) t.directories

     

       221
       221
       +
             Fmt.(option (fun fmt d -> Fmt.string fmt (destination_to_string d))) t.destination

     

       222
       222
       +
       end

     

       223
       223
       +
       

     

       224
       224
       +
       (** Permission context for callbacks *)

     

       225
       225
       +
       module Context = struct

     

       226
       226
       +
         type t = {

     

       227
       227
       +
           suggestions : Update.t list;

     

       228
       228
       +
         }

     

       229
       229
       +
         

     

       230
       230
       +
         let create ?(suggestions = []) () = { suggestions }

     

       231
       231
       +
         let suggestions t = t.suggestions

     

       232
       232
       +
         

     

       233
       233
       +
         let to_json t =

     

       234
       234
       +
           `O [("suggestions", `A (List.map Update.to_json t.suggestions))]

     

       235
       235
       +
         

     

       236
       236
       +
         let of_json = function

     

       237
       237
       +
           | `O fields ->

     

       238
       238
       +
               let suggestions = 

     

       239
       239
       +
                 try get_list Update.of_json (List.assoc "suggestions" fields)

     

       240
       240
       +
                 with Not_found -> []

     

       241
       241
       +
               in

     

       242
       242
       +
               { suggestions }

     

       243
       243
       +
           | _ -> raise (Invalid_argument "Context.of_json: expected object")

     

       244
       244
       +
         

     

       245
       245
       +
         let pp fmt t =

     

       246
       246
       +
           Fmt.pf fmt "@[<2>Context@ { suggestions = @[<v>%a@] }@]"

     

       247
       247
       +
             Fmt.(list ~sep:(any "@,") Update.pp) t.suggestions

     

       248
       248
       +
       end

     

       249
       249
       +
       

     

       250
       250
       +
       (** Permission results *)

     

       251
       251
       +
       module Result = struct

     

       252
       252
       +
         type t =

     

       253
       253
       +
           | Allow of {

     

       254
       254
       +
               updated_input : value option;

     

       255
       255
       +
               updated_permissions : Update.t list option;

     

       256
       256
       +
             }

     

       257
       257
       +
           | Deny of {

     

       258
       258
       +
               message : string;

     

       259
       259
       +
               interrupt : bool;

     

       260
       260
       +
             }

     

       261
       261
       +
         

     

       262
       262
       +
         let allow ?updated_input ?updated_permissions () =

     

       263
       263
       +
           Allow { updated_input; updated_permissions }

     

       264
       264
       +
         

     

       265
       265
       +
         let deny ~message ~interrupt = Deny { message; interrupt }

     

       266
       266
       +
         

     

       267
       267
       +
         let to_json = function

     

       268
       268
       +
           | Allow { updated_input; updated_permissions } ->

     

       269
       269
       +
               let fields = [("behavior", `String "allow")] in

     

       270
       270
       +
               let fields = match updated_input with

     

       271
       271
       +
                 | Some input -> ("updated_input", input) :: fields

     

       272
       272
       +
                 | None -> fields

     

       273
       273
       +
               in

     

       274
       274
       +
               let fields = match updated_permissions with

     

       275
       275
       +
                 | Some perms -> ("updated_permissions", `A (List.map Update.to_json perms)) :: fields

     

       276
       276
       +
                 | None -> fields

     

       277
       277
       +
               in

     

       278
       278
       +
               `O fields

     

       279
       279
       +
           | Deny { message; interrupt } ->

     

       280
       280
       +
               `O [

     

       281
       281
       +
                 ("behavior", `String "deny");

     

       282
       282
       +
                 ("message", `String message);

     

       283
       283
       +
                 ("interrupt", `Bool interrupt);

     

       284
       284
       +
               ]

     

       285
       285
       +
         

     

       286
       286
       +
         let of_json = function

     

       287
       287
       +
           | `O fields -> (

     

       288
       288
       +
               match List.assoc "behavior" fields with

     

       289
       289
       +
               | `String "allow" ->

     

       290
       290
       +
                   let updated_input = List.assoc_opt "updated_input" fields in

     

       291
       291
       +
                   let updated_permissions = 

     

       292
       292
       +
                     try Some (get_list Update.of_json (List.assoc "updated_permissions" fields))

     

       293
       293
       +
                     with Not_found -> None

     

       294
       294
       +
                   in

     

       295
       295
       +
                   Allow { updated_input; updated_permissions }

     

       296
       296
       +
               | `String "deny" ->

     

       297
       297
       +
                   let message = get_string (List.assoc "message" fields) in

     

       298
       298
       +
                   let interrupt = get_bool (List.assoc "interrupt" fields) in

     

       299
       299
       +
                   Deny { message; interrupt }

     

       300
       300
       +
               | _ -> raise (Invalid_argument "Result.of_json: unknown behavior")

     

       301
       301
       +
             )

     

       302
       302
       +
           | _ -> raise (Invalid_argument "Result.of_json: expected object")

     

       303
       303
       +
         

     

       304
       304
       +
         let pp fmt = function

     

       305
       305
       +
           | Allow { updated_input; updated_permissions } ->

     

       306
       306
       +
               Fmt.pf fmt "@[<2>Allow@ { updated_input = %a;@ updated_permissions = %a }@]"

     

       307
       307
       +
                 Fmt.(option pp_json) updated_input

     

       308
       308
       +
                 Fmt.(option (list Update.pp)) updated_permissions

     

       309
       309
       +
           | Deny { message; interrupt } ->

     

       310
       310
       +
               Fmt.pf fmt "@[<2>Deny@ { message = %S;@ interrupt = %b }@]" message interrupt

     

       311
       311
       +
       end

     

       312
       312
       +
       

     

       313
       313
       +
       (** Permission callback type *)

     

       27
       314
        
       type callback = 

     

       28
       315
        
         tool_name:string -> 

     

       29
       29
       -
         input:Ezjsonm.value -> 

     

       30
       30
       -
         context:context -> 

     

       31
       31
       -
         result

     

       32
       32
       -
       

     

       33
       33
       -
       let serialize_result = function

     

       34
       34
       -
         | Allow { updated_input; updated_permissions = _ } ->

     

       35
       35
       -
             let open Ezjsonm in

     

       36
       36
       -
             let fields = [ "behavior", string "allow" ] in

     

       37
       37
       -
             let fields = match updated_input with

     

       38
       38
       -
               | Some input -> ("updated_input", input) :: fields

     

       39
       39
       -
               | None -> fields

     

       40
       40
       -
             in

     

       41
       41
       -
             dict fields

     

       42
       42
       -
         | Deny { message; interrupt } ->

     

       43
       43
       -
             let open Ezjsonm in

     

       44
       44
       -
             dict [

     

       45
       45
       -
               "behavior", string "deny";

     

       46
       46
       -
               "message", string message;

     

       47
       47
       -
               "interrupt", bool interrupt

     

       48
       48
       -
             ]

     

       316
       316
       +
         input:value -> 

     

       317
       317
       +
         context:Context.t -> 

     

       318
       318
       +
         Result.t

     

       49
       319
        
       

     

       320
       320
       +
       (** Default callbacks *)

     

       50
       321
        
       let default_allow_callback ~tool_name:_ ~input:_ ~context:_ =

     

       51
       51
       -
         Allow { updated_input = None; updated_permissions = None }

     

       322
       322
       +
         Result.allow ()

     

       52
       323
        
       

     

       53
       324
        
       let discovery_callback log ~tool_name:_ ~input:_ ~context =

     

       54
       325
        
         List.iter (fun update ->

     

       55
       55
       -
           List.iter (fun rule ->

     

       56
       56
       -
             log := rule :: !log

     

       57
       57
       -
           ) update.rules

     

       58
       58
       -
         ) context.suggestions;

     

       59
       59
       -
         Allow { updated_input = None; updated_permissions = None }
     

       326
       326
       +
           match Update.rules update with

     

       327
       327
       +
           | Some rules ->

     

       328
       328
       +
               List.iter (fun rule ->

     

       329
       329
       +
                 log := rule :: !log

     

       330
       330
       +
               ) rules

     

       331
       331
       +
           | None -> ()

     

       332
       332
       +
         ) (Context.suggestions context);

     

       333
       333
       +
         Result.allow ()

     

       334
       334
       +
       

     

       335
       335
       +
       (** Logging *)

     

       336
       336
       +
       let log_permission_check ~tool_name ~result =

     

       337
       337
       +
         match result with

     

       338
       338
       +
         | Result.Allow _ -> 

     

       339
       339
       +
             Log.info (fun m -> m "Permission granted for tool: %s" tool_name)

     

       340
       340
       +
         | Result.Deny { message; _ } ->

     

       341
       341
       +
             Log.warn (fun m -> m "Permission denied for tool %s: %s" tool_name message)

+250 -27

claudeio/lib/permissions.mli

···

       1
       1
       -
       type behavior = Allow | Deny | Ask

     

       1
       1
       +
       (** Permission system for Claude tool invocations.

     

       2
       2
       +
           

     

       3
       3
       +
           This module provides a permission system for controlling

     

       4
       4
       +
           which tools Claude can invoke and how they can be used. It includes

     

       5
       5
       +
           support for permission modes, rules, updates, and callbacks. *)

     

       6
       6
       +
       

     

       7
       7
       +
       open Ezjsonm

     

       8
       8
       +
       

     

       9
       9
       +
       (** The log source for permission operations *)

     

       10
       10
       +
       val src : Logs.Src.t

     

       11
       11
       +
       

     

       12
       12
       +
       (** {1 Permission Modes} *)

     

       13
       13
       +
       

     

       14
       14
       +
       module Mode : sig

     

       15
       15
       +
         (** Permission modes control the overall behavior of the permission system. *)

     

       16
       16
       +
         

     

       17
       17
       +
         type t = 

     

       18
       18
       +
           | Default  (** Standard permission mode with normal checks *)

     

       19
       19
       +
           | Accept_edits  (** Automatically accept file edits *)

     

       20
       20
       +
           | Plan  (** Planning mode with restricted execution *)

     

       21
       21
       +
           | Bypass_permissions  (** Bypass all permission checks *)

     

       22
       22
       +
         (** The type of permission modes. *)

     

       23
       23
       +
         

     

       24
       24
       +
         val to_string : t -> string

     

       25
       25
       +
         (** [to_string t] converts a mode to its string representation. *)

     

       26
       26
       +
         

     

       27
       27
       +
         val of_string : string -> t

     

       28
       28
       +
         (** [of_string s] parses a mode from its string representation.

     

       29
       29
       +
             @raise Invalid_argument if the string is not a valid mode. *)

     

       30
       30
       +
         

     

       31
       31
       +
         val to_json : t -> value

     

       32
       32
       +
         (** [to_json t] converts a mode to JSON. *)

     

       33
       33
       +
         

     

       34
       34
       +
         val of_json : value -> t

     

       35
       35
       +
         (** [of_json json] parses a mode from JSON.

     

       36
       36
       +
             @raise Invalid_argument if the JSON is not a valid mode. *)

     

       37
       37
       +
         

     

       38
       38
       +
         val pp : Format.formatter -> t -> unit

     

       39
       39
       +
         (** [pp fmt t] pretty-prints the mode. *)

     

       40
       40
       +
       end

     

       41
       41
       +
       

     

       42
       42
       +
       (** {1 Permission Behaviors} *)

     

       43
       43
       +
       

     

       44
       44
       +
       module Behavior : sig

     

       45
       45
       +
         (** Behaviors determine how permission requests are handled. *)

     

       46
       46
       +
         

     

       47
       47
       +
         type t = 

     

       48
       48
       +
           | Allow  (** Allow the operation *)

     

       49
       49
       +
           | Deny  (** Deny the operation *)

     

       50
       50
       +
           | Ask  (** Ask the user for permission *)

     

       51
       51
       +
         (** The type of permission behaviors. *)

     

       52
       52
       +
         

     

       53
       53
       +
         val to_string : t -> string

     

       54
       54
       +
         (** [to_string t] converts a behavior to its string representation. *)

     

       55
       55
       +
         

     

       56
       56
       +
         val of_string : string -> t

     

       57
       57
       +
         (** [of_string s] parses a behavior from its string representation.

     

       58
       58
       +
             @raise Invalid_argument if the string is not a valid behavior. *)

     

       59
       59
       +
         

     

       60
       60
       +
         val to_json : t -> value

     

       61
       61
       +
         (** [to_json t] converts a behavior to JSON. *)

     

       62
       62
       +
         

     

       63
       63
       +
         val of_json : value -> t

     

       64
       64
       +
         (** [of_json json] parses a behavior from JSON.

     

       65
       65
       +
             @raise Invalid_argument if the JSON is not a valid behavior. *)

     

       66
       66
       +
         

     

       67
       67
       +
         val pp : Format.formatter -> t -> unit

     

       68
       68
       +
         (** [pp fmt t] pretty-prints the behavior. *)

     

       69
       69
       +
       end

     

       70
       70
       +
       

     

       71
       71
       +
       (** {1 Permission Rules} *)

     

       72
       72
       +
       

     

       73
       73
       +
       module Rule : sig

     

       74
       74
       +
         (** Rules define specific permissions for tools. *)

     

       75
       75
       +
         

     

       76
       76
       +
         type t = {

     

       77
       77
       +
           tool_name : string;  (** Name of the tool *)

     

       78
       78
       +
           rule_content : string option;  (** Optional rule specification *)

     

       79
       79
       +
         }

     

       80
       80
       +
         (** The type of permission rules. *)

     

       81
       81
       +
         

     

       82
       82
       +
         val create : tool_name:string -> ?rule_content:string -> unit -> t

     

       83
       83
       +
         (** [create ~tool_name ?rule_content ()] creates a new rule.

     

       84
       84
       +
             @param tool_name The name of the tool this rule applies to

     

       85
       85
       +
             @param rule_content Optional rule specification or pattern *)

     

       86
       86
       +
         

     

       87
       87
       +
         val tool_name : t -> string

     

       88
       88
       +
         (** [tool_name t] returns the tool name. *)

     

       89
       89
       +
         

     

       90
       90
       +
         val rule_content : t -> string option

     

       91
       91
       +
         (** [rule_content t] returns the optional rule content. *)

     

       92
       92
       +
         

     

       93
       93
       +
         val to_json : t -> value

     

       94
       94
       +
         (** [to_json t] converts a rule to JSON. *)

     

       95
       95
       +
         

     

       96
       96
       +
         val of_json : value -> t

     

       97
       97
       +
         (** [of_json json] parses a rule from JSON.

     

       98
       98
       +
             @raise Invalid_argument if the JSON is not a valid rule. *)

     

       99
       99
       +
         

     

       100
       100
       +
         val pp : Format.formatter -> t -> unit

     

       101
       101
       +
         (** [pp fmt t] pretty-prints the rule. *)

     

       102
       102
       +
       end

     

       103
       103
       +
       

     

       104
       104
       +
       (** {1 Permission Updates} *)

     

       105
       105
       +
       

     

       106
       106
       +
       module Update : sig

     

       107
       107
       +
         (** Updates modify permission settings. *)

     

       108
       108
       +
         

     

       109
       109
       +
         type destination = 

     

       110
       110
       +
           | User_settings  (** Apply to user settings *)

     

       111
       111
       +
           | Project_settings  (** Apply to project settings *)

     

       112
       112
       +
           | Local_settings  (** Apply to local settings *)

     

       113
       113
       +
           | Session  (** Apply to current session only *)

     

       114
       114
       +
         (** The destination for permission updates. *)

     

       115
       115
       +
         

     

       116
       116
       +
         type update_type =

     

       117
       117
       +
           | Add_rules  (** Add new rules *)

     

       118
       118
       +
           | Replace_rules  (** Replace existing rules *)

     

       119
       119
       +
           | Remove_rules  (** Remove rules *)

     

       120
       120
       +
           | Set_mode  (** Set permission mode *)

     

       121
       121
       +
           | Add_directories  (** Add allowed directories *)

     

       122
       122
       +
           | Remove_directories  (** Remove allowed directories *)

     

       123
       123
       +
         (** The type of permission update. *)

     

       124
       124
       +
         

     

       125
       125
       +
         type t

     

       126
       126
       +
         (** The type of permission updates. *)

     

       127
       127
       +
         

     

       128
       128
       +
         val create : 

     

       129
       129
       +
           update_type:update_type -> 

     

       130
       130
       +
           ?rules:Rule.t list -> 

     

       131
       131
       +
           ?behavior:Behavior.t -> 

     

       132
       132
       +
           ?mode:Mode.t -> 

     

       133
       133
       +
           ?directories:string list -> 

     

       134
       134
       +
           ?destination:destination -> 

     

       135
       135
       +
           unit -> t

     

       136
       136
       +
         (** [create ~update_type ?rules ?behavior ?mode ?directories ?destination ()] 

     

       137
       137
       +
             creates a new permission update.

     

       138
       138
       +
             @param update_type The type of update to perform

     

       139
       139
       +
             @param rules Optional list of rules to add/remove/replace

     

       140
       140
       +
             @param behavior Optional behavior to set

     

       141
       141
       +
             @param mode Optional permission mode to set

     

       142
       142
       +
             @param directories Optional directories to add/remove

     

       143
       143
       +
             @param destination Optional destination for the update *)

     

       144
       144
       +
         

     

       145
       145
       +
         val update_type : t -> update_type

     

       146
       146
       +
         (** [update_type t] returns the update type. *)

     

       147
       147
       +
         

     

       148
       148
       +
         val rules : t -> Rule.t list option

     

       149
       149
       +
         (** [rules t] returns the optional list of rules. *)

     

       150
       150
       +
         

     

       151
       151
       +
         val behavior : t -> Behavior.t option

     

       152
       152
       +
         (** [behavior t] returns the optional behavior. *)

     

       153
       153
       +
         

     

       154
       154
       +
         val mode : t -> Mode.t option

     

       155
       155
       +
         (** [mode t] returns the optional mode. *)

     

       156
       156
       +
         

     

       157
       157
       +
         val directories : t -> string list option

     

       158
       158
       +
         (** [directories t] returns the optional list of directories. *)

     

       159
       159
       +
         

     

       160
       160
       +
         val destination : t -> destination option

     

       161
       161
       +
         (** [destination t] returns the optional destination. *)

     

       162
       162
       +
         

     

       163
       163
       +
         val to_json : t -> value

     

       164
       164
       +
         (** [to_json t] converts an update to JSON. *)

     

       165
       165
       +
         

     

       166
       166
       +
         val of_json : value -> t

     

       167
       167
       +
         (** [of_json json] parses an update from JSON.

     

       168
       168
       +
             @raise Invalid_argument if the JSON is not a valid update. *)

     

       169
       169
       +
         

     

       170
       170
       +
         val pp : Format.formatter -> t -> unit

     

       171
       171
       +
         (** [pp fmt t] pretty-prints the update. *)

     

       172
       172
       +
       end

     

       2
       173
        
       

     

       3
       3
       -
       type rule = {

     

       4
       4
       -
         tool_name : string;

     

       5
       5
       -
         rule_content : string option;

     

       6
       6
       -
       }

     

       174
       174
       +
       (** {1 Permission Context} *)

     

       7
       175
        
       

     

       8
       8
       -
       type update = {

     

       9
       9
       -
         behavior : behavior;

     

       10
       10
       -
         rules : rule list;

     

       11
       11
       -
       }

     

       176
       176
       +
       module Context : sig

     

       177
       177
       +
         (** Context provided to permission callbacks. *)

     

       178
       178
       +
         

     

       179
       179
       +
         type t = {

     

       180
       180
       +
           suggestions : Update.t list;  (** Suggested permission updates *)

     

       181
       181
       +
         }

     

       182
       182
       +
         (** The type of permission context. *)

     

       183
       183
       +
         

     

       184
       184
       +
         val create : ?suggestions:Update.t list -> unit -> t

     

       185
       185
       +
         (** [create ?suggestions ()] creates a new context.

     

       186
       186
       +
             @param suggestions Optional list of suggested permission updates *)

     

       187
       187
       +
         

     

       188
       188
       +
         val suggestions : t -> Update.t list

     

       189
       189
       +
         (** [suggestions t] returns the list of suggested updates. *)

     

       190
       190
       +
         

     

       191
       191
       +
         val to_json : t -> value

     

       192
       192
       +
         (** [to_json t] converts a context to JSON. *)

     

       193
       193
       +
         

     

       194
       194
       +
         val of_json : value -> t

     

       195
       195
       +
         (** [of_json json] parses a context from JSON.

     

       196
       196
       +
             @raise Invalid_argument if the JSON is not a valid context. *)

     

       197
       197
       +
         

     

       198
       198
       +
         val pp : Format.formatter -> t -> unit

     

       199
       199
       +
         (** [pp fmt t] pretty-prints the context. *)

     

       200
       200
       +
       end

     

       12
       201
        
       

     

       13
       13
       -
       type context = {

     

       14
       14
       -
         suggestions : update list;

     

       15
       15
       -
       }

     

       202
       202
       +
       (** {1 Permission Results} *)

     

       203
       203
       +
       

     

       204
       204
       +
       module Result : sig

     

       205
       205
       +
         (** Results of permission checks. *)

     

       206
       206
       +
         

     

       207
       207
       +
         type t =

     

       208
       208
       +
           | Allow of {

     

       209
       209
       +
               updated_input : value option;  (** Modified tool input *)

     

       210
       210
       +
               updated_permissions : Update.t list option;  (** Permission updates to apply *)

     

       211
       211
       +
             }

     

       212
       212
       +
           | Deny of {

     

       213
       213
       +
               message : string;  (** Reason for denial *)

     

       214
       214
       +
               interrupt : bool;  (** Whether to interrupt execution *)

     

       215
       215
       +
             }

     

       216
       216
       +
         (** The type of permission results. *)

     

       217
       217
       +
         

     

       218
       218
       +
         val allow : ?updated_input:value -> ?updated_permissions:Update.t list -> unit -> t

     

       219
       219
       +
         (** [allow ?updated_input ?updated_permissions ()] creates an allow result.

     

       220
       220
       +
             @param updated_input Optional modified tool input

     

       221
       221
       +
             @param updated_permissions Optional permission updates to apply *)

     

       222
       222
       +
         

     

       223
       223
       +
         val deny : message:string -> interrupt:bool -> t

     

       224
       224
       +
         (** [deny ~message ~interrupt] creates a deny result.

     

       225
       225
       +
             @param message The reason for denying permission

     

       226
       226
       +
             @param interrupt Whether to interrupt further execution *)

     

       227
       227
       +
         

     

       228
       228
       +
         val to_json : t -> value

     

       229
       229
       +
         (** [to_json t] converts a result to JSON. *)

     

       230
       230
       +
         

     

       231
       231
       +
         val of_json : value -> t

     

       232
       232
       +
         (** [of_json json] parses a result from JSON.

     

       233
       233
       +
             @raise Invalid_argument if the JSON is not a valid result. *)

     

       234
       234
       +
         

     

       235
       235
       +
         val pp : Format.formatter -> t -> unit

     

       236
       236
       +
         (** [pp fmt t] pretty-prints the result. *)

     

       237
       237
       +
       end

     

       16
       238
        
       

     

       17
       17
       -
       type result =

     

       18
       18
       -
         | Allow of {

     

       19
       19
       -
             updated_input : Ezjsonm.value option;

     

       20
       20
       -
             updated_permissions : update list option;

     

       21
       21
       -
           }

     

       22
       22
       -
         | Deny of {

     

       23
       23
       -
             message : string;

     

       24
       24
       -
             interrupt : bool;

     

       25
       25
       -
           }

     

       239
       239
       +
       (** {1 Permission Callbacks} *)

     

       26
       240
        
       

     

       27
       241
        
       type callback = 

     

       28
       242
        
         tool_name:string -> 

     

       29
       29
       -
         input:Ezjsonm.value -> 

     

       30
       30
       -
         context:context -> 

     

       31
       31
       -
         result

     

       32
       32
       -
       

     

       33
       33
       -
       val serialize_result : result -> Ezjsonm.value

     

       243
       243
       +
         input:value -> 

     

       244
       244
       +
         context:Context.t -> 

     

       245
       245
       +
         Result.t

     

       246
       246
       +
       (** The type of permission callbacks. Callbacks are invoked when Claude

     

       247
       247
       +
           attempts to use a tool, allowing custom permission logic. *)

     

       34
       248
        
       

     

       35
       249
        
       val default_allow_callback : callback

     

       250
       250
       +
       (** [default_allow_callback] always allows tool invocations. *)

     

       36
       251
        
       

     

       37
       37
       -
       val discovery_callback : rule list ref -> callback
     

       252
       252
       +
       val discovery_callback : Rule.t list ref -> callback

     

       253
       253
       +
       (** [discovery_callback log] creates a callback that collects suggested

     

       254
       254
       +
           rules into the provided reference. Useful for discovering what

     

       255
       255
       +
           permissions an operation requires. *)

     

       256
       256
       +
       

     

       257
       257
       +
       (** {1 Logging} *)

     

       258
       258
       +
       

     

       259
       259
       +
       val log_permission_check : tool_name:string -> result:Result.t -> unit

     

       260
       260
       +
       (** [log_permission_check ~tool_name ~result] logs a permission check result. *)

+55 -49

claudeio/lib/transport.ml

···

       1
       1
        
       open Eio.Std

     

       2
       2
        
       

     

       3
       3
       +
       let src = Logs.Src.create "claude.transport" ~doc:"Claude transport layer"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       5
       5
       +
       

     

       3
       6
        
       exception CLI_not_found of string

     

       4
       7
        
       exception Process_error of string

     

       5
       8
        
       exception Connection_error of string

     
···

       14
       17
        
         sw : Switch.t;

     

       15
       18
        
       }

     

       16
       19
        
       

     

       17
       17
       -
       let find_claude_cli ~fs =

     

       18
       18
       -
         let ( / ) = Eio.Path.( / ) in

     

       19
       19
       -
         let paths = [

     

       20
       20
       -
           fs / "usr" / "local" / "bin" / "claude";

     

       21
       21
       -
           fs / "opt" / "homebrew" / "bin" / "claude";

     

       22
       22
       -
         ] in

     

       23
       23
       -
         

     

       24
       24
       -
         let rec check_paths = function

     

       25
       25
       -
           | [] -> 

     

       26
       26
       -
               (* Try using 'which' *)

     

       27
       27
       -
               None

     

       28
       28
       -
           | path :: rest ->

     

       29
       29
       -
               if Eio.Path.is_file path then

     

       30
       30
       -
                 Some (Eio.Path.native_exn path)

     

       31
       31
       -
               else

     

       32
       32
       -
                 check_paths rest

     

       33
       33
       -
         in

     

       34
       34
       -
         

     

       35
       35
       -
         match check_paths paths with

     

       36
       36
       -
         | Some path -> path

     

       37
       37
       -
         | None ->

     

       38
       38
       -
             (* Try to find using shell *)

     

       39
       39
       -
             "claude"

     

       40
       40
       -
       

     

       41
       20
        
       let build_command ~claude_path ~options =

     

       42
       42
       -
         let open Options in

     

       43
       21
        
         let cmd = [claude_path; "--output-format"; "stream-json"; "--verbose"] in

     

       44
       22
        
         

     

       45
       45
       -
         let cmd = match options.system_prompt with

     

       23
       23
       +
         let cmd = match Options.system_prompt options with

     

       46
       24
        
           | Some prompt -> cmd @ ["--system-prompt"; prompt]

     

       47
       25
        
           | None -> cmd

     

       48
       26
        
         in

     

       49
       27
        
         

     

       50
       50
       -
         let cmd = match options.append_system_prompt with

     

       28
       28
       +
         let cmd = match Options.append_system_prompt options with

     

       51
       29
        
           | Some prompt -> cmd @ ["--append-system-prompt"; prompt]

     

       52
       30
        
           | None -> cmd

     

       53
       31
        
         in

     

       54
       32
        
         

     

       55
       55
       -
         let cmd = match options.allowed_tools with

     

       33
       33
       +
         let cmd = match Options.allowed_tools options with

     

       56
       34
        
           | [] -> cmd

     

       57
       35
        
           | tools -> cmd @ ["--allowedTools"; String.concat "," tools]

     

       58
       36
        
         in

     

       59
       37
        
         

     

       60
       60
       -
         let cmd = match options.disallowed_tools with

     

       38
       38
       +
         let cmd = match Options.disallowed_tools options with

     

       61
       39
        
           | [] -> cmd

     

       62
       40
        
           | tools -> cmd @ ["--disallowedTools"; String.concat "," tools]

     

       63
       41
        
         in

     

       64
       42
        
         

     

       65
       65
       -
         let cmd = match options.model with

     

       43
       43
       +
         let cmd = match Options.model options with

     

       66
       44
        
           | Some model -> cmd @ ["--model"; model]

     

       67
       45
        
           | None -> cmd

     

       68
       46
        
         in

     

       69
       47
        
         

     

       70
       70
       -
         let cmd = match options.permission_mode with

     

       71
       71
       -
           | Some `Default -> cmd @ ["--permission-mode"; "default"]

     

       72
       72
       -
           | Some `AcceptEdits -> cmd @ ["--permission-mode"; "acceptEdits"]

     

       73
       73
       -
           | Some `Plan -> cmd @ ["--permission-mode"; "plan"]

     

       74
       74
       -
           | Some `BypassPermissions -> cmd @ ["--permission-mode"; "bypassPermissions"]

     

       48
       48
       +
         let cmd = match Options.permission_mode options with

     

       49
       49
       +
           | Some mode -> 

     

       50
       50
       +
               let mode_str = Permissions.Mode.to_string mode in

     

       51
       51
       +
               cmd @ ["--permission-mode"; mode_str]

     

       75
       52
        
           | None -> cmd

     

       76
       53
        
         in

     

       77
       54
        
         

     

       78
       55
        
         (* Use streaming input mode *)

     

       79
       56
        
         cmd @ ["--input-format"; "stream-json"]

     

       80
       57
        
       

     

       81
       81
       -
       let create ~sw ~process_mgr ~fs ~options () =

     

       82
       82
       -
         let claude_path = find_claude_cli ~fs in

     

       58
       58
       +
       let create ~sw ~process_mgr ~options () =

     

       59
       59
       +
         let claude_path = "claude" in

     

       83
       60
        
         let cmd = build_command ~claude_path ~options in

     

       84
       61
        
         

     

       85
       85
       -
         let env = 

     

       86
       86
       -
           Array.of_list (

     

       87
       87
       -
             List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) (

     

       88
       88
       -
               ("CLAUDE_CODE_ENTRYPOINT", "sdk-ocaml") ::

     

       89
       89
       -
               options.Options.env

     

       90
       90
       -
             )

     

       91
       91
       -
           )

     

       92
       92
       -
         in

     

       62
       62
       +
         (* Build environment - preserve essential vars for Claude config/auth access *)

     

       63
       63
       +
         let home = try Unix.getenv "HOME" with Not_found -> "/tmp" in

     

       64
       64
       +
         let path = try Unix.getenv "PATH" with Not_found -> "/usr/bin:/bin" in

     

       65
       65
       +
         

     

       66
       66
       +
         (* Preserve other potentially important environment variables *)

     

       67
       67
       +
         let preserve_vars = [

     

       68
       68
       +
           "USER"; "LOGNAME"; "SHELL"; "TERM"; 

     

       69
       69
       +
           "XDG_CONFIG_HOME"; "XDG_DATA_HOME"; "XDG_CACHE_HOME";

     

       70
       70
       +
           "ANTHROPIC_API_KEY"; "CLAUDE_API_KEY"  (* In case API key is set via env *)

     

       71
       71
       +
         ] in

     

       72
       72
       +
         

     

       73
       73
       +
         let preserved = List.filter_map (fun var ->

     

       74
       74
       +
           try Some (Printf.sprintf "%s=%s" var (Unix.getenv var))

     

       75
       75
       +
           with Not_found -> None

     

       76
       76
       +
         ) preserve_vars in

     

       77
       77
       +
         

     

       78
       78
       +
         let base_env = [

     

       79
       79
       +
           Printf.sprintf "HOME=%s" home;

     

       80
       80
       +
           Printf.sprintf "PATH=%s" path;

     

       81
       81
       +
           "CLAUDE_CODE_ENTRYPOINT=sdk-ocaml";

     

       82
       82
       +
         ] @ preserved in

     

       83
       83
       +
         

     

       84
       84
       +
         let custom_env = List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) (Options.env options) in

     

       85
       85
       +
         let env = Array.of_list (base_env @ custom_env) in

     

       86
       86
       +
         Log.debug (fun m -> m "Environment: HOME=%s, PATH=%s" home path);

     

       93
       87
        
         

     

       94
       88
        
         let stdin_r, stdin_w = Eio.Process.pipe ~sw process_mgr in

     

       95
       89
        
         let stdout_r, stdout_w = Eio.Process.pipe ~sw process_mgr in

     
···

       100
       94
        
         

     

       101
       95
        
         let process = 

     

       102
       96
        
           try

     

       97
       97
       +
             Log.info (fun m -> m "Spawning claude with command: %s" (String.concat " " cmd));

     

       103
       98
        
             Eio.Process.spawn ~sw process_mgr 

     

       104
       99
        
               ~env

     

       105
       100
        
               ~stdin:(stdin_r :> Eio.Flow.source_ty r)

     

       106
       101
        
               ~stdout:(stdout_w :> Eio.Flow.sink_ty r)

     

       107
       107
       -
               ?cwd:options.Options.cwd

     

       102
       102
       +
               ?cwd:(Options.cwd options)

     

       108
       103
        
               cmd

     

       109
       104
        
           with

     

       110
       105
        
           | exn ->

     

       106
       106
       +
               Log.err (fun m -> m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));

     

       107
       107
       +
               Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");

     

       108
       108
       +
               Log.err (fun m -> m "You may need to run 'claude login' first");

     

       111
       109
        
               raise (CLI_not_found (Printf.sprintf "Failed to spawn claude CLI: %s" (Printexc.to_string exn)))

     

       112
       110
        
         in

     

       113
       111
        
         

     
···

       119
       117
        
       

     

       120
       118
        
       let send t json =

     

       121
       119
        
         let data = Ezjsonm.value_to_string json in

     

       120
       120
       +
         Log.debug (fun m -> m "Sending: %s" data);

     

       122
       121
        
         try

     

       123
       122
        
           Eio.Flow.write t.stdin [Cstruct.of_string (data ^ "\n")]

     

       124
       123
        
         with

     

       125
       124
        
         | exn ->

     

       125
       125
       +
             Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));

     

       126
       126
        
             raise (Connection_error (Printf.sprintf "Failed to send message: %s" (Printexc.to_string exn)))

     

       127
       127
        
       

     

       128
       128
        
       let receive_line t =

     

       129
       129
        
         try

     

       130
       130
        
           match Eio.Buf_read.line t.stdout with

     

       131
       131
       -
           | line -> Some line

     

       132
       132
       -
           | exception End_of_file -> None

     

       131
       131
       +
           | line -> 

     

       132
       132
       +
               Log.debug (fun m -> m "Received: %s" line);

     

       133
       133
       +
               Some line

     

       134
       134
       +
           | exception End_of_file -> 

     

       135
       135
       +
               Log.debug (fun m -> m "Received EOF");

     

       136
       136
       +
               None

     

       133
       137
        
         with

     

       134
       138
        
         | exn ->

     

       139
       139
       +
             Log.err (fun m -> m "Failed to receive message: %s" (Printexc.to_string exn));

     

       135
       140
        
             raise (Connection_error (Printf.sprintf "Failed to receive message: %s" (Printexc.to_string exn)))

     

       136
       141
        
       

     

       137
       142
        
       let interrupt t =

     

       143
       143
       +
         Log.info (fun m -> m "Sending interrupt signal");

     

       138
       144
        
         let interrupt_msg = 

     

       139
       145
        
           Ezjsonm.dict [

     

       140
       146
        
             "type", Ezjsonm.string "control_response";

     
···

       151
       157
        
           Eio.Flow.close t.stdin_close;

     

       152
       158
        
           let (P process) = t.process in

     

       153
       159
        
           Eio.Process.await_exn process

     

       154
       154
       -
         with _ -> ()
     

       160
       160
       +
         with _ -> ()

+4 -2

claudeio/lib/transport.mli

···

       1
       1
       +
       (** The log source for transport operations *)

     

       2
       2
       +
       val src : Logs.Src.t

     

       3
       3
       +
       

     

       1
       4
        
       exception CLI_not_found of string

     

       2
       5
        
       exception Process_error of string

     

       3
       6
        
       exception Connection_error of string

     
···

       7
       10
        
       val create : 

     

       8
       11
        
         sw:Eio.Switch.t ->

     

       9
       12
        
         process_mgr:_ Eio.Process.mgr ->

     

       10
       10
       -
         fs:Eio.Fs.dir_ty Eio.Path.t ->

     

       11
       13
        
         options:Options.t ->

     

       12
       14
        
         unit -> t

     

       13
       15
        
       

     

       14
       16
        
       val send : t -> Ezjsonm.value -> unit

     

       15
       17
        
       val receive_line : t -> string option

     

       16
       18
        
       val interrupt : t -> unit

     

       17
       17
       -
       val close : t -> unit
     

       19
       19
       +
       val close : t -> unit

-62

claudeio/lib/types.ml

···

       1
       1
       -
       type text_block = { text : string }

     

       2
       2
       -
       

     

       3
       3
       -
       type tool_use_block = { 

     

       4
       4
       -
         id : string; 

     

       5
       5
       -
         name : string; 

     

       6
       6
       -
         input : Ezjsonm.value 

     

       7
       7
       -
       }

     

       8
       8
       -
       

     

       9
       9
       -
       type tool_result_block = { 

     

       10
       10
       -
         tool_use_id : string; 

     

       11
       11
       -
         content : string option; 

     

       12
       12
       -
         is_error : bool option 

     

       13
       13
       -
       }

     

       14
       14
       -
       

     

       15
       15
       -
       type thinking_block = {

     

       16
       16
       -
         thinking : string;

     

       17
       17
       -
         signature : string;

     

       18
       18
       -
       }

     

       19
       19
       -
       

     

       20
       20
       -
       type content_block =

     

       21
       21
       -
         | Text of text_block

     

       22
       22
       -
         | ToolUse of tool_use_block

     

       23
       23
       -
         | ToolResult of tool_result_block

     

       24
       24
       -
         | Thinking of thinking_block

     

       25
       25
       -
       

     

       26
       26
       -
       type user_message = { 

     

       27
       27
       -
         content : [ `String of string | `Blocks of content_block list ] 

     

       28
       28
       -
       }

     

       29
       29
       -
       

     

       30
       30
       -
       type assistant_message = { 

     

       31
       31
       -
         content : content_block list; 

     

       32
       32
       -
         model : string 

     

       33
       33
       -
       }

     

       34
       34
       -
       

     

       35
       35
       -
       type system_message = { 

     

       36
       36
       -
         subtype : string; 

     

       37
       37
       -
         data : Ezjsonm.value 

     

       38
       38
       -
       }

     

       39
       39
       -
       

     

       40
       40
       -
       type result_message = {

     

       41
       41
       -
         subtype : string;

     

       42
       42
       -
         duration_ms : int;

     

       43
       43
       -
         duration_api_ms : int;

     

       44
       44
       -
         is_error : bool;

     

       45
       45
       -
         num_turns : int;

     

       46
       46
       -
         session_id : string;

     

       47
       47
       -
         total_cost_usd : float option;

     

       48
       48
       -
         usage : Ezjsonm.value option;

     

       49
       49
       -
         result : string option;

     

       50
       50
       -
       }

     

       51
       51
       -
       

     

       52
       52
       -
       type message =

     

       53
       53
       -
         | User of user_message

     

       54
       54
       -
         | Assistant of assistant_message

     

       55
       55
       -
         | System of system_message

     

       56
       56
       -
         | Result of result_message

     

       57
       57
       -
       

     

       58
       58
       -
       type control_message = {

     

       59
       59
       -
         request_id : string;

     

       60
       60
       -
         subtype : string;

     

       61
       61
       -
         data : Ezjsonm.value;

     

       62
       62
       -
       }

-62

claudeio/lib/types.mli

···

       1
       1
       -
       type text_block = { text : string }

     

       2
       2
       -
       

     

       3
       3
       -
       type tool_use_block = { 

     

       4
       4
       -
         id : string; 

     

       5
       5
       -
         name : string; 

     

       6
       6
       -
         input : Ezjsonm.value 

     

       7
       7
       -
       }

     

       8
       8
       -
       

     

       9
       9
       -
       type tool_result_block = { 

     

       10
       10
       -
         tool_use_id : string; 

     

       11
       11
       -
         content : string option; 

     

       12
       12
       -
         is_error : bool option 

     

       13
       13
       -
       }

     

       14
       14
       -
       

     

       15
       15
       -
       type thinking_block = {

     

       16
       16
       -
         thinking : string;

     

       17
       17
       -
         signature : string;

     

       18
       18
       -
       }

     

       19
       19
       -
       

     

       20
       20
       -
       type content_block =

     

       21
       21
       -
         | Text of text_block

     

       22
       22
       -
         | ToolUse of tool_use_block

     

       23
       23
       -
         | ToolResult of tool_result_block

     

       24
       24
       -
         | Thinking of thinking_block

     

       25
       25
       -
       

     

       26
       26
       -
       type user_message = { 

     

       27
       27
       -
         content : [ `String of string | `Blocks of content_block list ] 

     

       28
       28
       -
       }

     

       29
       29
       -
       

     

       30
       30
       -
       type assistant_message = { 

     

       31
       31
       -
         content : content_block list; 

     

       32
       32
       -
         model : string 

     

       33
       33
       -
       }

     

       34
       34
       -
       

     

       35
       35
       -
       type system_message = { 

     

       36
       36
       -
         subtype : string; 

     

       37
       37
       -
         data : Ezjsonm.value 

     

       38
       38
       -
       }

     

       39
       39
       -
       

     

       40
       40
       -
       type result_message = {

     

       41
       41
       -
         subtype : string;

     

       42
       42
       -
         duration_ms : int;

     

       43
       43
       -
         duration_api_ms : int;

     

       44
       44
       -
         is_error : bool;

     

       45
       45
       -
         num_turns : int;

     

       46
       46
       -
         session_id : string;

     

       47
       47
       -
         total_cost_usd : float option;

     

       48
       48
       -
         usage : Ezjsonm.value option;

     

       49
       49
       -
         result : string option;

     

       50
       50
       -
       }

     

       51
       51
       -
       

     

       52
       52
       -
       type message =

     

       53
       53
       -
         | User of user_message

     

       54
       54
       -
         | Assistant of assistant_message

     

       55
       55
       -
         | System of system_message

     

       56
       56
       -
         | Result of result_message

     

       57
       57
       -
       

     

       58
       58
       -
       type control_message = {

     

       59
       59
       -
         request_id : string;

     

       60
       60
       -
         subtype : string;

     

       61
       61
       -
         data : Ezjsonm.value;

     

       62
       62
       -
       }

+90 -25

claudeio/test/camel_jokes.ml

···

       1
       1
        
       open Eio.Std

     

       2
       2
        
       

     

       3
       3
       +
       let src = Logs.Src.create "camel_jokes" ~doc:"Camel joke competition"

     

       4
       4
       +
       module Log = (val Logs.src_log src : Logs.LOG)

     

       5
       5
       +
       

     

       3
       6
        
       let process_claude_response client name =

     

       4
       4
       -
         traceln "\n=== %s's Response ===" name;

     

       7
       7
       +
         Log.info (fun m -> m "=== %s's Response ===" name);

     

       5
       8
        
         let messages = Claude.Client.receive_all client in

     

       6
       9
        
         List.iter (fun msg ->

     

       7
       10
        
           match msg with

     

       8
       8
       -
           | Claude.Types.Assistant msg ->

     

       11
       11
       +
           | Claude.Message.Assistant msg ->

     

       9
       12
        
               List.iter (function

     

       10
       10
       -
                 | Claude.Types.Text { text } -> 

     

       11
       11
       -
                     traceln "%s: %s" name text

     

       13
       13
       +
                 | Claude.Content_block.Text t -> 

     

       14
       14
       +
                     let text = Claude.Content_block.Text.text t in

     

       15
       15
       +
                     Log.app (fun m -> m "%s: %s" name text)

     

       16
       16
       +
                 | Claude.Content_block.Tool_use t ->

     

       17
       17
       +
                     Log.debug (fun m -> m "%s using tool: %s" name 

     

       18
       18
       +
                       (Claude.Content_block.Tool_use.name t))

     

       19
       19
       +
                 | Claude.Content_block.Thinking t ->

     

       20
       20
       +
                     Log.debug (fun m -> m "%s thinking: %s" name 

     

       21
       21
       +
                       (Claude.Content_block.Thinking.thinking t))

     

       12
       22
        
                 | _ -> ()

     

       13
       13
       -
               ) msg.content

     

       14
       14
       -
           | Claude.Types.Result msg ->

     

       15
       15
       -
               if msg.is_error then

     

       16
       16
       -
                 traceln "Error from %s!" name

     

       23
       23
       +
               ) (Claude.Message.Assistant.content msg);

     

       24
       24
       +
               Log.debug (fun m -> m "%s using model: %s" name 

     

       25
       25
       +
                 (Claude.Message.Assistant.model msg))

     

       26
       26
       +
           | Claude.Message.Result msg ->

     

       27
       27
       +
               if Claude.Message.Result.is_error msg then

     

       28
       28
       +
                 Log.err (fun m -> m "Error from %s!" name)

     

       17
       29
        
               else

     

       18
       18
       -
                 (match msg.total_cost_usd with

     

       19
       19
       -
                 | Some cost -> traceln "%s's joke cost: $%.6f" name cost

     

       20
       20
       -
                 | None -> ())

     

       21
       21
       -
           | _ -> ()

     

       30
       30
       +
                 (match Claude.Message.Result.total_cost_usd msg with

     

       31
       31
       +
                 | Some cost -> 

     

       32
       32
       +
                     Log.info (fun m -> m "%s's joke cost: $%.6f" name cost)

     

       33
       33
       +
                 | None -> ());

     

       34
       34
       +
               Log.debug (fun m -> m "%s session: %s, duration: %dms" 

     

       35
       35
       +
                 name 

     

       36
       36
       +
                 (Claude.Message.Result.session_id msg)

     

       37
       37
       +
                 (Claude.Message.Result.duration_ms msg))

     

       38
       38
       +
           | Claude.Message.System msg ->

     

       39
       39
       +
               Log.debug (fun m -> m "System message (%s): %a" 

     

       40
       40
       +
                 (Claude.Message.System.subtype msg)

     

       41
       41
       +
                 Claude.Message.System.pp msg)

     

       42
       42
       +
           | Claude.Message.User msg ->

     

       43
       43
       +
               Log.debug (fun m -> m "User message: %a" 

     

       44
       44
       +
                 Claude.Message.User.pp msg)

     

       22
       45
        
         ) messages

     

       23
       46
        
       

     

       24
       47
        
       let run_claude ~sw ~env name prompt =

     

       25
       25
       -
         traceln "Starting %s..." name;

     

       26
       26
       -
         let options = Claude.Options.{

     

       27
       27
       -
           default with

     

       28
       28
       -
           model = Some "claude-3-5-sonnet-20241022";

     

       29
       29
       -
           (* Allow Claude to be creative *)

     

       30
       30
       -
           allowed_tools = [];

     

       31
       31
       -
         } in

     

       48
       48
       +
         Log.info (fun m -> m "Starting %s..." name);

     

       49
       49
       +
         let options = Claude.Options.create ~model:"sonnet" ~allowed_tools:[] () in

     

       50
       50
       +
         

     

       51
       51
       +
         Claude.Options.log_options options;

     

       32
       52
        
         

     

       33
       53
        
         let client = Claude.Client.create ~options ~sw 

     

       34
       54
        
           ~process_mgr:env#process_mgr 

     

       35
       35
       -
           ~fs:env#fs 

     

       36
       55
        
           () in

     

       37
       56
        
         

     

       57
       57
       +
         Log.debug (fun m -> m "Sending prompt to %s: %s" name prompt);

     

       38
       58
        
         Claude.Client.query client prompt;

     

       39
       59
        
         process_claude_response client name

     

       40
       60
        
       

     

       41
       61
        
       let main ~env =

     

       42
       62
        
         Switch.run @@ fun sw ->

     

       43
       63
        
         

     

       44
       44
       -
         traceln "🐪 Starting the Great Camel Joke Competition! 🐪";

     

       45
       45
       -
         traceln "================================================\n";

     

       64
       64
       +
         Log.app (fun m -> m "🐪 Starting the Great Camel Joke Competition! 🐪");

     

       65
       65
       +
         Log.app (fun m -> m "================================================\n");

     

       46
       66
        
         

     

       47
       67
        
         let prompts = [

     

       48
       68
        
           "Claude 1", "Tell me a short, funny joke about camels! Make it original and clever.";

     
···

       57
       77
        
           ) prompts

     

       58
       78
        
         );

     

       59
       79
        
         

     

       60
       60
       -
         traceln "\n================================================";

     

       61
       61
       -
         traceln "🎉 The Camel Joke Competition is complete! 🎉"

     

       80
       80
       +
         Log.app (fun m -> m "\n================================================");

     

       81
       81
       +
         Log.app (fun m -> m "🎉 The Camel Joke Competition is complete! 🎉")

     

       82
       82
       +
       

     

       83
       83
       +
       (* Command-line interface *)

     

       84
       84
       +
       open Cmdliner

     

       85
       85
       +
       

     

       86
       86
       +
       let main_term env =

     

       87
       87
       +
         let setup_log style_renderer level =

     

       88
       88
       +
           Fmt_tty.setup_std_outputs ?style_renderer ();

     

       89
       89
       +
           Logs.set_level level;

     

       90
       90
       +
           Logs.set_reporter (Logs_fmt.reporter ());

     

       91
       91
       +
           (* Set default to App level if not specified *)

     

       92
       92
       +
           if level = None then Logs.set_level (Some Logs.App);

     

       93
       93
       +
           (* Enable debug for Client module if in debug mode *)

     

       94
       94
       +
           if level = Some Logs.Debug then

     

       95
       95
       +
             Logs.Src.set_level Claude.Client.src (Some Logs.Debug)

     

       96
       96
       +
         in

     

       97
       97
       +
         let run style level =

     

       98
       98
       +
           setup_log style level;

     

       99
       99
       +
           main ~env

     

       100
       100
       +
         in

     

       101
       101
       +
         Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())

     

       102
       102
       +
       

     

       103
       103
       +
       let cmd env =

     

       104
       104
       +
         let doc = "Run the Great Camel Joke Competition using Claude" in

     

       105
       105
       +
         let man = [

     

       106
       106
       +
           `S Manpage.s_description;

     

       107
       107
       +
           `P "This program runs three concurrent Claude instances to generate camel jokes.";

     

       108
       108
       +
           `P "Use $(b,-v) or $(b,--verbosity=info) to see RPC message traffic.";

     

       109
       109
       +
           `P "Use $(b,-vv) or $(b,--verbosity=debug) to see all internal operations.";

     

       110
       110
       +
           `S Manpage.s_examples;

     

       111
       111
       +
           `P "Run with normal output:";

     

       112
       112
       +
           `Pre "  $(mname)";

     

       113
       113
       +
           `P "Run with info-level logging (RPC traffic):";

     

       114
       114
       +
           `Pre "  $(mname) -v";

     

       115
       115
       +
           `Pre "  $(mname) --verbosity=info";

     

       116
       116
       +
           `P "Run with debug logging (all operations):";

     

       117
       117
       +
           `Pre "  $(mname) -vv";

     

       118
       118
       +
           `Pre "  $(mname) --verbosity=debug";

     

       119
       119
       +
           `P "Enable debug for specific modules:";

     

       120
       120
       +
           `Pre "  LOGS='claude.transport=debug' $(mname)";

     

       121
       121
       +
           `Pre "  LOGS='claude.message=info,camel_jokes=debug' $(mname)";

     

       122
       122
       +
           `S Manpage.s_bugs;

     

       123
       123
       +
           `P "Report bugs at https://github.com/your-repo/issues";

     

       124
       124
       +
         ] in

     

       125
       125
       +
         let info = Cmd.info "camel_jokes" ~version:"1.0" ~doc ~man in

     

       126
       126
       +
         Cmd.v info (main_term env)

     

       62
       127
        
       

     

       63
       128
        
       let () =

     

       64
       129
        
         Eio_main.run @@ fun env ->

     

       65
       65
       -
         main ~env
     

       130
       130
       +
         exit (Cmd.eval (cmd env))

+1 -1

claudeio/test/dune

···

       1
       1
        
       (executable

     

       2
       2
        
        (public_name camel_jokes)

     

       3
       3
        
        (name camel_jokes)

     

       4
       4
       -
        (libraries claude eio_main))
     

       4
       4
       +
        (libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))