comparing ddc4ab35059425a33ac52874c74cc718f43b0cd9 and jsont on anil.recoil.org/slop

claudeio/claude.opam

···

       10
       10
        
         "fmt"

     

       11
       11
        
         "logs"

     

       12
       12
        
         "ezjsonm"

     

       13
       13
       +
         "jsont" {>= "0.2.0"}

     

       13
       14
        
         "alcotest" {with-test}

     

       14
       15
        
         "odoc" {with-doc}

     

       15
       16
        
       ]

claudeio/dune-project

···

       13
       13
        
         fmt

     

       14
       14
        
         logs

     

       15
       15
        
         ezjsonm

     

       16
       16
       +
         (jsont (>= 0.2.0))

     

       16
       17
        
         (alcotest :with-test)))

claudeio/lib/claude.ml

···

       1
       1
       +
       module Model = Model

     

       1
       2
        
       module Content_block = Content_block

     

       2
       3
        
       module Message = Message

     

       3
       4
        
       module Control = Control

     

       4
       5
        
       module Permissions = Permissions

     

       5
       6
        
       module Hooks = Hooks

     

       7
       7
       +
       module Sdk_control = Sdk_control

     

       8
       8
       +
       module Structured_output = Structured_output

     

       6
       9
        
       module Options = Options

     

       7
       10
        
       module Transport = Transport

     

       8
       11
        
       module Client = Client

claudeio/lib/claude.mli

···

       153
       153
        
       module Options = Options

     

       154
       154
        
       (** Configuration options for Claude sessions. *)

     

       155
       155
        
       

     

       156
       156
       +
       module Model = Model

     

       157
       157
       +
       (** Claude AI model identifiers with type-safe variants. *)

     

       158
       158
       +
       

     

       156
       159
        
       module Content_block = Content_block

     

       157
       160
        
       (** Content blocks for messages (text, tool use, tool results, thinking). *)

     

       158
       161
        
       

     
···

       167
       170
        
       

     

       168
       171
        
       module Hooks = Hooks

     

       169
       172
        
       (** Hooks system for event interception. *)

     

       173
       173
       +
       

     

       174
       174
       +
       module Sdk_control = Sdk_control

     

       175
       175
       +
       (** SDK control protocol for dynamic configuration. *)

     

       176
       176
       +
       

     

       177
       177
       +
       module Structured_output = Structured_output

     

       178
       178
       +
       (** Structured output support using JSON Schema. *)

     

       170
       179
        
       

     

       171
       180
        
       module Transport = Transport

     

       172
       181
        
       (** Low-level transport layer for CLI communication. *)

+80 -1

claudeio/lib/client.ml

···

       8
       8
        
         hook_callbacks : (string, Hooks.callback) Hashtbl.t;

     

       9
       9
        
         mutable next_callback_id : int;

     

       10
       10
        
         mutable session_id : string option;

     

       11
       11
       +
         control_responses : (string, Ezjsonm.value) Hashtbl.t;

     

       12
       12
       +
         control_mutex : Eio.Mutex.t;

     

       13
       13
       +
         control_condition : Eio.Condition.t;

     

       11
       14
        
       }

     

       12
       15
        
       

     

       13
       16
        
       let handle_control_request t control_msg =

     
···

       166
       169
        
                       (* Handle control responses (e.g., initialize response) *)

     

       167
       170
        
                       let request_id = Json_utils.find_string json ["response"; "request_id"] in

     

       168
       171
        
                       Log.debug (fun m -> m "Received control response for request_id: %s" request_id);

     

       169
       169
       -
                       (* Don't yield control responses as messages, just loop *)

     

       172
       172
       +
                       (* Store the response and signal waiting threads *)

     

       173
       173
       +
                       Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->

     

       174
       174
       +
                         Hashtbl.replace t.control_responses request_id json;

     

       175
       175
       +
                         Eio.Condition.broadcast t.control_condition

     

       176
       176
       +
                       );

     

       170
       177
        
                       loop ()

     

       171
       178
        
       

     

       172
       179
        
                   | _ ->

     
···

       217
       224
        
           hook_callbacks;

     

       218
       225
        
           next_callback_id = 0;

     

       219
       226
        
           session_id = None;

     

       227
       227
       +
           control_responses = Hashtbl.create 16;

     

       228
       228
       +
           control_mutex = Eio.Mutex.create ();

     

       229
       229
       +
           control_condition = Eio.Condition.create ();

     

       220
       230
        
         } in

     

       221
       231
        
       

     

       222
       232
        
         (* Register hooks and send initialize if hooks are configured *)

     
···

       310
       320
        
       

     

       311
       321
        
       let with_permission_callback t callback =

     

       312
       322
        
         { t with permission_callback = Some callback }

     

       323
       323
       +
       

     

       324
       324
       +
       (* Helper to send a control request and wait for response *)

     

       325
       325
       +
       let send_control_request t ~request_id request =

     

       326
       326
       +
         let open Ezjsonm in

     

       327
       327
       +
         (* Send the control request *)

     

       328
       328
       +
         let control_msg = Sdk_control.create_request ~request_id ~request in

     

       329
       329
       +
         let json = Sdk_control.to_json control_msg in

     

       330
       330
       +
         Log.info (fun m -> m "Sending control request: %s" (value_to_string json));

     

       331
       331
       +
         Transport.send t.transport json;

     

       332
       332
       +
       

     

       333
       333
       +
         (* Wait for the response with timeout *)

     

       334
       334
       +
         let max_wait = 10.0 in (* 10 seconds timeout *)

     

       335
       335
       +
         let start_time = Unix.gettimeofday () in

     

       336
       336
       +
       

     

       337
       337
       +
         let rec wait_for_response () =

     

       338
       338
       +
           Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->

     

       339
       339
       +
             match Hashtbl.find_opt t.control_responses request_id with

     

       340
       340
       +
             | Some response_json ->

     

       341
       341
       +
                 (* Remove it from the table *)

     

       342
       342
       +
                 Hashtbl.remove t.control_responses request_id;

     

       343
       343
       +
                 response_json

     

       344
       344
       +
             | None ->

     

       345
       345
       +
                 let elapsed = Unix.gettimeofday () -. start_time in

     

       346
       346
       +
                 if elapsed > max_wait then

     

       347
       347
       +
                   raise (Failure (Printf.sprintf "Timeout waiting for control response: %s" request_id))

     

       348
       348
       +
                 else (

     

       349
       349
       +
                   (* Release mutex and wait for signal *)

     

       350
       350
       +
                   Eio.Condition.await_no_mutex t.control_condition;

     

       351
       351
       +
                   wait_for_response ()

     

       352
       352
       +
                 )

     

       353
       353
       +
           )

     

       354
       354
       +
         in

     

       355
       355
       +
       

     

       356
       356
       +
         let response_json = wait_for_response () in

     

       357
       357
       +
         Log.debug (fun m -> m "Received control response: %s" (value_to_string response_json));

     

       358
       358
       +
       

     

       359
       359
       +
         (* Parse the response *)

     

       360
       360
       +
         let response = find response_json ["response"] |> Sdk_control.Response.of_json in

     

       361
       361
       +
         match response with

     

       362
       362
       +
         | Sdk_control.Response.Success s -> s.response

     

       363
       363
       +
         | Sdk_control.Response.Error e ->

     

       364
       364
       +
             raise (Failure (Printf.sprintf "Control request failed: %s" e.error))

     

       365
       365
       +
       

     

       366
       366
       +
       let set_permission_mode t mode =

     

       367
       367
       +
         let request_id = Printf.sprintf "set_perm_mode_%f" (Unix.gettimeofday ()) in

     

       368
       368
       +
         let request = Sdk_control.Request.set_permission_mode ~mode in

     

       369
       369
       +
         let _response = send_control_request t ~request_id request in

     

       370
       370
       +
         Log.info (fun m -> m "Permission mode set to: %a" Permissions.Mode.pp mode)

     

       371
       371
       +
       

     

       372
       372
       +
       let set_model t model =

     

       373
       373
       +
         let model_str = Model.to_string model in

     

       374
       374
       +
         let request_id = Printf.sprintf "set_model_%f" (Unix.gettimeofday ()) in

     

       375
       375
       +
         let request = Sdk_control.Request.set_model ~model:model_str in

     

       376
       376
       +
         let _response = send_control_request t ~request_id request in

     

       377
       377
       +
         Log.info (fun m -> m "Model set to: %a" Model.pp model)

     

       378
       378
       +
       

     

       379
       379
       +
       let set_model_string t model_str =

     

       380
       380
       +
         set_model t (Model.of_string model_str)

     

       381
       381
       +
       

     

       382
       382
       +
       let get_server_info t =

     

       383
       383
       +
         let request_id = Printf.sprintf "get_server_info_%f" (Unix.gettimeofday ()) in

     

       384
       384
       +
         let request = Sdk_control.Request.get_server_info () in

     

       385
       385
       +
         match send_control_request t ~request_id request with

     

       386
       386
       +
         | Some response_data ->

     

       387
       387
       +
             let server_info = Sdk_control.Server_info.of_json response_data in

     

       388
       388
       +
             Log.info (fun m -> m "Retrieved server info: %a" Sdk_control.Server_info.pp server_info);

     

       389
       389
       +
             server_info

     

       390
       390
       +
         | None ->

     

       391
       391
       +
             raise (Failure "No response data from get_server_info request")

+193 -3

claudeio/lib/client.mli

···

       1
       1
       +
       (** Client interface for interacting with Claude.

     

       2
       2
       +
       

     

       3
       3
       +
           This module provides the high-level client API for sending messages to

     

       4
       4
       +
           Claude and receiving responses. It handles the bidirectional streaming

     

       5
       5
       +
           protocol, permission callbacks, and hooks.

     

       6
       6
       +
       

     

       7
       7
       +
           {2 Basic Usage}

     

       8
       8
       +
       

     

       9
       9
       +
           {[

     

       10
       10
       +
             Eio.Switch.run @@ fun sw ->

     

       11
       11
       +
               let client = Client.create ~sw ~process_mgr () in

     

       12
       12
       +
               Client.query client "What is 2+2?";

     

       13
       13
       +
       

     

       14
       14
       +
               let messages = Client.receive_all client in

     

       15
       15
       +
               List.iter (function

     

       16
       16
       +
                 | Message.Assistant msg ->

     

       17
       17
       +
                     Printf.printf "Claude: %s\n" (Message.Assistant.text msg)

     

       18
       18
       +
                 | _ -> ()

     

       19
       19
       +
               ) messages

     

       20
       20
       +
           ]}

     

       21
       21
       +
       

     

       22
       22
       +
           {2 Features}

     

       23
       23
       +
       

     

       24
       24
       +
           - {b Message Streaming}: Messages are streamed lazily via {!Seq.t}

     

       25
       25
       +
           - {b Permission Control}: Custom permission callbacks for tool usage

     

       26
       26
       +
           - {b Hooks}: Intercept and modify tool execution

     

       27
       27
       +
           - {b Dynamic Control}: Change settings mid-conversation

     

       28
       28
       +
           - {b Resource Management}: Automatic cleanup via Eio switches

     

       29
       29
       +
       

     

       30
       30
       +
           {2 Message Flow}

     

       31
       31
       +
       

     

       32
       32
       +
           1. Create a client with {!create}

     

       33
       33
       +
           2. Send messages with {!query} or {!send_message}

     

       34
       34
       +
           3. Receive responses with {!receive} or {!receive_all}

     

       35
       35
       +
           4. Continue multi-turn conversations by sending more messages

     

       36
       36
       +
           5. Client automatically cleans up when the switch exits

     

       37
       37
       +
       

     

       38
       38
       +
           {2 Advanced Features}

     

       39
       39
       +
       

     

       40
       40
       +
           - Permission discovery mode for understanding required permissions

     

       41
       41
       +
           - Mid-conversation model switching and permission mode changes

     

       42
       42
       +
           - Server capability introspection *)

     

       43
       43
       +
       

     

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

     

       2
       45
        
       val src : Logs.Src.t

     

       3
       46
        
       

     

       4
       47
        
       type t

     

       48
       48
       +
       (** The type of Claude clients. *)

     

       5
       49
        
       

     

       6
       6
       -
       val create : 

     

       7
       7
       -
         ?options:Options.t -> 

     

       8
       8
       -
         sw:Eio.Switch.t -> 

     

       50
       50
       +
       val create :

     

       51
       51
       +
         ?options:Options.t ->

     

       52
       52
       +
         sw:Eio.Switch.t ->

     

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

     

       10
       54
        
         unit -> t

     

       55
       55
       +
       (** [create ?options ~sw ~process_mgr ()] creates a new Claude client.

     

       56
       56
       +
       

     

       57
       57
       +
           @param options Configuration options (defaults to {!Options.default})

     

       58
       58
       +
           @param sw Eio switch for resource management

     

       59
       59
       +
           @param process_mgr Eio process manager for spawning the Claude CLI *)

     

       11
       60
        
       

     

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

     

       62
       62
       +
       (** [query t prompt] sends a text message to Claude.

     

       63
       63
       +
       

     

       64
       64
       +
           This is a convenience function for simple string messages. For more

     

       65
       65
       +
           complex messages with tool results or multiple content blocks, use

     

       66
       66
       +
           {!send_message} instead. *)

     

       67
       67
       +
       

     

       13
       68
        
       val send_message : t -> Message.t -> unit

     

       69
       69
       +
       (** [send_message t msg] sends a message to Claude.

     

       70
       70
       +
       

     

       71
       71
       +
           Supports all message types including user messages with tool results. *)

     

       72
       72
       +
       

     

       14
       73
        
       val send_user_message : t -> Message.User.t -> unit

     

       74
       74
       +
       (** [send_user_message t msg] sends a user message to Claude. *)

     

       15
       75
        
       

     

       16
       76
        
       val receive : t -> Message.t Seq.t

     

       77
       77
       +
       (** [receive t] returns a lazy sequence of messages from Claude.

     

       78
       78
       +
       

     

       79
       79
       +
           The sequence yields messages as they arrive from Claude, including:

     

       80
       80
       +
           - {!Message.Assistant} - Claude's responses

     

       81
       81
       +
           - {!Message.System} - System notifications

     

       82
       82
       +
           - {!Message.Result} - Final result with usage statistics

     

       83
       83
       +
       

     

       84
       84
       +
           Control messages (permission requests, hook callbacks) are handled

     

       85
       85
       +
           internally and not yielded to the sequence. *)

     

       86
       86
       +
       

     

       17
       87
        
       val receive_all : t -> Message.t list

     

       88
       88
       +
       (** [receive_all t] collects all messages into a list.

     

       89
       89
       +
       

     

       90
       90
       +
           This is a convenience function that consumes the {!receive} sequence.

     

       91
       91
       +
           Use this when you want to process all messages at once rather than

     

       92
       92
       +
           streaming them. *)

     

       18
       93
        
       

     

       19
       94
        
       val interrupt : t -> unit

     

       95
       95
       +
       (** [interrupt t] sends an interrupt signal to stop Claude's execution. *)

     

       20
       96
        
       

     

       21
       97
        
       val discover_permissions : t -> t

     

       98
       98
       +
       (** [discover_permissions t] enables permission discovery mode.

     

       99
       99
       +
       

     

       100
       100
       +
           In discovery mode, all tool usage is logged but allowed. Use

     

       101
       101
       +
           {!get_discovered_permissions} to retrieve the list of permissions

     

       102
       102
       +
           that were requested during execution.

     

       103
       103
       +
       

     

       104
       104
       +
           This is useful for understanding what permissions your prompt requires. *)

     

       105
       105
       +
       

     

       22
       106
        
       val get_discovered_permissions : t -> Permissions.Rule.t list

     

       107
       107
       +
       (** [get_discovered_permissions t] returns permissions discovered during execution.

     

       108
       108
       +
       

     

       109
       109
       +
           Only useful after enabling {!discover_permissions}. *)

     

       110
       110
       +
       

     

       23
       111
        
       val with_permission_callback : t -> Permissions.callback -> t

     

       112
       112
       +
       (** [with_permission_callback t callback] updates the permission callback.

     

       113
       113
       +
       

     

       114
       114
       +
           Allows dynamically changing the permission callback without recreating

     

       115
       115
       +
           the client. *)

     

       116
       116
       +
       

     

       117
       117
       +
       (** {1 Dynamic Control Methods}

     

       118
       118
       +
       

     

       119
       119
       +
           These methods allow you to change Claude's behavior mid-conversation

     

       120
       120
       +
           without recreating the client. This is useful for:

     

       121
       121
       +
       

     

       122
       122
       +
           - Adjusting permission strictness based on user feedback

     

       123
       123
       +
           - Switching to faster/cheaper models for simple tasks

     

       124
       124
       +
           - Adapting to changing requirements during long conversations

     

       125
       125
       +
           - Introspecting server capabilities

     

       126
       126
       +
       

     

       127
       127
       +
           {2 Example: Adaptive Permission Control}

     

       128
       128
       +
       

     

       129
       129
       +
           {[

     

       130
       130
       +
             (* Start with strict permissions *)

     

       131
       131
       +
             let client = Client.create ~sw ~process_mgr

     

       132
       132
       +
               ~options:(Options.default

     

       133
       133
       +
                         |> Options.with_permission_mode Permissions.Mode.Default) ()

     

       134
       134
       +
             in

     

       135
       135
       +
       

     

       136
       136
       +
             Client.query client "Analyze this code";

     

       137
       137
       +
             let _ = Client.receive_all client in

     

       138
       138
       +
       

     

       139
       139
       +
             (* User approves, switch to auto-accept edits *)

     

       140
       140
       +
             Client.set_permission_mode client Permissions.Mode.Accept_edits;

     

       141
       141
       +
       

     

       142
       142
       +
             Client.query client "Now refactor it";

     

       143
       143
       +
             let _ = Client.receive_all client in

     

       144
       144
       +
           ]}

     

       145
       145
       +
       

     

       146
       146
       +
           {2 Example: Model Switching for Efficiency}

     

       147
       147
       +
       

     

       148
       148
       +
           {[

     

       149
       149
       +
             (* Use powerful model for complex analysis *)

     

       150
       150
       +
             let client = Client.create ~sw ~process_mgr

     

       151
       151
       +
               ~options:(Options.default |> Options.with_model "claude-sonnet-4-5") ()

     

       152
       152
       +
             in

     

       153
       153
       +
       

     

       154
       154
       +
             Client.query client "Design a new architecture for this system";

     

       155
       155
       +
             let _ = Client.receive_all client in

     

       156
       156
       +
       

     

       157
       157
       +
             (* Switch to faster model for simple tasks *)

     

       158
       158
       +
             Client.set_model client "claude-haiku-4";

     

       159
       159
       +
       

     

       160
       160
       +
             Client.query client "Now write a README";

     

       161
       161
       +
             let _ = Client.receive_all client in

     

       162
       162
       +
           ]}

     

       163
       163
       +
       

     

       164
       164
       +
           {2 Example: Server Introspection}

     

       165
       165
       +
       

     

       166
       166
       +
           {[

     

       167
       167
       +
             let info = Client.get_server_info client in

     

       168
       168
       +
             Printf.printf "Claude CLI version: %s\n"

     

       169
       169
       +
               (Sdk_control.Server_info.version info);

     

       170
       170
       +
             Printf.printf "Capabilities: %s\n"

     

       171
       171
       +
               (String.concat ", " (Sdk_control.Server_info.capabilities info));

     

       172
       172
       +
           ]} *)

     

       173
       173
       +
       

     

       174
       174
       +
       val set_permission_mode : t -> Permissions.Mode.t -> unit

     

       175
       175
       +
       (** [set_permission_mode t mode] changes the permission mode mid-conversation.

     

       176
       176
       +
       

     

       177
       177
       +
           This allows switching between permission modes without recreating the client:

     

       178
       178
       +
           - {!Permissions.Mode.Default} - Prompt for all permissions

     

       179
       179
       +
           - {!Permissions.Mode.Accept_edits} - Auto-accept file edits

     

       180
       180
       +
           - {!Permissions.Mode.Plan} - Planning mode with restricted execution

     

       181
       181
       +
           - {!Permissions.Mode.Bypass_permissions} - Skip all permission checks

     

       182
       182
       +
       

     

       183
       183
       +
           @raise Failure if the server returns an error *)

     

       184
       184
       +
       

     

       185
       185
       +
       val set_model : t -> Model.t -> unit

     

       186
       186
       +
       (** [set_model t model] switches to a different AI model mid-conversation.

     

       187
       187
       +
       

     

       188
       188
       +
           Common models:

     

       189
       189
       +
           - [`Sonnet_4_5] - Most capable, balanced performance

     

       190
       190
       +
           - [`Opus_4] - Maximum capability for complex tasks

     

       191
       191
       +
           - [`Haiku_4] - Fast and cost-effective

     

       192
       192
       +
       

     

       193
       193
       +
           @raise Failure if the model is invalid or unavailable *)

     

       194
       194
       +
       

     

       195
       195
       +
       val set_model_string : t -> string -> unit

     

       196
       196
       +
       (** [set_model_string t model] switches to a different AI model using a string.

     

       197
       197
       +
       

     

       198
       198
       +
           This is a convenience function that parses the string using {!Model.of_string}.

     

       199
       199
       +
       

     

       200
       200
       +
           @raise Failure if the model is invalid or unavailable *)

     

       201
       201
       +
       

     

       202
       202
       +
       val get_server_info : t -> Sdk_control.Server_info.t

     

       203
       203
       +
       (** [get_server_info t] retrieves server capabilities and metadata.

     

       204
       204
       +
       

     

       205
       205
       +
           Returns information about:

     

       206
       206
       +
           - Server version string

     

       207
       207
       +
           - Available capabilities

     

       208
       208
       +
           - Supported commands

     

       209
       209
       +
           - Available output styles

     

       210
       210
       +
       

     

       211
       211
       +
           Useful for feature detection and debugging.

     

       212
       212
       +
       

     

       213
       213
       +
           @raise Failure if the server returns an error *)

+1 -1

claudeio/lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (public_name claude)

     

       3
       3
        
        (name claude)

     

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

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

+65 -21

claudeio/lib/message.ml

···

       98
       98
        
       end

     

       99
       99
        
       

     

       100
       100
        
       module Assistant = struct

     

       101
       101
       +
         type error = [

     

       102
       102
       +
           | `Authentication_failed

     

       103
       103
       +
           | `Billing_error

     

       104
       104
       +
           | `Rate_limit

     

       105
       105
       +
           | `Invalid_request

     

       106
       106
       +
           | `Server_error

     

       107
       107
       +
           | `Unknown

     

       108
       108
       +
         ]

     

       109
       109
       +
       

     

       110
       110
       +
         let error_to_string = function

     

       111
       111
       +
           | `Authentication_failed -> "authentication_failed"

     

       112
       112
       +
           | `Billing_error -> "billing_error"

     

       113
       113
       +
           | `Rate_limit -> "rate_limit"

     

       114
       114
       +
           | `Invalid_request -> "invalid_request"

     

       115
       115
       +
           | `Server_error -> "server_error"

     

       116
       116
       +
           | `Unknown -> "unknown"

     

       117
       117
       +
       

     

       118
       118
       +
         let error_of_string = function

     

       119
       119
       +
           | "authentication_failed" -> `Authentication_failed

     

       120
       120
       +
           | "billing_error" -> `Billing_error

     

       121
       121
       +
           | "rate_limit" -> `Rate_limit

     

       122
       122
       +
           | "invalid_request" -> `Invalid_request

     

       123
       123
       +
           | "server_error" -> `Server_error

     

       124
       124
       +
           | "unknown" | _ -> `Unknown

     

       125
       125
       +
       

     

       101
       126
        
         type t = {

     

       102
       127
        
           content : Content_block.t list;

     

       103
       128
        
           model : string;

     

       129
       129
       +
           error : error option;

     

       104
       130
        
         }

     

       105
       105
       -
         

     

       106
       106
       -
         let create ~content ~model = { content; model }

     

       131
       131
       +
       

     

       132
       132
       +
         let create ~content ~model ?error () = { content; model; error }

     

       107
       133
        
         let content t = t.content

     

       108
       134
        
         let model t = t.model

     

       135
       135
       +
         let error t = t.error

     

       109
       136
        
         

     

       110
       137
        
         let get_text_blocks t =

     

       111
       138
        
           List.filter_map (function

     
···

       135
       162
        
           String.concat "\n" (get_text_blocks t)

     

       136
       163
        
         

     

       137
       164
        
         let to_json t =

     

       165
       165
       +
           let msg_fields = [

     

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

     

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

     

       168
       168
       +
           ] in

     

       169
       169
       +
           let msg_fields = match t.error with

     

       170
       170
       +
             | Some err -> ("error", `String (error_to_string err)) :: msg_fields

     

       171
       171
       +
             | None -> msg_fields

     

       172
       172
       +
           in

     

       138
       173
        
           `O [

     

       139
       174
        
             ("type", `String "assistant");

     

       140
       140
       -
             ("message", `O [

     

       141
       141
       -
               ("content", `A (List.map Content_block.to_json t.content));

     

       142
       142
       -
               ("model", `String t.model);

     

       143
       143
       -
             ]);

     

       175
       175
       +
             ("message", `O msg_fields);

     

       144
       176
        
           ]

     

       145
       177
        
         

     

       146
       178
        
         let of_json = function

     

       147
       179
        
           | `O fields ->

     

       148
       180
        
               let message = List.assoc "message" fields in

     

       149
       149
       -
               let content, model = match message with

     

       181
       181
       +
               let content, model, error = match message with

     

       150
       182
        
                 | `O msg_fields ->

     

       151
       151
       -
                     let content = 

     

       183
       183
       +
                     let content =

     

       152
       184
        
                       match List.assoc "content" msg_fields with

     

       153
       185
        
                       | `A blocks -> List.map Content_block.of_json blocks

     

       154
       186
        
                       | _ -> raise (Invalid_argument "Assistant.of_json: invalid content")

     

       155
       187
        
                     in

     

       156
       188
        
                     let model = JU.assoc_string "model" msg_fields in

     

       157
       157
       -
                     content, model

     

       189
       189
       +
                     let error =

     

       190
       190
       +
                       match JU.assoc_string_opt "error" msg_fields with

     

       191
       191
       +
                       | Some err_str -> Some (error_of_string err_str)

     

       192
       192
       +
                       | None -> None

     

       193
       193
       +
                     in

     

       194
       194
       +
                     content, model, error

     

       158
       195
        
                 | _ -> raise (Invalid_argument "Assistant.of_json: invalid message")

     

       159
       196
        
               in

     

       160
       160
       -
               { content; model }

     

       197
       197
       +
               { content; model; error }

     

       161
       198
        
           | _ -> raise (Invalid_argument "Assistant.of_json: expected object")

     

       162
       199
        
         

     

       163
       200
        
         let pp fmt t =

     
···

       341
       378
        
           total_cost_usd : float option;

     

       342
       379
        
           usage : Usage.t option;

     

       343
       380
        
           result : string option;

     

       381
       381
       +
           structured_output : value option;

     

       344
       382
        
         }

     

       345
       383
        
         

     

       346
       346
       -
         let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       347
       347
       -
             ~session_id ?total_cost_usd ?usage ?result () =

     

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

     

       385
       385
       +
             ~session_id ?total_cost_usd ?usage ?result ?structured_output () =

     

       348
       386
        
           { subtype; duration_ms; duration_api_ms; is_error; num_turns;

     

       349
       349
       -
             session_id; total_cost_usd; usage; result }

     

       387
       387
       +
             session_id; total_cost_usd; usage; result; structured_output }

     

       350
       388
        
         

     

       351
       389
        
         let subtype t = t.subtype

     

       352
       390
        
         let duration_ms t = t.duration_ms

     
···

       357
       395
        
         let total_cost_usd t = t.total_cost_usd

     

       358
       396
        
         let usage t = t.usage

     

       359
       397
        
         let result t = t.result

     

       398
       398
       +
         let structured_output t = t.structured_output

     

       360
       399
        
         

     

       361
       400
        
         let to_json t =

     

       362
       401
        
           let fields = [

     
···

       380
       419
        
             | Some result -> ("result", `String result) :: fields

     

       381
       420
        
             | None -> fields

     

       382
       421
        
           in

     

       422
       422
       +
           let fields = match t.structured_output with

     

       423
       423
       +
             | Some output -> ("structured_output", output) :: fields

     

       424
       424
       +
             | None -> fields

     

       425
       425
       +
           in

     

       383
       426
        
           `O fields

     

       384
       427
        
         

     

       385
       428
        
         let of_json = function

     
···

       393
       436
        
               let total_cost_usd = JU.assoc_float_opt "total_cost_usd" fields in

     

       394
       437
        
               let usage = Option.map Usage.of_json (List.assoc_opt "usage" fields) in

     

       395
       438
        
               let result = JU.assoc_string_opt "result" fields in

     

       439
       439
       +
               let structured_output = List.assoc_opt "structured_output" fields in

     

       396
       440
        
               { subtype; duration_ms; duration_api_ms; is_error; num_turns;

     

       397
       397
       -
                 session_id; total_cost_usd; usage; result }

     

       441
       441
       +
                 session_id; total_cost_usd; usage; result; structured_output }

     

       398
       442
        
           | _ -> raise (Invalid_argument "Result.of_json: expected object")

     

       399
       443
        
         

     

       400
       444
        
         let pp fmt t =

     
···

       434
       478
        
       let user_with_tool_result ~tool_use_id ~content ?is_error () =

     

       435
       479
        
         User (User.create_with_tool_result ~tool_use_id ~content ?is_error ())

     

       436
       480
        
       

     

       437
       437
       -
       let assistant ~content ~model = Assistant (Assistant.create ~content ~model)

     

       438
       438
       -
       let assistant_text ~text ~model = 

     

       439
       439
       -
         Assistant (Assistant.create ~content:[Content_block.text text] ~model)

     

       481
       481
       +
       let assistant ~content ~model ?error () = Assistant (Assistant.create ~content ~model ?error ())

     

       482
       482
       +
       let assistant_text ~text ~model ?error () =

     

       483
       483
       +
         Assistant (Assistant.create ~content:[Content_block.text text] ~model ?error ())

     

       440
       484
        
       

     

       441
       485
        
       let system ~subtype ~data = System (System.create ~subtype ~data)

     

       442
       486
        
       let system_init ~session_id =

     
···

       446
       490
        
         let data = System.Data.of_assoc [("error", `String error)] in

     

       447
       491
        
         System (System.create ~subtype:"error" ~data)

     

       448
       492
        
       

     

       449
       449
       -
       let result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       450
       450
       -
           ~session_id ?total_cost_usd ?usage ?result () =

     

       451
       451
       -
         Result (Result.create ~subtype ~duration_ms ~duration_api_ms ~is_error 

     

       452
       452
       -
           ~num_turns ~session_id ?total_cost_usd ?usage ?result ())

     

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

     

       494
       494
       +
           ~session_id ?total_cost_usd ?usage ?result ?structured_output () =

     

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

     

       496
       496
       +
           ~num_turns ~session_id ?total_cost_usd ?usage ?result ?structured_output ())

     

       453
       497
        
       

     

       454
       498
        
       let to_json = function

     

       455
       499
        
         | User t -> User.to_json t

+59 -33

claudeio/lib/message.mli

···

       62
       62
        
       

     

       63
       63
        
       module Assistant : sig

     

       64
       64
        
         (** Messages from Claude assistant. *)

     

       65
       65
       -
         

     

       65
       65
       +
       

     

       66
       66
       +
         type error = [

     

       67
       67
       +
           | `Authentication_failed  (** Authentication with Claude API failed *)

     

       68
       68
       +
           | `Billing_error         (** Billing or account issue *)

     

       69
       69
       +
           | `Rate_limit            (** Rate limit exceeded *)

     

       70
       70
       +
           | `Invalid_request       (** Request was invalid *)

     

       71
       71
       +
           | `Server_error          (** Internal server error *)

     

       72
       72
       +
           | `Unknown               (** Unknown error type *)

     

       73
       73
       +
         ]

     

       74
       74
       +
         (** The type of assistant message errors based on Python SDK error types. *)

     

       75
       75
       +
       

     

       76
       76
       +
         val error_to_string : error -> string

     

       77
       77
       +
         (** [error_to_string err] converts an error to its string representation. *)

     

       78
       78
       +
       

     

       79
       79
       +
         val error_of_string : string -> error

     

       80
       80
       +
         (** [error_of_string s] parses an error string. Unknown strings become [`Unknown]. *)

     

       81
       81
       +
       

     

       66
       82
        
         type t

     

       67
       83
        
         (** The type of assistant messages. *)

     

       68
       68
       -
         

     

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

     

       70
       70
       -
         (** [create ~content ~model] creates an assistant message.

     

       84
       84
       +
       

     

       85
       85
       +
         val create : content:Content_block.t list -> model:string -> ?error:error -> unit -> t

     

       86
       86
       +
         (** [create ~content ~model ?error ()] creates an assistant message.

     

       71
       87
        
             @param content List of content blocks in the response

     

       72
       72
       -
             @param model The model identifier used for the response *)

     

       73
       73
       -
         

     

       88
       88
       +
             @param model The model identifier used for the response

     

       89
       89
       +
             @param error Optional error that occurred during message generation *)

     

       90
       90
       +
       

     

       74
       91
        
         val content : t -> Content_block.t list

     

       75
       92
        
         (** [content t] returns the content blocks of the assistant message. *)

     

       76
       76
       -
         

     

       93
       93
       +
       

     

       77
       94
        
         val model : t -> string

     

       78
       95
        
         (** [model t] returns the model identifier. *)

     

       96
       96
       +
       

     

       97
       97
       +
         val error : t -> error option

     

       98
       98
       +
         (** [error t] returns the optional error that occurred during message generation. *)

     

       79
       99
        
         

     

       80
       100
        
         val get_text_blocks : t -> string list

     

       81
       101
        
         (** [get_text_blocks t] extracts all text content from the message. *)

     
···

       230
       250
        
         type t

     

       231
       251
        
         (** The type of result messages. *)

     

       232
       252
        
         

     

       233
       233
       -
         val create : 

     

       234
       234
       -
           subtype:string -> 

     

       235
       235
       -
           duration_ms:int -> 

     

       236
       236
       -
           duration_api_ms:int -> 

     

       237
       237
       -
           is_error:bool -> 

     

       238
       238
       -
           num_turns:int -> 

     

       239
       239
       -
           session_id:string -> 

     

       240
       240
       -
           ?total_cost_usd:float -> 

     

       241
       241
       -
           ?usage:Usage.t -> 

     

       242
       242
       -
           ?result:string -> 

     

       253
       253
       +
         val create :

     

       254
       254
       +
           subtype:string ->

     

       255
       255
       +
           duration_ms:int ->

     

       256
       256
       +
           duration_api_ms:int ->

     

       257
       257
       +
           is_error:bool ->

     

       258
       258
       +
           num_turns:int ->

     

       259
       259
       +
           session_id:string ->

     

       260
       260
       +
           ?total_cost_usd:float ->

     

       261
       261
       +
           ?usage:Usage.t ->

     

       262
       262
       +
           ?result:string ->

     

       263
       263
       +
           ?structured_output:Ezjsonm.value ->

     

       243
       264
        
           unit -> t

     

       244
       265
        
         (** [create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       245
       266
        
             ~session_id ?total_cost_usd ?usage ?result ()] creates a result message.

     
···

       251
       272
        
             @param session_id Unique session identifier

     

       252
       273
        
             @param total_cost_usd Optional total cost in USD

     

       253
       274
        
             @param usage Optional usage statistics as JSON

     

       254
       254
       -
             @param result Optional result string *)

     

       275
       275
       +
             @param result Optional result string

     

       276
       276
       +
             @param structured_output Optional structured JSON output from Claude *)

     

       255
       277
        
         

     

       256
       278
        
         val subtype : t -> string

     

       257
       279
        
         (** [subtype t] returns the subtype of the result. *)

     
···

       279
       301
        
         

     

       280
       302
        
         val result : t -> string option

     

       281
       303
        
         (** [result t] returns the optional result string. *)

     

       282
       282
       -
         

     

       304
       304
       +
       

     

       305
       305
       +
         val structured_output : t -> Ezjsonm.value option

     

       306
       306
       +
         (** [structured_output t] returns the optional structured JSON output. *)

     

       307
       307
       +
       

     

       283
       308
        
         val to_json : t -> Ezjsonm.value

     

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

     

       285
       310
        
         

     
···

       310
       335
        
       (** [user_with_tool_result ~tool_use_id ~content ?is_error ()] creates a user message 

     

       311
       336
        
           containing a tool result. *)

     

       312
       337
        
       

     

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

     

       314
       314
       -
       (** [assistant ~content ~model] creates an assistant message. *)

     

       338
       338
       +
       val assistant : content:Content_block.t list -> model:string -> ?error:Assistant.error -> unit -> t

     

       339
       339
       +
       (** [assistant ~content ~model ?error ()] creates an assistant message. *)

     

       315
       340
        
       

     

       316
       316
       -
       val assistant_text : text:string -> model:string -> t

     

       317
       317
       -
       (** [assistant_text ~text ~model] creates an assistant message with only text content. *)

     

       341
       341
       +
       val assistant_text : text:string -> model:string -> ?error:Assistant.error -> unit -> t

     

       342
       342
       +
       (** [assistant_text ~text ~model ?error ()] creates an assistant message with only text content. *)

     

       318
       343
        
       

     

       319
       344
        
       val system : subtype:string -> data:System.Data.t -> t

     

       320
       345
        
       (** [system ~subtype ~data] creates a system message. *)

     
···

       325
       350
        
       val system_error : error:string -> t

     

       326
       351
        
       (** [system_error ~error] creates a system error message. *)

     

       327
       352
        
       

     

       328
       328
       -
       val result : 

     

       329
       329
       -
         subtype:string -> 

     

       330
       330
       -
         duration_ms:int -> 

     

       331
       331
       -
         duration_api_ms:int -> 

     

       332
       332
       -
         is_error:bool -> 

     

       333
       333
       -
         num_turns:int -> 

     

       334
       334
       -
         session_id:string -> 

     

       335
       335
       -
         ?total_cost_usd:float -> 

     

       336
       336
       -
         ?usage:Result.Usage.t -> 

     

       337
       337
       -
         ?result:string -> 

     

       353
       353
       +
       val result :

     

       354
       354
       +
         subtype:string ->

     

       355
       355
       +
         duration_ms:int ->

     

       356
       356
       +
         duration_api_ms:int ->

     

       357
       357
       +
         is_error:bool ->

     

       358
       358
       +
         num_turns:int ->

     

       359
       359
       +
         session_id:string ->

     

       360
       360
       +
         ?total_cost_usd:float ->

     

       361
       361
       +
         ?usage:Result.Usage.t ->

     

       362
       362
       +
         ?result:string ->

     

       363
       363
       +
         ?structured_output:Ezjsonm.value ->

     

       338
       364
        
         unit -> t

     

       339
       365
        
       (** [result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns 

     

       340
       366
        
           ~session_id ?total_cost_usd ?usage ?result ()] creates a result message. *)

+50 -7

claudeio/lib/options.ml

···

       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
        
       

     

       6
       6
       +
       type setting_source = User | Project | Local

     

       7
       7
       +
       

     

       6
       8
        
       type t = {

     

       7
       9
        
         allowed_tools : string list;

     

       8
       10
        
         disallowed_tools : string list;

     
···

       11
       13
        
         append_system_prompt : string option;

     

       12
       14
        
         permission_mode : Permissions.Mode.t option;

     

       13
       15
        
         permission_callback : Permissions.callback option;

     

       14
       14
       -
         model : string option;

     

       16
       16
       +
         model : Model.t option;

     

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

     

       16
       18
        
         env : (string * string) list;

     

       17
       19
        
         continue_conversation : bool;

     
···

       23
       25
        
         extra_args : (string * string option) list;

     

       24
       26
        
         debug_stderr : Eio.Flow.sink_ty Eio.Flow.sink option;

     

       25
       27
        
         hooks : Hooks.config option;

     

       28
       28
       +
         max_budget_usd : float option;

     

       29
       29
       +
         fallback_model : Model.t option;

     

       30
       30
       +
         setting_sources : setting_source list option;

     

       31
       31
       +
         max_buffer_size : int option;

     

       32
       32
       +
         user : string option;

     

       33
       33
       +
         output_format : Structured_output.t option;

     

       26
       34
        
       }

     

       27
       35
        
       

     

       28
       36
        
       let default = {

     
···

       45
       53
        
         extra_args = [];

     

       46
       54
        
         debug_stderr = None;

     

       47
       55
        
         hooks = None;

     

       56
       56
       +
         max_budget_usd = None;

     

       57
       57
       +
         fallback_model = None;

     

       58
       58
       +
         setting_sources = None;

     

       59
       59
       +
         max_buffer_size = None;

     

       60
       60
       +
         user = None;

     

       61
       61
       +
         output_format = None;

     

       48
       62
        
       }

     

       49
       63
        
       

     

       50
       64
        
       let create

     
···

       67
       81
        
           ?(extra_args = [])

     

       68
       82
        
           ?debug_stderr

     

       69
       83
        
           ?hooks

     

       84
       84
       +
           ?max_budget_usd

     

       85
       85
       +
           ?fallback_model

     

       86
       86
       +
           ?setting_sources

     

       87
       87
       +
           ?max_buffer_size

     

       88
       88
       +
           ?user

     

       89
       89
       +
           ?output_format

     

       70
       90
        
           () =

     

       71
       91
        
         { allowed_tools; disallowed_tools; max_thinking_tokens;

     

       72
       92
        
           system_prompt; append_system_prompt; permission_mode;

     

       73
       93
        
           permission_callback; model; cwd; env;

     

       74
       94
        
           continue_conversation; resume; max_turns;

     

       75
       95
        
           permission_prompt_tool_name; settings; add_dirs;

     

       76
       76
       -
           extra_args; debug_stderr; hooks }

     

       96
       96
       +
           extra_args; debug_stderr; hooks;

     

       97
       97
       +
           max_budget_usd; fallback_model; setting_sources;

     

       98
       98
       +
           max_buffer_size; user; output_format }

     

       77
       99
        
       

     

       78
       100
        
       let allowed_tools t = t.allowed_tools

     

       79
       101
        
       let disallowed_tools t = t.disallowed_tools

     
···

       94
       116
        
       let extra_args t = t.extra_args

     

       95
       117
        
       let debug_stderr t = t.debug_stderr

     

       96
       118
        
       let hooks t = t.hooks

     

       119
       119
       +
       let max_budget_usd t = t.max_budget_usd

     

       120
       120
       +
       let fallback_model t = t.fallback_model

     

       121
       121
       +
       let setting_sources t = t.setting_sources

     

       122
       122
       +
       let max_buffer_size t = t.max_buffer_size

     

       123
       123
       +
       let user t = t.user

     

       124
       124
       +
       let output_format t = t.output_format

     

       97
       125
        
       

     

       98
       126
        
       let with_allowed_tools tools t = { t with allowed_tools = tools }

     

       99
       127
        
       let with_disallowed_tools tools t = { t with disallowed_tools = tools }

     
···

       103
       131
        
       let with_permission_mode mode t = { t with permission_mode = Some mode }

     

       104
       132
        
       let with_permission_callback callback t = { t with permission_callback = Some callback }

     

       105
       133
        
       let with_model model t = { t with model = Some model }

     

       134
       134
       +
       let with_model_string model t = { t with model = Some (Model.of_string model) }

     

       106
       135
        
       let with_cwd cwd t = { t with cwd = Some cwd }

     

       107
       136
        
       let with_env env t = { t with env }

     

       108
       137
        
       let with_continue_conversation continue t = { t with continue_conversation = continue }

     
···

       114
       143
        
       let with_extra_args args t = { t with extra_args = args }

     

       115
       144
        
       let with_debug_stderr sink t = { t with debug_stderr = Some sink }

     

       116
       145
        
       let with_hooks hooks t = { t with hooks = Some hooks }

     

       146
       146
       +
       let with_max_budget_usd budget t = { t with max_budget_usd = Some budget }

     

       147
       147
       +
       let with_fallback_model model t = { t with fallback_model = Some model }

     

       148
       148
       +
       let with_fallback_model_string model t = { t with fallback_model = Some (Model.of_string model) }

     

       149
       149
       +
       let with_setting_sources sources t = { t with setting_sources = Some sources }

     

       150
       150
       +
       let with_no_settings t = { t with setting_sources = Some [] }

     

       151
       151
       +
       let with_max_buffer_size size t = { t with max_buffer_size = Some size }

     

       152
       152
       +
       let with_user user t = { t with user = Some user }

     

       153
       153
       +
       let with_output_format format t = { t with output_format = Some format }

     

       117
       154
        
       

     

       118
       155
        
       let to_json t =

     

       119
       156
        
         let fields = [] in

     
···

       145
       182
        
           | None -> fields

     

       146
       183
        
         in

     

       147
       184
        
         let fields = match t.model with

     

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

     

       185
       185
       +
           | Some m -> ("model", `String (Model.to_string m)) :: fields

     

       149
       186
        
           | None -> fields

     

       150
       187
        
         in

     

       151
       188
        
         let fields = 

     
···

       182
       219
        
               try Some (Permissions.Mode.of_json (List.assoc "permission_mode" fields))

     

       183
       220
        
               with Not_found -> None

     

       184
       221
        
             in

     

       185
       185
       -
             let model = 

     

       186
       186
       -
               try Some (get_string (List.assoc "model" fields))

     

       222
       222
       +
             let model =

     

       223
       223
       +
               try Some (Model.of_string (get_string (List.assoc "model" fields)))

     

       187
       224
        
               with Not_found -> None

     

       188
       225
        
             in

     

       189
       226
        
             let env = 

     
···

       205
       242
        
               add_dirs = [];

     

       206
       243
        
               extra_args = [];

     

       207
       244
        
               debug_stderr = None;

     

       208
       208
       -
               hooks = None; }

     

       245
       245
       +
               hooks = None;

     

       246
       246
       +
               max_budget_usd = None;

     

       247
       247
       +
               fallback_model = None;

     

       248
       248
       +
               setting_sources = None;

     

       249
       249
       +
               max_buffer_size = None;

     

       250
       250
       +
               user = None;

     

       251
       251
       +
               output_format = None; }

     

       209
       252
        
         | _ -> raise (Invalid_argument "Options.of_json: expected object")

     

       210
       253
        
       

     

       211
       254
        
       let pp fmt t =

     
···

       225
       268
        
           Fmt.(option string) t.system_prompt

     

       226
       269
        
           Fmt.(option string) t.append_system_prompt

     

       227
       270
        
           Fmt.(option Permissions.Mode.pp) t.permission_mode

     

       228
       228
       -
           Fmt.(option string) t.model

     

       271
       271
       +
           Fmt.(option Model.pp) t.model

     

       229
       272
        
           Fmt.(list (pair string string)) t.env

     

       230
       273
        
       

     

       231
       274
        
       let log_options t =

+177 -10

claudeio/lib/options.mli

···

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

     

       2
       2
       +
       

     

       3
       3
       +
           This module provides comprehensive configuration options for controlling

     

       4
       4
       +
           Claude's behavior, including tool permissions, system prompts, models,

     

       5
       5
       +
           execution environment, cost controls, and structured outputs.

     

       6
       6
       +
       

     

       7
       7
       +
           {2 Overview}

     

       8
       8
       +
       

     

       9
       9
       +
           Options control all aspects of Claude's behavior:

     

       10
       10
       +
           - {b Permissions}: Which tools Claude can use and how permission is granted

     

       11
       11
       +
           - {b Models}: Which AI model to use and fallback options

     

       12
       12
       +
           - {b Environment}: Working directory, environment variables, settings

     

       13
       13
       +
           - {b Cost Control}: Budget limits to prevent runaway spending

     

       14
       14
       +
           - {b Hooks}: Intercept and modify tool execution

     

       15
       15
       +
           - {b Structured Output}: JSON schema validation for responses

     

       16
       16
       +
           - {b Session Management}: Continue or resume conversations

     

       17
       17
       +
       

     

       18
       18
       +
           {2 Builder Pattern}

     

       19
       19
       +
       

     

       20
       20
       +
           Options use a functional builder pattern - each [with_*] function returns

     

       21
       21
       +
           a new options value with the specified field updated:

     

       22
       22
       +
       

     

       23
       23
       +
           {[

     

       24
       24
       +
             let options = Options.default

     

       25
       25
       +
               |> Options.with_model "claude-sonnet-4-5"

     

       26
       26
       +
               |> Options.with_max_budget_usd 1.0

     

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

     

       28
       28
       +
           ]}

     

       29
       29
       +
       

     

       30
       30
       +
           {2 Common Configuration Scenarios}

     

       31
       31
       +
       

     

       32
       32
       +
           {3 CI/CD: Isolated, Reproducible Builds}

     

       33
       33
       +
       

     

       34
       34
       +
           {[

     

       35
       35
       +
             let ci_config = Options.default

     

       36
       36
       +
               |> Options.with_no_settings           (* Ignore user config *)

     

       37
       37
       +
               |> Options.with_max_budget_usd 0.50   (* 50 cent limit *)

     

       38
       38
       +
               |> Options.with_permission_mode

     

       39
       39
       +
                    Permissions.Mode.Bypass_permissions

     

       40
       40
       +
               |> Options.with_model "claude-haiku-4"

     

       41
       41
       +
           ]}

     

       42
       42
       +
       

     

       43
       43
       +
           {3 Production: Cost Control with Fallback}

     

       44
       44
       +
       

     

       45
       45
       +
           {[

     

       46
       46
       +
             let prod_config = Options.default

     

       47
       47
       +
               |> Options.with_model "claude-sonnet-4-5"

     

       48
       48
       +
               |> Options.with_fallback_model "claude-haiku-4"

     

       49
       49
       +
               |> Options.with_max_budget_usd 10.0   (* $10 daily limit *)

     

       50
       50
       +
               |> Options.with_max_buffer_size 5_000_000

     

       51
       51
       +
           ]}

     

       52
       52
       +
       

     

       53
       53
       +
           {3 Development: User Settings with Overrides}

     

       54
       54
       +
       

     

       55
       55
       +
           {[

     

       56
       56
       +
             let dev_config = Options.default

     

       57
       57
       +
               |> Options.with_setting_sources [User; Project]

     

       58
       58
       +
               |> Options.with_max_budget_usd 1.0

     

       59
       59
       +
               |> Options.with_permission_mode Permissions.Mode.Default

     

       60
       60
       +
           ]}

     

       61
       61
       +
       

     

       62
       62
       +
           {3 Structured Output: Type-Safe Responses}

     

       63
       63
       +
       

     

       64
       64
       +
           {[

     

       65
       65
       +
             let schema = Ezjsonm.(`O [

     

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

     

       67
       67
       +
               ("properties", `O [

     

       68
       68
       +
                 ("count", `O [("type", `String "integer")]);

     

       69
       69
       +
                 ("has_tests", `O [("type", `String "boolean")]);

     

       70
       70
       +
               ]);

     

       71
       71
       +
             ])

     

       72
       72
       +
             let format = Structured_output.of_json_schema schema

     

       73
       73
       +
       

     

       74
       74
       +
             let analysis_config = Options.default

     

       75
       75
       +
               |> Options.with_output_format format

     

       76
       76
       +
               |> Options.with_allowed_tools ["Read"; "Glob"; "Grep"]

     

       77
       77
       +
           ]}

     

       78
       78
       +
       

     

       79
       79
       +
           {2 Advanced Options}

     

       80
       80
       +
       

     

       81
       81
       +
           {3 Budget Control}

     

       82
       82
       +
       

     

       83
       83
       +
           Use {!with_max_budget_usd} to set hard spending limits. Claude will

     

       84
       84
       +
           terminate the session if the budget is exceeded, preventing runaway costs.

     

       85
       85
       +
       

     

       86
       86
       +
           {3 Settings Isolation}

     

       87
       87
       +
       

     

       88
       88
       +
           Use {!with_setting_sources} or {!with_no_settings} to control which

     

       89
       89
       +
           configuration files are loaded:

     

       90
       90
       +
           - [User] - ~/.claude/config

     

       91
       91
       +
           - [Project] - .claude/ in project root

     

       92
       92
       +
           - [Local] - Current directory settings

     

       93
       93
       +
           - [Some \[\]] (via {!with_no_settings}) - No settings, fully isolated

     

       94
       94
       +
       

     

       95
       95
       +
           This is critical for reproducible builds in CI/CD environments.

     

       96
       96
       +
       

     

       97
       97
       +
           {3 Model Fallback}

     

       98
       98
       +
       

     

       99
       99
       +
           Use {!with_fallback_model} to specify an alternative model when the

     

       100
       100
       +
           primary model is unavailable or overloaded. This improves reliability. *)

     

       6
       101
        
       

     

       7
       102
        
       open Ezjsonm

     

       8
       103
        
       

     

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

     

       10
       105
        
       val src : Logs.Src.t

     

       11
       106
        
       

     

       107
       107
       +
       (** {1 Types} *)

     

       108
       108
       +
       

     

       109
       109
       +
       type setting_source = User | Project | Local

     

       110
       110
       +
       (** Setting source determines which configuration files to load.

     

       111
       111
       +
           - [User]: Load user-level settings from ~/.claude/config

     

       112
       112
       +
           - [Project]: Load project-level settings from .claude/ in project root

     

       113
       113
       +
           - [Local]: Load local settings from current directory *)

     

       114
       114
       +
       

     

       12
       115
        
       type t

     

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

     

       14
       117
        
       

     
···

       27
       130
        
         ?append_system_prompt:string ->

     

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

     

       29
       132
        
         ?permission_callback:Permissions.callback ->

     

       30
       30
       -
         ?model:string ->

     

       133
       133
       +
         ?model:Model.t ->

     

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

     

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

     

       33
       136
        
         ?continue_conversation:bool ->

     
···

       39
       142
        
         ?extra_args:(string * string option) list ->

     

       40
       143
        
         ?debug_stderr:Eio.Flow.sink_ty Eio.Flow.sink ->

     

       41
       144
        
         ?hooks:Hooks.config ->

     

       145
       145
       +
         ?max_budget_usd:float ->

     

       146
       146
       +
         ?fallback_model:Model.t ->

     

       147
       147
       +
         ?setting_sources:setting_source list ->

     

       148
       148
       +
         ?max_buffer_size:int ->

     

       149
       149
       +
         ?user:string ->

     

       150
       150
       +
         ?output_format:Structured_output.t ->

     

       42
       151
        
         unit -> t

     

       43
       152
        
       (** [create ?allowed_tools ?disallowed_tools ?max_thinking_tokens ?system_prompt

     

       44
       153
        
           ?append_system_prompt ?permission_mode ?permission_callback ?model ?cwd ?env

     

       45
       154
        
           ?continue_conversation ?resume ?max_turns ?permission_prompt_tool_name ?settings

     

       46
       46
       -
           ?add_dirs ?extra_args ?debug_stderr ()]

     

       155
       155
       +
           ?add_dirs ?extra_args ?debug_stderr ?hooks ?max_budget_usd ?fallback_model

     

       156
       156
       +
           ?setting_sources ?max_buffer_size ?user ()]

     

       47
       157
        
           creates a new configuration.

     

       48
       158
        
           @param allowed_tools List of explicitly allowed tool names

     

       49
       159
        
           @param disallowed_tools List of explicitly disallowed tool names

     
···

       62
       172
        
           @param settings Path to settings file

     

       63
       173
        
           @param add_dirs Additional directories to allow access to

     

       64
       174
        
           @param extra_args Additional CLI flags to pass through

     

       65
       65
       -
           @param debug_stderr Sink for debug output when debug-to-stderr is set *)

     

       175
       175
       +
           @param debug_stderr Sink for debug output when debug-to-stderr is set

     

       176
       176
       +
           @param hooks Hooks configuration for event interception

     

       177
       177
       +
           @param max_budget_usd Hard spending limit in USD (terminates on exceed)

     

       178
       178
       +
           @param fallback_model Automatic fallback on primary model unavailability

     

       179
       179
       +
           @param setting_sources Control which settings load (user/project/local)

     

       180
       180
       +
           @param max_buffer_size Control for stdout buffer size in bytes

     

       181
       181
       +
           @param user Unix user for subprocess execution

     

       182
       182
       +
           @param output_format Optional structured output format specification *)

     

       66
       183
        
       

     

       67
       184
        
       (** {1 Accessors} *)

     

       68
       185
        
       

     
···

       87
       204
        
       val permission_callback : t -> Permissions.callback option

     

       88
       205
        
       (** [permission_callback t] returns the optional permission callback. *)

     

       89
       206
        
       

     

       90
       90
       -
       val model : t -> string option

     

       207
       207
       +
       val model : t -> Model.t option

     

       91
       208
        
       (** [model t] returns the optional model override. *)

     

       92
       209
        
       

     

       93
       210
        
       val cwd : t -> Eio.Fs.dir_ty Eio.Path.t option

     
···

       123
       240
        
       val hooks : t -> Hooks.config option

     

       124
       241
        
       (** [hooks t] returns the optional hooks configuration. *)

     

       125
       242
        
       

     

       243
       243
       +
       val max_budget_usd : t -> float option

     

       244
       244
       +
       (** [max_budget_usd t] returns the optional spending limit in USD. *)

     

       245
       245
       +
       

     

       246
       246
       +
       val fallback_model : t -> Model.t option

     

       247
       247
       +
       (** [fallback_model t] returns the optional fallback model. *)

     

       248
       248
       +
       

     

       249
       249
       +
       val setting_sources : t -> setting_source list option

     

       250
       250
       +
       (** [setting_sources t] returns the optional list of setting sources to load. *)

     

       251
       251
       +
       

     

       252
       252
       +
       val max_buffer_size : t -> int option

     

       253
       253
       +
       (** [max_buffer_size t] returns the optional stdout buffer size in bytes. *)

     

       254
       254
       +
       

     

       255
       255
       +
       val user : t -> string option

     

       256
       256
       +
       (** [user t] returns the optional Unix user for subprocess execution. *)

     

       257
       257
       +
       

     

       258
       258
       +
       val output_format : t -> Structured_output.t option

     

       259
       259
       +
       (** [output_format t] returns the optional structured output format. *)

     

       260
       260
       +
       

     

       126
       261
        
       (** {1 Builders} *)

     

       127
       262
        
       

     

       128
       263
        
       val with_allowed_tools : string list -> t -> t

     
···

       146
       281
        
       val with_permission_callback : Permissions.callback -> t -> t

     

       147
       282
        
       (** [with_permission_callback callback t] sets the permission callback. *)

     

       148
       283
        
       

     

       149
       149
       -
       val with_model : string -> t -> t

     

       150
       150
       -
       (** [with_model model t] sets the model override. *)

     

       284
       284
       +
       val with_model : Model.t -> t -> t

     

       285
       285
       +
       (** [with_model model t] sets the model override using a typed Model.t. *)

     

       286
       286
       +
       

     

       287
       287
       +
       val with_model_string : string -> t -> t

     

       288
       288
       +
       (** [with_model_string model t] sets the model override from a string.

     

       289
       289
       +
           The string is parsed using {!Model.of_string}. *)

     

       151
       290
        
       

     

       152
       291
        
       val with_cwd : Eio.Fs.dir_ty Eio.Path.t -> t -> t

     

       153
       292
        
       (** [with_cwd cwd t] sets the working directory. *)

     
···

       181
       320
        
       

     

       182
       321
        
       val with_hooks : Hooks.config -> t -> t

     

       183
       322
        
       (** [with_hooks hooks t] sets the hooks configuration. *)

     

       323
       323
       +
       

     

       324
       324
       +
       val with_max_budget_usd : float -> t -> t

     

       325
       325
       +
       (** [with_max_budget_usd budget t] sets the maximum spending limit in USD.

     

       326
       326
       +
           The session will terminate if this limit is exceeded. *)

     

       327
       327
       +
       

     

       328
       328
       +
       val with_fallback_model : Model.t -> t -> t

     

       329
       329
       +
       (** [with_fallback_model model t] sets the fallback model using a typed Model.t. *)

     

       330
       330
       +
       

     

       331
       331
       +
       val with_fallback_model_string : string -> t -> t

     

       332
       332
       +
       (** [with_fallback_model_string model t] sets the fallback model from a string.

     

       333
       333
       +
           The string is parsed using {!Model.of_string}. *)

     

       334
       334
       +
       

     

       335
       335
       +
       val with_setting_sources : setting_source list -> t -> t

     

       336
       336
       +
       (** [with_setting_sources sources t] sets which configuration sources to load.

     

       337
       337
       +
           Use empty list for isolated environments (e.g., CI/CD). *)

     

       338
       338
       +
       

     

       339
       339
       +
       val with_no_settings : t -> t

     

       340
       340
       +
       (** [with_no_settings t] disables all settings loading (user, project, local).

     

       341
       341
       +
           Useful for CI/CD environments where you want isolated, reproducible behavior. *)

     

       342
       342
       +
       

     

       343
       343
       +
       val with_max_buffer_size : int -> t -> t

     

       344
       344
       +
       (** [with_max_buffer_size size t] sets the maximum stdout buffer size in bytes. *)

     

       345
       345
       +
       

     

       346
       346
       +
       val with_user : string -> t -> t

     

       347
       347
       +
       (** [with_user user t] sets the Unix user for subprocess execution. *)

     

       348
       348
       +
       

     

       349
       349
       +
       val with_output_format : Structured_output.t -> t -> t

     

       350
       350
       +
       (** [with_output_format format t] sets the structured output format. *)

     

       184
       351
        
       

     

       185
       352
        
       (** {1 Serialization} *)

     

       186
       353

+91 -4

claudeio/lib/sdk_control.ml

···

       40
       40
        
           server_name : string;

     

       41
       41
        
           message : value;

     

       42
       42
        
         }

     

       43
       43
       -
         

     

       43
       43
       +
       

     

       44
       44
       +
         type set_model = {

     

       45
       45
       +
           subtype : [`Set_model];

     

       46
       46
       +
           model : string;

     

       47
       47
       +
         }

     

       48
       48
       +
       

     

       49
       49
       +
         type get_server_info = {

     

       50
       50
       +
           subtype : [`Get_server_info];

     

       51
       51
       +
         }

     

       52
       52
       +
       

     

       44
       53
        
         type t =

     

       45
       54
        
           | Interrupt of interrupt

     

       46
       55
        
           | Permission of permission

     
···

       48
       57
        
           | Set_permission_mode of set_permission_mode

     

       49
       58
        
           | Hook_callback of hook_callback

     

       50
       59
        
           | Mcp_message of mcp_message

     

       60
       60
       +
           | Set_model of set_model

     

       61
       61
       +
           | Get_server_info of get_server_info

     

       51
       62
        
         

     

       52
       63
        
         let interrupt () = Interrupt { subtype = `Interrupt }

     

       53
       64
        
         

     
···

       80
       91
        
             server_name;

     

       81
       92
        
             message;

     

       82
       93
        
           }

     

       83
       83
       -
         

     

       94
       94
       +
       

     

       95
       95
       +
         let set_model ~model =

     

       96
       96
       +
           Set_model { subtype = `Set_model; model }

     

       97
       97
       +
       

     

       98
       98
       +
         let get_server_info () =

     

       99
       99
       +
           Get_server_info { subtype = `Get_server_info }

     

       100
       100
       +
       

     

       84
       101
        
         let to_json = function

     

       85
       102
        
           | Interrupt _ ->

     

       86
       103
        
               `O [("subtype", `String "interrupt")]

     
···

       131
       148
        
                 ("server_name", `String m.server_name);

     

       132
       149
        
                 ("message", m.message);

     

       133
       150
        
               ]

     

       134
       134
       -
         

     

       151
       151
       +
           | Set_model s ->

     

       152
       152
       +
               `O [

     

       153
       153
       +
                 ("subtype", `String "set_model");

     

       154
       154
       +
                 ("model", `String s.model);

     

       155
       155
       +
               ]

     

       156
       156
       +
           | Get_server_info _ ->

     

       157
       157
       +
               `O [("subtype", `String "get_server_info")]

     

       158
       158
       +
       

     

       135
       159
        
         let of_json = function

     

       136
       160
        
           | `O fields ->

     

       137
       161
        
               let subtype = JU.assoc_string "subtype" fields in

     
···

       183
       207
        
                     server_name;

     

       184
       208
        
                     message;

     

       185
       209
        
                   }

     

       210
       210
       +
               | "set_model" ->

     

       211
       211
       +
                   let model = JU.assoc_string "model" fields in

     

       212
       212
       +
                   Set_model { subtype = `Set_model; model }

     

       213
       213
       +
               | "get_server_info" ->

     

       214
       214
       +
                   Get_server_info { subtype = `Get_server_info }

     

       186
       215
        
               | _ -> raise (Invalid_argument ("Unknown request subtype: " ^ subtype)))

     

       187
       216
        
           | _ -> raise (Invalid_argument "Request.of_json: expected object")

     

       188
       217
        
         

     
···

       204
       233
        
           | Mcp_message m ->

     

       205
       234
        
               Fmt.pf fmt "@[<2>McpMessage@ { server = %S }@]"

     

       206
       235
        
                 m.server_name

     

       236
       236
       +
           | Set_model s ->

     

       237
       237
       +
               Fmt.pf fmt "@[<2>SetModel@ { model = %S }@]" s.model

     

       238
       238
       +
           | Get_server_info _ ->

     

       239
       239
       +
               Fmt.pf fmt "@[<2>GetServerInfo@]"

     

       207
       240
        
       end

     

       208
       241
        
       

     

       209
       242
        
       module Response = struct

     
···

       360
       393
        
         Log.debug (fun m -> m "SDK control request: %a" Request.pp req)

     

       361
       394
        
       

     

       362
       395
        
       let log_response resp =

     

       363
       363
       -
         Log.debug (fun m -> m "SDK control response: %a" Response.pp resp)
     

       396
       396
       +
         Log.debug (fun m -> m "SDK control response: %a" Response.pp resp)

     

       397
       397
       +
       

     

       398
       398
       +
       (** Server information *)

     

       399
       399
       +
       module Server_info = struct

     

       400
       400
       +
         type t = {

     

       401
       401
       +
           version : string;

     

       402
       402
       +
           capabilities : string list;

     

       403
       403
       +
           commands : string list;

     

       404
       404
       +
           output_styles : string list;

     

       405
       405
       +
         }

     

       406
       406
       +
       

     

       407
       407
       +
         let create ~version ~capabilities ~commands ~output_styles =

     

       408
       408
       +
           { version; capabilities; commands; output_styles }

     

       409
       409
       +
       

     

       410
       410
       +
         let version t = t.version

     

       411
       411
       +
         let capabilities t = t.capabilities

     

       412
       412
       +
         let commands t = t.commands

     

       413
       413
       +
         let output_styles t = t.output_styles

     

       414
       414
       +
       

     

       415
       415
       +
         let of_json = function

     

       416
       416
       +
           | `O fields ->

     

       417
       417
       +
               let version = JU.assoc_string "version" fields in

     

       418
       418
       +
               let capabilities =

     

       419
       419
       +
                 match List.assoc_opt "capabilities" fields with

     

       420
       420
       +
                 | Some (`A lst) -> List.map Ezjsonm.get_string lst

     

       421
       421
       +
                 | _ -> []

     

       422
       422
       +
               in

     

       423
       423
       +
               let commands =

     

       424
       424
       +
                 match List.assoc_opt "commands" fields with

     

       425
       425
       +
                 | Some (`A lst) -> List.map Ezjsonm.get_string lst

     

       426
       426
       +
                 | _ -> []

     

       427
       427
       +
               in

     

       428
       428
       +
               let output_styles =

     

       429
       429
       +
                 match List.assoc_opt "outputStyles" fields with

     

       430
       430
       +
                 | Some (`A lst) -> List.map Ezjsonm.get_string lst

     

       431
       431
       +
                 | _ -> []

     

       432
       432
       +
               in

     

       433
       433
       +
               { version; capabilities; commands; output_styles }

     

       434
       434
       +
           | _ -> raise (Invalid_argument "Server_info.of_json: expected object")

     

       435
       435
       +
       

     

       436
       436
       +
         let to_json t =

     

       437
       437
       +
           `O [

     

       438
       438
       +
             ("version", `String t.version);

     

       439
       439
       +
             ("capabilities", `A (List.map (fun s -> `String s) t.capabilities));

     

       440
       440
       +
             ("commands", `A (List.map (fun s -> `String s) t.commands));

     

       441
       441
       +
             ("outputStyles", `A (List.map (fun s -> `String s) t.output_styles));

     

       442
       442
       +
           ]

     

       443
       443
       +
       

     

       444
       444
       +
         let pp fmt t =

     

       445
       445
       +
           Fmt.pf fmt "@[<2>ServerInfo@ { version = %S;@ capabilities = [%a];@ commands = [%a];@ output_styles = [%a] }@]"

     

       446
       446
       +
             t.version

     

       447
       447
       +
             Fmt.(list ~sep:(any ", ") (quote string)) t.capabilities

     

       448
       448
       +
             Fmt.(list ~sep:(any ", ") (quote string)) t.commands

     

       449
       449
       +
             Fmt.(list ~sep:(any ", ") (quote string)) t.output_styles

     

       450
       450
       +
       end

+149 -6

claudeio/lib/sdk_control.mli

···

       1
       1
        
       (** SDK Control Protocol for Claude.

     

       2
       2
       -
           

     

       3
       3
       -
           This module defines the typed SDK control protocol for communication

     

       4
       4
       -
           between the SDK and Claude, including request and response types. *)

     

       2
       2
       +
       

     

       3
       3
       +
           This module defines the typed SDK control protocol for bidirectional

     

       4
       4
       +
           communication between the SDK and the Claude CLI. It handles:

     

       5
       5
       +
       

     

       6
       6
       +
           - Permission requests (tool usage authorization)

     

       7
       7
       +
           - Hook callbacks (intercepting and modifying tool execution)

     

       8
       8
       +
           - Dynamic control (changing settings mid-conversation)

     

       9
       9
       +
           - Server introspection (querying capabilities)

     

       10
       10
       +
       

     

       11
       11
       +
           {2 Protocol Overview}

     

       12
       12
       +
       

     

       13
       13
       +
           The SDK control protocol is a JSON-based request/response protocol that

     

       14
       14
       +
           runs alongside the main message stream. It enables:

     

       15
       15
       +
       

     

       16
       16
       +
           1. {b Callbacks}: Claude asks the SDK for permission or hook execution

     

       17
       17
       +
           2. {b Control}: SDK changes Claude's behavior dynamically

     

       18
       18
       +
           3. {b Introspection}: SDK queries server metadata

     

       19
       19
       +
       

     

       20
       20
       +
           {2 Request/Response Flow}

     

       21
       21
       +
       

     

       22
       22
       +
           {v

     

       23
       23
       +
             SDK                          Claude CLI

     

       24
       24
       +
              |                               |

     

       25
       25
       +
              |-- Initialize (with hooks) --> |

     

       26
       26
       +
              |<-- Permission Request --------|  (for tool usage)

     

       27
       27
       +
              |-- Allow/Deny Response ------> |

     

       28
       28
       +
              |                               |

     

       29
       29
       +
              |<-- Hook Callback -------------|  (pre/post tool)

     

       30
       30
       +
              |-- Hook Result -------------> |

     

       31
       31
       +
              |                               |

     

       32
       32
       +
              |-- Set Model ---------------> |  (dynamic control)

     

       33
       33
       +
              |<-- Success Response ----------|

     

       34
       34
       +
              |                               |

     

       35
       35
       +
              |-- Get Server Info ----------> |

     

       36
       36
       +
              |<-- Server Info Response ------|

     

       37
       37
       +
           v}

     

       38
       38
       +
       

     

       39
       39
       +
           {2 Usage}

     

       40
       40
       +
       

     

       41
       41
       +
           Most users won't interact with this module directly. The {!Client} module

     

       42
       42
       +
           handles the protocol automatically. However, this module is exposed for:

     

       43
       43
       +
       

     

       44
       44
       +
           - Understanding the control protocol

     

       45
       45
       +
           - Implementing custom control logic

     

       46
       46
       +
           - Debugging control message flow

     

       47
       47
       +
           - Advanced SDK extensions

     

       48
       48
       +
       

     

       49
       49
       +
           {2 Dynamic Control Examples}

     

       50
       50
       +
       

     

       51
       51
       +
           See {!Client.set_permission_mode}, {!Client.set_model}, and

     

       52
       52
       +
           {!Client.get_server_info} for high-level APIs that use this protocol. *)

     

       5
       53
        
       

     

       6
       54
        
       open Ezjsonm

     

       7
       55
        
       

     
···

       53
       101
        
           message : value;

     

       54
       102
        
         }

     

       55
       103
        
         (** MCP server message request. *)

     

       56
       56
       -
         

     

       104
       104
       +
       

     

       105
       105
       +
         type set_model = {

     

       106
       106
       +
           subtype : [`Set_model];

     

       107
       107
       +
           model : string;

     

       108
       108
       +
         }

     

       109
       109
       +
         (** Request to change the AI model. *)

     

       110
       110
       +
       

     

       111
       111
       +
         type get_server_info = {

     

       112
       112
       +
           subtype : [`Get_server_info];

     

       113
       113
       +
         }

     

       114
       114
       +
         (** Request to get server information. *)

     

       115
       115
       +
       

     

       57
       116
        
         type t =

     

       58
       117
        
           | Interrupt of interrupt

     

       59
       118
        
           | Permission of permission

     
···

       61
       120
        
           | Set_permission_mode of set_permission_mode

     

       62
       121
        
           | Hook_callback of hook_callback

     

       63
       122
        
           | Mcp_message of mcp_message

     

       123
       123
       +
           | Set_model of set_model

     

       124
       124
       +
           | Get_server_info of get_server_info

     

       64
       125
        
         (** The type of SDK control requests. *)

     

       65
       126
        
         

     

       66
       127
        
         val interrupt : unit -> t

     
···

       90
       151
        
         

     

       91
       152
        
         val mcp_message : server_name:string -> message:value -> t

     

       92
       153
        
         (** [mcp_message ~server_name ~message] creates an MCP message request. *)

     

       93
       93
       -
         

     

       154
       154
       +
       

     

       155
       155
       +
         val set_model : model:string -> t

     

       156
       156
       +
         (** [set_model ~model] creates a model change request. *)

     

       157
       157
       +
       

     

       158
       158
       +
         val get_server_info : unit -> t

     

       159
       159
       +
         (** [get_server_info ()] creates a server info request. *)

     

       160
       160
       +
       

     

       94
       161
        
         val to_json : t -> value

     

       95
       162
        
         (** [to_json t] converts a request to JSON. *)

     

       96
       163
        
         

     
···

       185
       252
        
       (** [log_request req] logs an SDK control request. *)

     

       186
       253
        
       

     

       187
       254
        
       val log_response : Response.t -> unit

     

       188
       188
       -
       (** [log_response resp] logs an SDK control response. *)
     

       255
       255
       +
       (** [log_response resp] logs an SDK control response. *)

     

       256
       256
       +
       

     

       257
       257
       +
       (** {1 Server Information}

     

       258
       258
       +
       

     

       259
       259
       +
           Server information provides metadata about the Claude CLI server,

     

       260
       260
       +
           including version, capabilities, available commands, and output styles.

     

       261
       261
       +
       

     

       262
       262
       +
           {2 Use Cases}

     

       263
       263
       +
       

     

       264
       264
       +
           - Feature detection: Check if specific capabilities are available

     

       265
       265
       +
           - Version compatibility: Ensure minimum version requirements

     

       266
       266
       +
           - Debugging: Log server information for troubleshooting

     

       267
       267
       +
           - Dynamic adaptation: Adjust SDK behavior based on capabilities

     

       268
       268
       +
       

     

       269
       269
       +
           {2 Example}

     

       270
       270
       +
       

     

       271
       271
       +
           {[

     

       272
       272
       +
             let info = Client.get_server_info client in

     

       273
       273
       +
             Printf.printf "Claude CLI version: %s\n"

     

       274
       274
       +
               (Server_info.version info);

     

       275
       275
       +
       

     

       276
       276
       +
             if List.mem "structured-output" (Server_info.capabilities info) then

     

       277
       277
       +
               Printf.printf "Structured output is supported\n"

     

       278
       278
       +
             else

     

       279
       279
       +
               Printf.printf "Structured output not available\n";

     

       280
       280
       +
           ]} *)

     

       281
       281
       +
       

     

       282
       282
       +
       module Server_info : sig

     

       283
       283
       +
         (** Server information and capabilities. *)

     

       284
       284
       +
       

     

       285
       285
       +
         type t = {

     

       286
       286
       +
           version : string;

     

       287
       287
       +
           (** Server version string (e.g., "2.0.0") *)

     

       288
       288
       +
       

     

       289
       289
       +
           capabilities : string list;

     

       290
       290
       +
           (** Available server capabilities (e.g., "hooks", "structured-output") *)

     

       291
       291
       +
       

     

       292
       292
       +
           commands : string list;

     

       293
       293
       +
           (** Available CLI commands *)

     

       294
       294
       +
       

     

       295
       295
       +
           output_styles : string list;

     

       296
       296
       +
           (** Supported output formats (e.g., "json", "stream-json") *)

     

       297
       297
       +
         }

     

       298
       298
       +
         (** Server metadata and capabilities.

     

       299
       299
       +
       

     

       300
       300
       +
             This information is useful for feature detection and debugging. *)

     

       301
       301
       +
       

     

       302
       302
       +
         val create :

     

       303
       303
       +
           version:string ->

     

       304
       304
       +
           capabilities:string list ->

     

       305
       305
       +
           commands:string list ->

     

       306
       306
       +
           output_styles:string list ->

     

       307
       307
       +
           t

     

       308
       308
       +
         (** [create ~version ~capabilities ~commands ~output_styles] creates server info. *)

     

       309
       309
       +
       

     

       310
       310
       +
         val version : t -> string

     

       311
       311
       +
         (** [version t] returns the server version. *)

     

       312
       312
       +
       

     

       313
       313
       +
         val capabilities : t -> string list

     

       314
       314
       +
         (** [capabilities t] returns the server capabilities. *)

     

       315
       315
       +
       

     

       316
       316
       +
         val commands : t -> string list

     

       317
       317
       +
         (** [commands t] returns available commands. *)

     

       318
       318
       +
       

     

       319
       319
       +
         val output_styles : t -> string list

     

       320
       320
       +
         (** [output_styles t] returns available output styles. *)

     

       321
       321
       +
       

     

       322
       322
       +
         val of_json : value -> t

     

       323
       323
       +
         (** [of_json json] parses server info from JSON.

     

       324
       324
       +
             @raise Invalid_argument if the JSON is not valid server info. *)

     

       325
       325
       +
       

     

       326
       326
       +
         val to_json : t -> value

     

       327
       327
       +
         (** [to_json t] converts server info to JSON. *)

     

       328
       328
       +
       

     

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

     

       330
       330
       +
         (** [pp fmt t] pretty-prints the server info. *)

     

       331
       331
       +
       end

+45 -9

claudeio/lib/transport.ml

···

       17
       17
        
         sw : Switch.t;

     

       18
       18
        
       }

     

       19
       19
        
       

     

       20
       20
       +
       let setting_source_to_string = function

     

       21
       21
       +
         | Options.User -> "user"

     

       22
       22
       +
         | Options.Project -> "project"

     

       23
       23
       +
         | Options.Local -> "local"

     

       24
       24
       +
       

     

       20
       25
        
       let build_command ~claude_path ~options =

     

       21
       26
        
         let cmd = [claude_path; "--output-format"; "stream-json"; "--verbose"] in

     

       22
       22
       -
         

     

       27
       27
       +
       

     

       23
       28
        
         let cmd = match Options.system_prompt options with

     

       24
       29
        
           | Some prompt -> cmd @ ["--system-prompt"; prompt]

     

       25
       30
        
           | None -> cmd

     

       26
       31
        
         in

     

       27
       27
       -
         

     

       32
       32
       +
       

     

       28
       33
        
         let cmd = match Options.append_system_prompt options with

     

       29
       34
        
           | Some prompt -> cmd @ ["--append-system-prompt"; prompt]

     

       30
       35
        
           | None -> cmd

     

       31
       36
        
         in

     

       32
       32
       -
         

     

       37
       37
       +
       

     

       33
       38
        
         let cmd = match Options.allowed_tools options with

     

       34
       39
        
           | [] -> cmd

     

       35
       40
        
           | tools -> cmd @ ["--allowedTools"; String.concat "," tools]

     

       36
       41
        
         in

     

       37
       37
       -
         

     

       42
       42
       +
       

     

       38
       43
        
         let cmd = match Options.disallowed_tools options with

     

       39
       44
        
           | [] -> cmd

     

       40
       45
        
           | tools -> cmd @ ["--disallowedTools"; String.concat "," tools]

     

       41
       46
        
         in

     

       42
       42
       -
         

     

       47
       47
       +
       

     

       43
       48
        
         let cmd = match Options.model options with

     

       44
       44
       -
           | Some model -> cmd @ ["--model"; model]

     

       49
       49
       +
           | Some model -> cmd @ ["--model"; Model.to_string model]

     

       45
       50
        
           | None -> cmd

     

       46
       51
        
         in

     

       47
       47
       -
         

     

       52
       52
       +
       

     

       48
       53
        
         let cmd = match Options.permission_mode options with

     

       49
       54
        
           | Some mode ->

     

       50
       55
        
               let mode_str = Permissions.Mode.to_string mode in

     
···

       57
       62
        
           | None -> cmd

     

       58
       63
        
         in

     

       59
       64
        
       

     

       65
       65
       +
         (* Advanced configuration options *)

     

       66
       66
       +
         let cmd = match Options.max_budget_usd options with

     

       67
       67
       +
           | Some budget -> cmd @ ["--max-budget-usd"; Float.to_string budget]

     

       68
       68
       +
           | None -> cmd

     

       69
       69
       +
         in

     

       70
       70
       +
       

     

       71
       71
       +
         let cmd = match Options.fallback_model options with

     

       72
       72
       +
           | Some model -> cmd @ ["--fallback-model"; Model.to_string model]

     

       73
       73
       +
           | None -> cmd

     

       74
       74
       +
         in

     

       75
       75
       +
       

     

       76
       76
       +
         let cmd = match Options.setting_sources options with

     

       77
       77
       +
           | Some sources ->

     

       78
       78
       +
               let sources_str = String.concat "," (List.map setting_source_to_string sources) in

     

       79
       79
       +
               cmd @ ["--setting-sources"; sources_str]

     

       80
       80
       +
           | None -> cmd

     

       81
       81
       +
         in

     

       82
       82
       +
       

     

       83
       83
       +
         (* Add JSON Schema if specified *)

     

       84
       84
       +
         let cmd = match Options.output_format options with

     

       85
       85
       +
           | Some format ->

     

       86
       86
       +
               let schema = Structured_output.json_schema format in

     

       87
       87
       +
               let schema_str = Ezjsonm.value_to_string schema in

     

       88
       88
       +
               cmd @ ["--json-schema"; schema_str]

     

       89
       89
       +
           | None -> cmd

     

       90
       90
       +
         in

     

       91
       91
       +
       

     

       60
       92
        
         (* Use streaming input mode *)

     

       61
       93
        
         cmd @ ["--input-format"; "stream-json"]

     

       62
       94
        
       

     
···

       121
       153
        
         

     

       122
       154
        
         let stdin = (stdin_w :> Eio.Flow.sink_ty r) in

     

       123
       155
        
         let stdin_close = (stdin_w :> [`Close | `Flow] r) in

     

       124
       124
       -
         let stdout = Eio.Buf_read.of_flow ~max_size:1_000_000 (stdout_r :> Eio.Flow.source_ty r) in

     

       125
       125
       -
         

     

       156
       156
       +
         let max_size = match Options.max_buffer_size options with

     

       157
       157
       +
           | Some size -> size

     

       158
       158
       +
           | None -> 1_000_000  (* Default 1MB *)

     

       159
       159
       +
         in

     

       160
       160
       +
         let stdout = Eio.Buf_read.of_flow ~max_size (stdout_r :> Eio.Flow.source_ty r) in

     

       161
       161
       +
       

     

       126
       162
        
         { process = P process; stdin; stdin_close; stdout; sw }

     

       127
       163
        
       

     

       128
       164
        
       let send t json =

+1 -1

claudeio/test/camel_jokes.ml

···

       45
       45
        
       

     

       46
       46
        
       let run_claude ~sw ~env name prompt =

     

       47
       47
        
         Log.info (fun m -> m "🐪 Starting %s..." name);

     

       48
       48
       -
         let options = Claude.Options.create ~model:"sonnet" ~allowed_tools:[] () in

     

       48
       48
       +
         let options = Claude.Options.create ~model:(Claude.Model.of_string "sonnet") ~allowed_tools:[] () in

     

       49
       49
        
         

     

       50
       50
        
         let client = Claude.Client.create ~options ~sw 

     

       51
       51
        
           ~process_mgr:env#process_mgr

+1 -1

claudeio/test/discovery_demo.ml

···

       37
       37
        
         Log.app (fun m -> m "This will discover what permissions Claude needs.\n");

     

       38
       38
        
         

     

       39
       39
        
         (* Create client with discovery mode *)

     

       40
       40
       -
         let options = Claude.Options.create ~model:"sonnet" () in

     

       40
       40
       +
         let options = Claude.Options.create ~model:(Claude.Model.of_string "sonnet") () in

     

       41
       41
        
         let client = Claude.Client.discover_permissions 

     

       42
       42
        
           (Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()) in

     

       43
       43

+27 -1

claudeio/test/dune

···

       38
       38
        
        (public_name hooks_example)

     

       39
       39
        
        (name hooks_example)

     

       40
       40
        
        (modules hooks_example)

     

       41
       41
       -
        (libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
     

       41
       41
       +
        (libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))

     

       42
       42
       +
       

     

       43
       43
       +
       (executable

     

       44
       44
       +
        (public_name dynamic_control_demo)

     

       45
       45
       +
        (name dynamic_control_demo)

     

       46
       46
       +
        (modules dynamic_control_demo)

     

       47
       47
       +
        (libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))

     

       48
       48
       +
       

     

       49
       49
       +
       (executable

     

       50
       50
       +
        (public_name advanced_config_demo)

     

       51
       51
       +
        (name advanced_config_demo)

     

       52
       52
       +
        (modules advanced_config_demo)

     

       53
       53
       +
        (libraries claude eio_main logs logs.fmt fmt.tty))

     

       54
       54
       +
       

     

       55
       55
       +
       (executable

     

       56
       56
       +
        (public_name structured_output_demo)

     

       57
       57
       +
        (name structured_output_demo)

     

       58
       58
       +
        (modules structured_output_demo)

     

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

     

       60
       60
       +
        (libraries claude eio_main logs logs.fmt fmt.tty))

     

       61
       61
       +
       

     

       62
       62
       +
       (executable

     

       63
       63
       +
        (public_name structured_output_simple)

     

       64
       64
       +
        (name structured_output_simple)

     

       65
       65
       +
        (modules structured_output_simple)

     

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

     

       67
       67
       +
        (libraries claude eio_main logs logs.fmt fmt.tty))

+1 -1

claudeio/test/hooks_example.ml

···

       51
       51
        
         in

     

       52
       52
        
       

     

       53
       53
        
         let options = Claude.Options.create

     

       54
       54
       -
           ~model:"sonnet"

     

       54
       54
       +
           ~model:(Claude.Model.of_string "sonnet")

     

       55
       55
        
           ~hooks

     

       56
       56
        
           () in

     

       57
       57

+1 -1

claudeio/test/permission_demo.ml

···

       131
       131
        
         (* DON'T specify allowed_tools - let the permission callback handle everything.

     

       132
       132
        
            The Default permission mode with a callback should send requests for all tools. *)

     

       133
       133
        
         let options = Claude.Options.create 

     

       134
       134
       -
           ~model:"sonnet"

     

       134
       134
       +
           ~model:(Claude.Model.of_string "sonnet")

     

       135
       135
        
           ~permission_mode:Claude.Permissions.Mode.Default

     

       136
       136
        
           ~permission_callback:interactive_permission_callback

     

       137
       137
        
           () in

+1 -1

claudeio/test/simple_permission_test.ml

···

       17
       17
        
       

     

       18
       18
        
         (* Create options with permission callback *)

     

       19
       19
        
         let options = Claude.Options.create

     

       20
       20
       -
           ~model:"sonnet"

     

       20
       20
       +
           ~model:(Claude.Model.of_string "sonnet")

     

       21
       21
        
           ~permission_callback:auto_allow_callback

     

       22
       22
        
           () in

     

       23
       23

+1 -1

claudeio/test/test_permissions.ml

···

       14
       14
        
       

     

       15
       15
        
         (* Create options with custom permission callback *)

     

       16
       16
        
         let options = Claude.Options.create

     

       17
       17
       -
           ~model:"sonnet"

     

       17
       17
       +
           ~model:(Claude.Model.of_string "sonnet")

     

       18
       18
        
           ~permission_callback:auto_allow_callback

     

       19
       19
        
           () in

     

       20
       20

stack/.gitignore

···

       1
       1
       +
       _build

-9

stack/bushel/.gitignore

···

       1
       1
       -
       _build

     

       2
       2
       -
       .*.swp

     

       3
       3
       -
       **/.claude/settings.local.json

     

       4
       4
       -
       .photos-api

     

       5
       5
       -
       .karakeep-api

     

       6
       6
       -
       KARAKEEP.md

     

       7
       7
       -
       karakeep-src

     

       8
       8
       -
       .DS_Store

     

       9
       9
       -
       .openapi-key

-1

stack/bushel/.ocamlformat

···

       1
       1
       -
       profile=janestreet

-127

stack/bushel/bin/bushel_bibtex.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       open Printf

     

       3
       3
       -
       

     

       4
       4
       -
       (** TODO:claude Generate bibtex entry from paper data *)

     

       5
       5
       -
       let generate_bibtex_entry paper =

     

       6
       6
       -
         let open Bushel.Paper in

     

       7
       7
       -
         (* Use slug as the bibtex key/label *)

     

       8
       8
       -
         let bibkey = slug paper in

     

       9
       9
       -
         let bibtype = try bibtype paper with _ -> "misc" in

     

       10
       10
       -
         let title = try title paper with _ -> "Untitled" in

     

       11
       11
       -
         let authors =

     

       12
       12
       -
           let auth_list = try authors paper with _ -> [] in

     

       13
       13
       -
           String.concat " and " auth_list

     

       14
       14
       -
         in

     

       15
       15
       -
         let year = try year paper with _ -> 0 in

     

       16
       16
       -
       

     

       17
       17
       -
         (* Build the bibtex entry *)

     

       18
       18
       -
         let buf = Buffer.create 1024 in

     

       19
       19
       -
         Buffer.add_string buf (sprintf "@%s{%s,\n" bibtype bibkey);

     

       20
       20
       -
         Buffer.add_string buf (sprintf "  title = {%s},\n" title);

     

       21
       21
       -
         Buffer.add_string buf (sprintf "  author = {%s},\n" authors);

     

       22
       22
       -
         Buffer.add_string buf (sprintf "  year = {%d}" year);

     

       23
       23
       -
       

     

       24
       24
       -
         (* Add optional fields *)

     

       25
       25
       -
         (match String.lowercase_ascii bibtype with

     

       26
       26
       -
         | "article" ->

     

       27
       27
       -
           (try

     

       28
       28
       -
             Buffer.add_string buf (sprintf ",\n  journal = {%s}" (journal paper))

     

       29
       29
       -
           with _ -> ());

     

       30
       30
       -
           (match volume paper with

     

       31
       31
       -
           | Some v -> Buffer.add_string buf (sprintf ",\n  volume = {%s}" v)

     

       32
       32
       -
           | None -> ());

     

       33
       33
       -
           (match issue paper with

     

       34
       34
       -
           | Some i -> Buffer.add_string buf (sprintf ",\n  number = {%s}" i)

     

       35
       35
       -
           | None -> ());

     

       36
       36
       -
           (match pages paper with

     

       37
       37
       -
           | "" -> ()

     

       38
       38
       -
           | p -> Buffer.add_string buf (sprintf ",\n  pages = {%s}" p))

     

       39
       39
       -
         | "inproceedings" ->

     

       40
       40
       -
           (try

     

       41
       41
       -
             Buffer.add_string buf (sprintf ",\n  booktitle = {%s}" (booktitle paper))

     

       42
       42
       -
           with _ -> ());

     

       43
       43
       -
           (match pages paper with

     

       44
       44
       -
           | "" -> ()

     

       45
       45
       -
           | p -> Buffer.add_string buf (sprintf ",\n  pages = {%s}" p));

     

       46
       46
       -
           (match publisher paper with

     

       47
       47
       -
           | "" -> ()

     

       48
       48
       -
           | p -> Buffer.add_string buf (sprintf ",\n  publisher = {%s}" p))

     

       49
       49
       -
         | "techreport" ->

     

       50
       50
       -
           (try

     

       51
       51
       -
             Buffer.add_string buf (sprintf ",\n  institution = {%s}" (institution paper))

     

       52
       52
       -
           with _ -> ());

     

       53
       53
       -
           (match number paper with

     

       54
       54
       -
           | Some n -> Buffer.add_string buf (sprintf ",\n  number = {%s}" n)

     

       55
       55
       -
           | None -> ())

     

       56
       56
       -
         | "book" ->

     

       57
       57
       -
           (match publisher paper with

     

       58
       58
       -
           | "" -> ()

     

       59
       59
       -
           | p -> Buffer.add_string buf (sprintf ",\n  publisher = {%s}" p));

     

       60
       60
       -
           (try

     

       61
       61
       -
             Buffer.add_string buf (sprintf ",\n  isbn = {%s}" (isbn paper))

     

       62
       62
       -
           with _ -> ())

     

       63
       63
       -
         | _ -> ());

     

       64
       64
       -
       

     

       65
       65
       -
         (* Add DOI if available *)

     

       66
       66
       -
         (match doi paper with

     

       67
       67
       -
         | Some d -> Buffer.add_string buf (sprintf ",\n  doi = {%s}" d)

     

       68
       68
       -
         | None -> ());

     

       69
       69
       -
       

     

       70
       70
       -
         (* Add URL if available *)

     

       71
       71
       -
         (match url paper with

     

       72
       72
       -
         | Some u -> Buffer.add_string buf (sprintf ",\n  url = {%s}" u)

     

       73
       73
       -
         | None -> ());

     

       74
       74
       -
       

     

       75
       75
       -
         Buffer.add_string buf "\n}\n";

     

       76
       76
       -
         Buffer.contents buf

     

       77
       77
       -
       

     

       78
       78
       -
       (** TODO:claude Main function to export bibtex for all papers *)

     

       79
       79
       -
       let export_bibtex base_dir output_file latest_only _env _xdg _profile =

     

       80
       80
       -
         (* Load all papers *)

     

       81
       81
       -
         let bushel = Bushel.load base_dir in

     

       82
       82
       -
         let papers = Bushel.Entry.papers bushel in

     

       83
       83
       -
       

     

       84
       84
       -
         (* Filter to only latest versions if requested *)

     

       85
       85
       -
         let papers =

     

       86
       86
       -
           if latest_only then

     

       87
       87
       -
             List.filter (fun p -> p.Bushel.Paper.latest) papers

     

       88
       88
       -
           else

     

       89
       89
       -
             papers

     

       90
       90
       -
         in

     

       91
       91
       -
       

     

       92
       92
       -
         (* Sort papers by year (most recent first) *)

     

       93
       93
       -
         let papers = List.sort Bushel.Paper.compare papers in

     

       94
       94
       -
       

     

       95
       95
       -
         (* Generate bibtex for each paper *)

     

       96
       96
       -
         let bibtex_entries = List.map generate_bibtex_entry papers in

     

       97
       97
       -
         let bibtex_content = String.concat "\n" bibtex_entries in

     

       98
       98
       -
       

     

       99
       99
       -
         (* Output to file or stdout *)

     

       100
       100
       -
         match output_file with

     

       101
       101
       -
         | None ->

     

       102
       102
       -
           print_string bibtex_content;

     

       103
       103
       -
           0

     

       104
       104
       -
         | Some file ->

     

       105
       105
       -
           let oc = open_out file in

     

       106
       106
       -
           output_string oc bibtex_content;

     

       107
       107
       -
           close_out oc;

     

       108
       108
       -
           printf "Bibtex exported to %s (%d entries)\n" file (List.length papers);

     

       109
       109
       -
           0

     

       110
       110
       -
       

     

       111
       111
       -
       (** TODO:claude Command line arguments *)

     

       112
       112
       -
       let output_file_arg =

     

       113
       113
       -
         let doc = "Output file for bibtex (defaults to stdout)" in

     

       114
       114
       -
         Arg.(value & opt (some string) None & info ["o"; "output"] ~docv:"FILE" ~doc)

     

       115
       115
       -
       

     

       116
       116
       -
       let latest_only_arg =

     

       117
       117
       -
         let doc = "Export only the latest version of each paper" in

     

       118
       118
       -
         Arg.(value & flag & info ["latest"] ~doc)

     

       119
       119
       -
       

     

       120
       120
       -
       (** TODO:claude Command term *)

     

       121
       121
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       122
       122
       -
         Term.(const export_bibtex $ Bushel_common.base_dir $ output_file_arg $ latest_only_arg)

     

       123
       123
       -
       

     

       124
       124
       -
       let cmd =

     

       125
       125
       -
         let doc = "Export bibtex for all papers" in

     

       126
       126
       -
         let info = Cmd.info "bibtex" ~doc in

     

       127
       127
       -
         Cmd.v info term

-67

stack/bushel/bin/bushel_common.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       

     

       3
       3
       -
       (** TODO:claude Get default base directory from BUSHEL_DATA env variable or current directory *)

     

       4
       4
       -
       let get_default_base_dir () =

     

       5
       5
       -
         match Sys.getenv_opt "BUSHEL_DATA" with

     

       6
       6
       -
         | Some dir -> dir

     

       7
       7
       -
         | None -> "."

     

       8
       8
       -
       

     

       9
       9
       -
       (** TODO:claude Optional base directory term with BUSHEL_DATA env variable support *)

     

       10
       10
       -
       let base_dir =

     

       11
       11
       -
         let doc = "Base directory containing Bushel data (defaults to BUSHEL_DATA env var or current directory)" in

     

       12
       12
       -
         Arg.(value & opt dir (get_default_base_dir ()) & info ["d"; "dir"] ~docv:"DIR" ~doc)

     

       13
       13
       -
       

     

       14
       14
       -
       (** TODO:claude Output directory as option *)

     

       15
       15
       -
       let output_dir ~default =

     

       16
       16
       -
         let doc = "Output directory for generated files" in

     

       17
       17
       -
         Arg.(value & opt string default & info ["o"; "output"] ~docv:"DIR" ~doc)

     

       18
       18
       -
       

     

       19
       19
       -
       (** TODO:claude URL term with custom default *)

     

       20
       20
       -
       let url_term ~default ~doc =

     

       21
       21
       -
         Arg.(value & opt string default & info ["u"; "url"] ~docv:"URL" ~doc)

     

       22
       22
       -
       

     

       23
       23
       -
       (** TODO:claude API key file term *)

     

       24
       24
       -
       let api_key_file ~default =

     

       25
       25
       -
         let doc = "File containing API key" in

     

       26
       26
       -
         Arg.(value & opt string default & info ["k"; "key-file"] ~docv:"FILE" ~doc)

     

       27
       27
       -
       

     

       28
       28
       -
       (** TODO:claude API key term *)

     

       29
       29
       -
       let api_key =

     

       30
       30
       -
         let doc = "API key for authentication" in

     

       31
       31
       -
         Arg.(value & opt (some string) None & info ["api-key"] ~docv:"KEY" ~doc)

     

       32
       32
       -
       

     

       33
       33
       -
       (** TODO:claude Overwrite flag *)

     

       34
       34
       -
       let overwrite =

     

       35
       35
       -
         let doc = "Overwrite existing files" in

     

       36
       36
       -
         Arg.(value & flag & info ["overwrite"] ~doc)

     

       37
       37
       -
       

     

       38
       38
       -
       (** TODO:claude Verbose flag *)

     

       39
       39
       -
       let verbose =

     

       40
       40
       -
         let doc = "Enable verbose output" in

     

       41
       41
       -
         Arg.(value & flag & info ["v"; "verbose"] ~doc)

     

       42
       42
       -
       

     

       43
       43
       -
       (** TODO:claude File path term *)

     

       44
       44
       -
       let file_term ~default ~doc =

     

       45
       45
       -
         Arg.(value & opt string default & info ["f"; "file"] ~docv:"FILE" ~doc)

     

       46
       46
       -
       

     

       47
       47
       -
       (** TODO:claude Channel/handle term *)

     

       48
       48
       -
       let channel ~default =

     

       49
       49
       -
         let doc = "Channel or handle name" in

     

       50
       50
       -
         Arg.(value & opt string default & info ["c"; "channel"] ~docv:"CHANNEL" ~doc)

     

       51
       51
       -
       

     

       52
       52
       -
       (** TODO:claude Optional handle term *)

     

       53
       53
       -
       let handle_opt =

     

       54
       54
       -
         let doc = "Process specific handle" in

     

       55
       55
       -
         Arg.(value & opt (some string) None & info ["h"; "handle"] ~docv:"HANDLE" ~doc)

     

       56
       56
       -
       

     

       57
       57
       -
       (** TODO:claude Tag term for filtering *)

     

       58
       58
       -
       let tag =

     

       59
       59
       -
         let doc = "Tag to filter or apply" in

     

       60
       60
       -
         Arg.(value & opt (some string) None & info ["t"; "tag"] ~docv:"TAG" ~doc)

     

       61
       61
       -
       

     

       62
       62
       -
       (** TODO:claude Limit term *)

     

       63
       63
       -
       let limit =

     

       64
       64
       -
         let doc = "Limit number of items to process" in

     

       65
       65
       -
         Arg.(value & opt (some int) None & info ["l"; "limit"] ~docv:"N" ~doc)

     

       66
       66
       -
       

     

       67
       67
       -
       (* Note: Logging setup is now handled by eiocmd for all bushel binaries *)

-295

stack/bushel/bin/bushel_doi.ml

···

       1
       1
       -
       module ZT = Zotero_translation

     

       2
       2
       -
       open Lwt.Infix

     

       3
       3
       -
       module J = Ezjsonm

     

       4
       4
       -
       open Cmdliner

     

       5
       5
       -
       

     

       6
       6
       -
       (* Extract all DOIs from notes by scanning for doi.org URLs *)

     

       7
       7
       -
       let extract_dois_from_notes notes =

     

       8
       8
       -
         let doi_url_pattern = Re.Perl.compile_pat "https?://(?:dx\\.)?doi\\.org/([^)\\s\"'>]+)" in

     

       9
       9
       -
         let dois = ref [] in

     

       10
       10
       -
         List.iter (fun note ->

     

       11
       11
       -
           let body = Bushel.Note.body note in

     

       12
       12
       -
           let matches = Re.all doi_url_pattern body in

     

       13
       13
       -
           List.iter (fun group ->

     

       14
       14
       -
             try

     

       15
       15
       -
               let encoded_doi = Re.Group.get group 1 in

     

       16
       16
       -
               let doi = Uri.pct_decode encoded_doi in

     

       17
       17
       -
               if not (List.mem doi !dois) then

     

       18
       18
       -
                 dois := doi :: !dois

     

       19
       19
       -
             with _ -> ()

     

       20
       20
       -
           ) matches

     

       21
       21
       -
         ) notes;

     

       22
       22
       -
         !dois

     

       23
       23
       -
       

     

       24
       24
       -
       (* Extract publisher URLs from notes (Elsevier, ScienceDirect, IEEE, Nature, ACM, Sage, UPenn, Springer, Taylor & Francis, OUP) *)

     

       25
       25
       -
       let extract_publisher_urls_from_notes notes =

     

       26
       26
       -
         (* Matches publisher URLs: linkinghub.elsevier.com, sciencedirect.com/science/article, ieeexplore.ieee.org, academic.oup.com, nature.com, journals.sagepub.com, garfield.library.upenn.edu, link.springer.com, tandfonline.com/doi, and dl.acm.org/doi/10.* URLs *)

     

       27
       27
       -
         let publisher_pattern = Re.Perl.compile_pat "https?://(?:(?:www\\.)?(?:linkinghub\\.elsevier\\.com|(?:www\\.)?sciencedirect\\.com/science/article|ieeexplore\\.ieee\\.org|academic\\.oup\\.com|nature\\.com|journals\\.sagepub\\.com|garfield\\.library\\.upenn\\.edu|link\\.springer\\.com)/[^)\\s\"'>]+|(?:dl\\.acm\\.org|(?:www\\.)?tandfonline\\.com)/doi(?:/pdf)?/10\\.[^)\\s\"'>]+)" in

     

       28
       28
       -
         let urls = ref [] in

     

       29
       29
       -
         List.iter (fun note ->

     

       30
       30
       -
           let body = Bushel.Note.body note in

     

       31
       31
       -
           let matches = Re.all publisher_pattern body in

     

       32
       32
       -
           List.iter (fun group ->

     

       33
       33
       -
             try

     

       34
       34
       -
               let url = Re.Group.get group 0 in

     

       35
       35
       -
               if not (List.mem url !urls) then

     

       36
       36
       -
                 urls := url :: !urls

     

       37
       37
       -
             with _ -> ()

     

       38
       38
       -
           ) matches

     

       39
       39
       -
         ) notes;

     

       40
       40
       -
         !urls

     

       41
       41
       -
       

     

       42
       42
       -
       (* Resolve a single DOI via Zotero and convert to doi_entry *)

     

       43
       43
       -
       let resolve_doi zt ~verbose doi =

     

       44
       44
       -
         Printf.printf "Resolving DOI: %s\n%!" doi;

     

       45
       45
       -
         let doi_url = Printf.sprintf "https://doi.org/%s" doi in

     

       46
       46
       -
         Lwt.catch

     

       47
       47
       -
           (fun () ->

     

       48
       48
       -
             ZT.json_of_doi zt ~slug:"temp" doi >>= fun json ->

     

       49
       49
       -
             if verbose then begin

     

       50
       50
       -
               Printf.printf "  Raw Zotero response:\n%s\n%!" (J.value_to_string json)

     

       51
       51
       -
             end;

     

       52
       52
       -
             try

     

       53
       53
       -
               let keys = J.get_dict (json :> J.value) in

     

       54
       54
       -
               let title = J.find json ["title"] |> J.get_string in

     

       55
       55
       -
               let authors = J.find json ["author"] |> J.get_list J.get_string in

     

       56
       56
       -
               let year = J.find json ["year"] |> J.get_string |> int_of_string in

     

       57
       57
       -
               let bibtype = J.find json ["bibtype"] |> J.get_string in

     

       58
       58
       -
               let publisher =

     

       59
       59
       -
                 try

     

       60
       60
       -
                   (* Try journal first, then booktitle, then proceedingsTitle, then publisher *)

     

       61
       61
       -
                   match List.assoc_opt "journal" keys with

     

       62
       62
       -
                   | Some j -> J.get_string j

     

       63
       63
       -
                   | None ->

     

       64
       64
       -
                     match List.assoc_opt "booktitle" keys with

     

       65
       65
       -
                     | Some b -> J.get_string b

     

       66
       66
       -
                     | None ->

     

       67
       67
       -
                       match List.assoc_opt "proceedingsTitle" keys with

     

       68
       68
       -
                       | Some pt -> J.get_string pt

     

       69
       69
       -
                       | None ->

     

       70
       70
       -
                         match List.assoc_opt "publisher" keys with

     

       71
       71
       -
                         | Some p -> J.get_string p

     

       72
       72
       -
                         | None -> ""

     

       73
       73
       -
                 with _ -> ""

     

       74
       74
       -
               in

     

       75
       75
       -
               let entry = Bushel.Doi_entry.create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ~source_urls:[doi_url] () in

     

       76
       76
       -
               Printf.printf "  ✓ Resolved: %s (%d)\n%!" title year;

     

       77
       77
       -
               Lwt.return entry

     

       78
       78
       -
             with e ->

     

       79
       79
       -
               Printf.eprintf "  ✗ Failed to parse response for %s: %s\n%!" doi (Printexc.to_string e);

     

       80
       80
       -
               Lwt.return (Bushel.Doi_entry.create_failed ~doi ~error:(Printexc.to_string e) ~source_urls:[doi_url] ())

     

       81
       81
       -
           )

     

       82
       82
       -
           (fun exn ->

     

       83
       83
       -
             Printf.eprintf "  ✗ Failed to resolve %s: %s\n%!" doi (Printexc.to_string exn);

     

       84
       84
       -
             Lwt.return (Bushel.Doi_entry.create_failed ~doi ~error:(Printexc.to_string exn) ~source_urls:[doi_url] ())

     

       85
       85
       -
           )

     

       86
       86
       -
       

     

       87
       87
       -
       (* Resolve a publisher URL via Zotero /web endpoint *)

     

       88
       88
       -
       let resolve_url zt ~verbose url =

     

       89
       89
       -
         Printf.printf "Resolving URL: %s\n%!" url;

     

       90
       90
       -
         Lwt.catch

     

       91
       91
       -
           (fun () ->

     

       92
       92
       -
             (* Use Zotero's resolve_url which calls /web endpoint with the URL directly *)

     

       93
       93
       -
             ZT.resolve_url zt url >>= function

     

       94
       94
       -
             | Error (`Msg err) ->

     

       95
       95
       -
               Printf.eprintf "  ✗ Failed to resolve URL: %s\n%!" err;

     

       96
       96
       -
               Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:err ~source_urls:[url] ())

     

       97
       97
       -
             | Ok json ->

     

       98
       98
       -
               if verbose then begin

     

       99
       99
       -
                 Printf.printf "  Raw Zotero response:\n%s\n%!" (J.value_to_string json)

     

       100
       100
       -
               end;

     

       101
       101
       -
               try

     

       102
       102
       -
                 (* Extract metadata from the JSON response *)

     

       103
       103
       -
                 let json_list = match json with

     

       104
       104
       -
                   | `A lst -> lst

     

       105
       105
       -
                   | single -> [single]

     

       106
       106
       -
                 in

     

       107
       107
       -
                 match json_list with

     

       108
       108
       -
                 | [] ->

     

       109
       109
       -
                   Printf.eprintf "  ✗ Empty response\n%!";

     

       110
       110
       -
                   Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:"Empty response" ~source_urls:[url] ())

     

       111
       111
       -
                 | item :: _ ->

     

       112
       112
       -
                   (* Extract DOI if present, otherwise use URL *)

     

       113
       113
       -
                   let doi = try J.find item ["DOI"] |> J.get_string with _ ->

     

       114
       114
       -
                     try J.find item ["doi"] |> J.get_string with _ -> url

     

       115
       115
       -
                   in

     

       116
       116
       -
                   let title = try J.find item ["title"] |> J.get_string with _ ->

     

       117
       117
       -
                     "Unknown Title"

     

       118
       118
       -
                   in

     

       119
       119
       -
                   (* Extract authors from Zotero's "creators" field *)

     

       120
       120
       -
                   let authors = try

     

       121
       121
       -
                     J.find item ["creators"] |> J.get_list (fun creator_obj ->

     

       122
       122
       -
                       try

     

       123
       123
       -
                         let last_name = J.find creator_obj ["lastName"] |> J.get_string in

     

       124
       124
       -
                         let first_name = try J.find creator_obj ["firstName"] |> J.get_string with _ -> "" in

     

       125
       125
       -
                         if first_name = "" then last_name else first_name ^ " " ^ last_name

     

       126
       126
       -
                       with _ -> "Unknown Author"

     

       127
       127
       -
                     )

     

       128
       128
       -
                   with _ -> []

     

       129
       129
       -
                   in

     

       130
       130
       -
                   (* Extract year from Zotero's "date" field *)

     

       131
       131
       -
                   (* Handles both ISO format "2025-07" and text format "November 28, 2023" *)

     

       132
       132
       -
                   let year = try

     

       133
       133
       -
                     let date_str = J.find item ["date"] |> J.get_string in

     

       134
       134
       -
                     (* First try splitting on '-' for ISO dates like "2025-07" or "2024-11-04" *)

     

       135
       135
       -
                     let parts = String.split_on_char '-' date_str in

     

       136
       136
       -
                     match parts with

     

       137
       137
       -
                     | year_str :: _ when String.length year_str = 4 ->

     

       138
       138
       -
                       (try int_of_string year_str with _ -> 0)

     

       139
       139
       -
                     | _ ->

     

       140
       140
       -
                       (* Try splitting on space and comma for dates like "November 28, 2023" *)

     

       141
       141
       -
                       let space_parts = String.split_on_char ' ' date_str in

     

       142
       142
       -
                       let year_candidate = List.find_opt (fun s ->

     

       143
       143
       -
                         let s = String.trim (String.map (fun c -> if c = ',' then ' ' else c) s) in

     

       144
       144
       -
                         String.length s = 4 && String.for_all (function '0'..'9' -> true | _ -> false) s

     

       145
       145
       -
                       ) space_parts in

     

       146
       146
       -
                       (match year_candidate with

     

       147
       147
       -
                        | Some year_str -> int_of_string (String.trim year_str)

     

       148
       148
       -
                        | None -> 0)

     

       149
       149
       -
                   with _ -> 0

     

       150
       150
       -
                   in

     

       151
       151
       -
                   (* Extract type/bibtype from Zotero's "itemType" field *)

     

       152
       152
       -
                   let bibtype = try J.find item ["itemType"] |> J.get_string with _ -> "article" in

     

       153
       153
       -
                   (* Extract publisher/journal from Zotero's "publicationTitle" or "proceedingsTitle" field *)

     

       154
       154
       -
                   let publisher = try

     

       155
       155
       -
                     J.find item ["publicationTitle"] |> J.get_string

     

       156
       156
       -
                   with _ ->

     

       157
       157
       -
                     try J.find item ["proceedingsTitle"] |> J.get_string

     

       158
       158
       -
                     with _ -> ""

     

       159
       159
       -
                   in

     

       160
       160
       -
                   (* Include both the original URL and the DOI URL in source_urls *)

     

       161
       161
       -
                   let doi_url = if doi = url then [] else [Printf.sprintf "https://doi.org/%s" doi] in

     

       162
       162
       -
                   let source_urls = url :: doi_url in

     

       163
       163
       -
                   let entry = Bushel.Doi_entry.create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ~source_urls () in

     

       164
       164
       -
                   Printf.printf "  ✓ Resolved: %s (%d) [DOI: %s]\n%!" title year doi;

     

       165
       165
       -
                   Lwt.return entry

     

       166
       166
       -
               with e ->

     

       167
       167
       -
                 Printf.eprintf "  ✗ Failed to parse response: %s\n%!" (Printexc.to_string e);

     

       168
       168
       -
                 Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:(Printexc.to_string e) ~source_urls:[url] ())

     

       169
       169
       -
           )

     

       170
       170
       -
           (fun exn ->

     

       171
       171
       -
             Printf.eprintf "  ✗ Failed to resolve %s: %s\n%!" url (Printexc.to_string exn);

     

       172
       172
       -
             Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:(Printexc.to_string exn) ~source_urls:[url] ())

     

       173
       173
       -
           )

     

       174
       174
       -
       

     

       175
       175
       -
       let run base_dir force verbose =

     

       176
       176
       -
         Printf.printf "Loading bushel database...\n%!";

     

       177
       177
       -
         let entries = Bushel.load base_dir in

     

       178
       178
       -
         let notes = Bushel.Entry.notes entries in

     

       179
       179
       -
       

     

       180
       180
       -
         Printf.printf "Scanning %d notes for DOI URLs...\n%!" (List.length notes);

     

       181
       181
       -
         let found_dois = extract_dois_from_notes notes in

     

       182
       182
       -
         Printf.printf "Found %d unique DOIs\n%!" (List.length found_dois);

     

       183
       183
       -
       

     

       184
       184
       -
         Printf.printf "Scanning %d notes for publisher URLs...\n%!" (List.length notes);

     

       185
       185
       -
         let found_urls = extract_publisher_urls_from_notes notes in

     

       186
       186
       -
         Printf.printf "Found %d unique publisher URLs\n%!" (List.length found_urls);

     

       187
       187
       -
       

     

       188
       188
       -
         let data_dir = Bushel.Entry.data_dir entries in

     

       189
       189
       -
         let doi_yml_path = Filename.concat data_dir "doi.yml" in

     

       190
       190
       -
         Printf.printf "Loading existing DOI cache from %s...\n%!" doi_yml_path;

     

       191
       191
       -
         let existing_entries = Bushel.Doi_entry.load doi_yml_path in

     

       192
       192
       -
         Printf.printf "Loaded %d cached DOI entries\n%!" (List.length existing_entries);

     

       193
       193
       -
       

     

       194
       194
       -
         (* Filter DOIs that need resolution *)

     

       195
       195
       -
         let dois_to_resolve =

     

       196
       196
       -
           List.filter (fun doi ->

     

       197
       197
       -
             match Bushel.Doi_entry.find_by_doi_including_ignored existing_entries doi with

     

       198
       198
       -
             | Some _ when not force ->

     

       199
       199
       -
               Printf.printf "Skipping DOI %s (already cached)\n%!" doi;

     

       200
       200
       -
               false

     

       201
       201
       -
             | Some _ when force ->

     

       202
       202
       -
               Printf.printf "Re-resolving DOI %s (--force)\n%!" doi;

     

       203
       203
       -
               true

     

       204
       204
       -
             | Some _ -> false  (* Catch-all for Some case *)

     

       205
       205
       -
             | None -> true

     

       206
       206
       -
           ) found_dois

     

       207
       207
       -
         in

     

       208
       208
       -
       

     

       209
       209
       -
         (* Filter URLs that need resolution *)

     

       210
       210
       -
         let urls_to_resolve =

     

       211
       211
       -
           List.filter (fun url ->

     

       212
       212
       -
             match Bushel.Doi_entry.find_by_url_including_ignored existing_entries url with

     

       213
       213
       -
             | Some _ when not force ->

     

       214
       214
       -
               Printf.printf "Skipping URL %s (already cached)\n%!" url;

     

       215
       215
       -
               false

     

       216
       216
       -
             | Some _ when force ->

     

       217
       217
       -
               Printf.printf "Re-resolving URL %s (--force)\n%!" url;

     

       218
       218
       -
               true

     

       219
       219
       -
             | Some _ -> false  (* Catch-all for Some case *)

     

       220
       220
       -
             | None -> true

     

       221
       221
       -
           ) found_urls

     

       222
       222
       -
         in

     

       223
       223
       -
       

     

       224
       224
       -
         if List.length dois_to_resolve = 0 && List.length urls_to_resolve = 0 then begin

     

       225
       225
       -
           Printf.printf "No DOIs or URLs to resolve!\n%!";

     

       226
       226
       -
           0

     

       227
       227
       -
         end else begin

     

       228
       228
       -
           Printf.printf "Resolving %d DOI(s) and %d URL(s)...\n%!" (List.length dois_to_resolve) (List.length urls_to_resolve);

     

       229
       229
       -
       

     

       230
       230
       -
           let zt = ZT.v "http://svr-avsm2-eeg-ce:1969" in

     

       231
       231
       -
       

     

       232
       232
       -
           (* Resolve all DOIs *)

     

       233
       233
       -
           let resolved_doi_entries_lwt =

     

       234
       234
       -
             Lwt_list.map_s (resolve_doi zt ~verbose) dois_to_resolve

     

       235
       235
       -
           in

     

       236
       236
       -
       

     

       237
       237
       -
           (* Resolve all publisher URLs *)

     

       238
       238
       -
           let resolved_url_entries_lwt =

     

       239
       239
       -
             Lwt_list.map_s (resolve_url zt ~verbose) urls_to_resolve

     

       240
       240
       -
           in

     

       241
       241
       -
       

     

       242
       242
       -
           let new_doi_entries = Lwt_main.run resolved_doi_entries_lwt in

     

       243
       243
       -
           let new_url_entries = Lwt_main.run resolved_url_entries_lwt in

     

       244
       244
       -
           let new_entries = new_doi_entries @ new_url_entries in

     

       245
       245
       -
       

     

       246
       246
       -
           (* Merge with existing entries, combining source_urls for entries with the same DOI *)

     

       247
       247
       -
           let all_entries =

     

       248
       248
       -
             if force then

     

       249
       249
       -
               (* Replace existing entries with new ones - match by DOI *)

     

       250
       250
       -
               let is_updated entry =

     

       251
       251
       -
                 List.exists (fun new_e ->

     

       252
       252
       -
                   new_e.Bushel.Doi_entry.doi = entry.Bushel.Doi_entry.doi

     

       253
       253
       -
                 ) new_entries

     

       254
       254
       -
               in

     

       255
       255
       -
               let kept_existing = List.filter (fun e -> not (is_updated e)) existing_entries in

     

       256
       256
       -
               kept_existing @ new_entries

     

       257
       257
       -
             else

     

       258
       258
       -
               (* Merge new entries with existing ones, combining source_urls *)

     

       259
       259
       -
               let merged = ref existing_entries in

     

       260
       260
       -
               List.iter (fun new_entry ->

     

       261
       261
       -
                 match Bushel.Doi_entry.find_by_doi_including_ignored !merged new_entry.Bushel.Doi_entry.doi with

     

       262
       262
       -
                 | Some existing_entry ->

     

       263
       263
       -
                   (* DOI already exists - merge the entries by combining source_urls and preserving ignore flag *)

     

       264
       264
       -
                   let combined = Bushel.Doi_entry.merge_entries existing_entry new_entry in

     

       265
       265
       -
                   merged := combined :: (List.filter (fun e -> e.Bushel.Doi_entry.doi <> new_entry.Bushel.Doi_entry.doi) !merged)

     

       266
       266
       -
                 | None ->

     

       267
       267
       -
                   (* New DOI - add it *)

     

       268
       268
       -
                   merged := new_entry :: !merged

     

       269
       269
       -
               ) new_entries;

     

       270
       270
       -
               !merged

     

       271
       271
       -
           in

     

       272
       272
       -
       

     

       273
       273
       -
           (* Save updated cache *)

     

       274
       274
       -
           Printf.printf "Saving %d total entries to %s...\n%!" (List.length all_entries) doi_yml_path;

     

       275
       275
       -
           Bushel.Doi_entry.save doi_yml_path all_entries;

     

       276
       276
       -
       

     

       277
       277
       -
           Printf.printf "Done!\n%!";

     

       278
       278
       -
           0

     

       279
       279
       -
         end

     

       280
       280
       -
       

     

       281
       281
       -
       let force_flag =

     

       282
       282
       -
         let doc = "Force re-resolution of already cached DOIs" in

     

       283
       283
       -
         Arg.(value & flag & info ["force"; "f"] ~doc)

     

       284
       284
       -
       

     

       285
       285
       -
       let verbose_flag =

     

       286
       286
       -
         let doc = "Show raw Zotero API responses for debugging" in

     

       287
       287
       -
         Arg.(value & flag & info ["verbose"; "v"] ~doc)

     

       288
       288
       -
       

     

       289
       289
       -
       let term =

     

       290
       290
       -
         Term.(const run $ Bushel_common.base_dir $ force_flag $ verbose_flag)

     

       291
       291
       -
       

     

       292
       292
       -
       let cmd =

     

       293
       293
       -
         let doc = "Resolve DOIs found in notes via Zotero Translation Server" in

     

       294
       294
       -
         let info = Cmd.info "doi-resolve" ~doc in

     

       295
       295
       -
         Cmd.v info term

-182

stack/bushel/bin/bushel_faces.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       open Lwt.Infix

     

       3
       3
       -
       open Printf

     

       4
       4
       -
       

     

       5
       5
       -
       (* Type for person response *)

     

       6
       6
       -
       type person = {

     

       7
       7
       -
         id: string;

     

       8
       8
       -
         name: string;

     

       9
       9
       -
         thumbnailPath: string option;

     

       10
       10
       -
       }

     

       11
       11
       -
       

     

       12
       12
       -
       (* Parse a person from JSON *)

     

       13
       13
       -
       let parse_person json =

     

       14
       14
       -
         let open Ezjsonm in

     

       15
       15
       -
         let id = find json ["id"] |> get_string in

     

       16
       16
       -
         let name = find json ["name"] |> get_string in

     

       17
       17
       -
         let thumbnailPath = 

     

       18
       18
       -
           try Some (find json ["thumbnailPath"] |> get_string)

     

       19
       19
       -
           with _ -> None

     

       20
       20
       -
         in

     

       21
       21
       -
         { id; name; thumbnailPath }

     

       22
       22
       -
       

     

       23
       23
       -
       (* Parse a list of people from JSON response *)

     

       24
       24
       -
       let parse_people_response json =

     

       25
       25
       -
         let open Ezjsonm in

     

       26
       26
       -
         get_list parse_person json

     

       27
       27
       -
       

     

       28
       28
       -
       (* Read API key from file *)

     

       29
       29
       -
       let read_api_key file =

     

       30
       30
       -
         let ic = open_in file in

     

       31
       31
       -
         let key = input_line ic in

     

       32
       32
       -
         close_in ic;

     

       33
       33
       -
         key

     

       34
       34
       -
       

     

       35
       35
       -
       (* Search for a person by name *)

     

       36
       36
       -
       let search_person base_url api_key name =

     

       37
       37
       -
         let open Cohttp_lwt_unix in

     

       38
       38
       -
         let headers = Cohttp.Header.init_with "X-Api-Key" api_key in

     

       39
       39
       -
         let encoded_name = Uri.pct_encode name in

     

       40
       40
       -
         let url = Printf.sprintf "%s/api/search/person?name=%s" base_url encoded_name in

     

       41
       41
       -
         

     

       42
       42
       -
         Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->

     

       43
       43
       -
         if resp.status = `OK then

     

       44
       44
       -
           Cohttp_lwt.Body.to_string body >>= fun body_str ->

     

       45
       45
       -
           let json = Ezjsonm.from_string body_str in

     

       46
       46
       -
           Lwt.return (parse_people_response json)

     

       47
       47
       -
         else

     

       48
       48
       -
           let status_code = Cohttp.Code.code_of_status resp.status in

     

       49
       49
       -
           Lwt.fail_with (Printf.sprintf "HTTP error: %d" status_code)

     

       50
       50
       -
       

     

       51
       51
       -
       (* Download thumbnail for a person *)

     

       52
       52
       -
       let download_thumbnail base_url api_key person_id output_path =

     

       53
       53
       -
         let open Cohttp_lwt_unix in

     

       54
       54
       -
         let headers = Cohttp.Header.init_with "X-Api-Key" api_key in

     

       55
       55
       -
         let url = Printf.sprintf "%s/api/people/%s/thumbnail" base_url person_id in

     

       56
       56
       -
         

     

       57
       57
       -
         Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->

     

       58
       58
       -
         match resp.status with

     

       59
       59
       -
         | `OK ->

     

       60
       60
       -
           Cohttp_lwt.Body.to_string body >>= fun img_data ->

     

       61
       61
       -
           (* Ensure output directory exists *)

     

       62
       62
       -
           (try

     

       63
       63
       -
              let dir = Filename.dirname output_path in

     

       64
       64
       -
              if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;

     

       65
       65
       -
              Lwt.return_unit

     

       66
       66
       -
            with _ -> Lwt.return_unit) >>= fun () ->

     

       67
       67
       -
           Lwt_io.with_file ~mode:Lwt_io.output output_path

     

       68
       68
       -
             (fun oc -> Lwt_io.write oc img_data) >>= fun () ->

     

       69
       69
       -
           Lwt.return_ok output_path

     

       70
       70
       -
         | _ ->

     

       71
       71
       -
           let status_code = Cohttp.Code.code_of_status resp.status in

     

       72
       72
       -
           Lwt.return_error (Printf.sprintf "HTTP error: %d" status_code)

     

       73
       73
       -
       

     

       74
       74
       -
       (* Get face for a single contact *)

     

       75
       75
       -
       (* TODO:claude *)

     

       76
       76
       -
       let get_face_for_contact base_url api_key output_dir contact =

     

       77
       77
       -
         let names = Bushel.Contact.names contact in

     

       78
       78
       -
         let handle = Bushel.Contact.handle contact in

     

       79
       79
       -
         let output_path = Filename.concat output_dir (handle ^ ".jpg") in

     

       80
       80
       -
       

     

       81
       81
       -
         (* Skip if file already exists *)

     

       82
       82
       -
         if Sys.file_exists output_path then

     

       83
       83
       -
           Lwt.return (`Skipped (sprintf "Thumbnail for '%s' already exists at %s" (List.hd names) output_path))

     

       84
       84
       -
         else begin

     

       85
       85
       -
           printf "Processing contact: %s (handle: %s)\n%!" (List.hd names) handle;

     

       86
       86
       -
       

     

       87
       87
       -
           (* Try each name in the list until we find a match *)

     

       88
       88
       -
           let rec try_names = function

     

       89
       89
       -
             | [] ->

     

       90
       90
       -
                 Lwt.return (`Error (sprintf "No person found with any name for contact '%s'" handle))

     

       91
       91
       -
             | name :: rest_names ->

     

       92
       92
       -
                 printf "  Trying name: %s\n%!" name;

     

       93
       93
       -
                 search_person base_url api_key name >>= function

     

       94
       94
       -
                 | [] ->

     

       95
       95
       -
                     printf "  No results for '%s', trying next name...\n%!" name;

     

       96
       96
       -
                     try_names rest_names

     

       97
       97
       -
                 | person :: _ ->

     

       98
       98
       -
                     printf "  Found match for '%s'\n%!" name;

     

       99
       99
       -
                     download_thumbnail base_url api_key person.id output_path >>= function

     

       100
       100
       -
                     | Ok path ->

     

       101
       101
       -
                         Lwt.return (`Ok (sprintf "Saved thumbnail for '%s' to %s" name path))

     

       102
       102
       -
                     | Error err ->

     

       103
       103
       -
                         Lwt.return (`Error (sprintf "Error for '%s': %s" name err))

     

       104
       104
       -
           in

     

       105
       105
       -
           try_names names

     

       106
       106
       -
         end

     

       107
       107
       -
       

     

       108
       108
       -
       (* Process all contacts or a specific one *)

     

       109
       109
       -
       let process_contacts base_dir output_dir specific_handle api_key base_url =

     

       110
       110
       -
         printf "Loading Bushel database from %s\n%!" base_dir;

     

       111
       111
       -
         let db = Bushel.load base_dir in

     

       112
       112
       -
         let contacts = Bushel.Entry.contacts db in

     

       113
       113
       -
         printf "Found %d contacts\n%!" (List.length contacts);

     

       114
       114
       -
         

     

       115
       115
       -
         (* Ensure output directory exists *)

     

       116
       116
       -
         if not (Sys.file_exists output_dir) then Unix.mkdir output_dir 0o755;

     

       117
       117
       -
         

     

       118
       118
       -
         (* Filter contacts based on specific_handle if provided *)

     

       119
       119
       -
         let contacts_to_process = 

     

       120
       120
       -
           match specific_handle with

     

       121
       121
       -
           | Some handle -> 

     

       122
       122
       -
               begin match Bushel.Contact.find_by_handle contacts handle with

     

       123
       123
       -
               | Some contact -> [contact]

     

       124
       124
       -
               | None -> 

     

       125
       125
       -
                   eprintf "No contact found with handle '%s'\n%!" handle;

     

       126
       126
       -
                   []

     

       127
       127
       -
               end

     

       128
       128
       -
           | None -> contacts

     

       129
       129
       -
         in

     

       130
       130
       -
         

     

       131
       131
       -
         (* Process each contact *)

     

       132
       132
       -
         let results = Lwt_main.run begin

     

       133
       133
       -
           Lwt_list.map_s 

     

       134
       134
       -
             (fun contact -> 

     

       135
       135
       -
                get_face_for_contact base_url api_key output_dir contact >>= fun result ->

     

       136
       136
       -
                Lwt.return (Bushel.Contact.handle contact, result))

     

       137
       137
       -
             contacts_to_process

     

       138
       138
       -
         end in

     

       139
       139
       -
         

     

       140
       140
       -
         (* Print summary *)

     

       141
       141
       -
         let ok_count = List.length (List.filter (fun (_, r) -> match r with `Ok _ -> true | _ -> false) results) in

     

       142
       142
       -
         let error_count = List.length (List.filter (fun (_, r) -> match r with `Error _ -> true | _ -> false) results) in

     

       143
       143
       -
         let skipped_count = List.length (List.filter (fun (_, r) -> match r with `Skipped _ -> true | _ -> false) results) in

     

       144
       144
       -
         

     

       145
       145
       -
         printf "\nSummary:\n";

     

       146
       146
       -
         printf "  Successfully processed: %d\n" ok_count;

     

       147
       147
       -
         printf "  Errors: %d\n" error_count;

     

       148
       148
       -
         printf "  Skipped (already exist): %d\n" skipped_count;

     

       149
       149
       -
         

     

       150
       150
       -
         (* Print detailed results *)

     

       151
       151
       -
         if error_count > 0 then begin

     

       152
       152
       -
           printf "\nError details:\n";

     

       153
       153
       -
           List.iter (fun (handle, result) ->

     

       154
       154
       -
             match result with

     

       155
       155
       -
             | `Error msg -> printf "  %s: %s\n" handle msg

     

       156
       156
       -
             | _ -> ())

     

       157
       157
       -
             results;

     

       158
       158
       -
         end;

     

       159
       159
       -
         

     

       160
       160
       -
         if ok_count > 0 || skipped_count > 0 then 0 else 1

     

       161
       161
       -
       

     

       162
       162
       -
       (* Command line interface *)

     

       163
       163
       -
       

     

       164
       164
       -
       (* Export the term for use in main bushel.ml *)

     

       165
       165
       -
       let term =

     

       166
       166
       -
         Term.(

     

       167
       167
       -
           const (fun base_dir output_dir handle api_key_file base_url ->

     

       168
       168
       -
             try

     

       169
       169
       -
               let api_key = read_api_key api_key_file in

     

       170
       170
       -
               process_contacts base_dir output_dir handle api_key base_url

     

       171
       171
       -
             with e -> 

     

       172
       172
       -
               eprintf "Error: %s\n%!" (Printexc.to_string e);

     

       173
       173
       -
               1

     

       174
       174
       -
           ) $ Bushel_common.base_dir $ Bushel_common.output_dir ~default:"." $ Bushel_common.handle_opt $ 

     

       175
       175
       -
             Bushel_common.api_key_file ~default:".photos-api" $ 

     

       176
       176
       -
             Bushel_common.url_term ~default:"https://photos.recoil.org" ~doc:"Base URL of the Immich instance")

     

       177
       177
       -
       

     

       178
       178
       -
       let cmd =

     

       179
       179
       -
         let info = Cmd.info "faces" ~doc:"Retrieve face thumbnails for Bushel contacts from Immich" in

     

       180
       180
       -
         Cmd.v info term

     

       181
       181
       -
       

     

       182
       182
       -
       (* Main entry point removed - accessed through bushel_main.ml *)

-77

stack/bushel/bin/bushel_ideas.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       

     

       3
       3
       -
       (** TODO:claude List completed ideas as markdown bullet list *)

     

       4
       4
       -
       let list_ideas_md base_dir =

     

       5
       5
       -
         let ideas_dir = Printf.sprintf "%s/ideas" base_dir in

     

       6
       6
       -
         let contacts_dir = Printf.sprintf "%s/contacts" base_dir in

     

       7
       7
       -
       

     

       8
       8
       -
         if not (Sys.file_exists ideas_dir) then (

     

       9
       9
       -
           Printf.eprintf "Ideas directory not found: %s\n" ideas_dir;

     

       10
       10
       -
           1

     

       11
       11
       -
         ) else (

     

       12
       12
       -
           (* Load all contacts *)

     

       13
       13
       -
           let contacts =

     

       14
       14
       -
             if Sys.file_exists contacts_dir then

     

       15
       15
       -
               Sys.readdir contacts_dir

     

       16
       16
       -
               |> Array.to_list

     

       17
       17
       -
               |> List.filter (String.ends_with ~suffix:".md")

     

       18
       18
       -
               |> List.filter_map (fun contact_file ->

     

       19
       19
       -
                 let filepath = Filename.concat contacts_dir contact_file in

     

       20
       20
       -
                 try Some (Bushel.Contact.of_md filepath)

     

       21
       21
       -
                 with e ->

     

       22
       22
       -
                   Printf.eprintf "Error loading contact %s: %s\n" filepath (Printexc.to_string e);

     

       23
       23
       -
                   None

     

       24
       24
       -
               )

     

       25
       25
       -
             else []

     

       26
       26
       -
           in

     

       27
       27
       -
       

     

       28
       28
       -
           let idea_files = Sys.readdir ideas_dir

     

       29
       29
       -
                            |> Array.to_list

     

       30
       30
       -
                            |> List.filter (String.ends_with ~suffix:".md") in

     

       31
       31
       -
           let ideas = List.filter_map (fun idea_file ->

     

       32
       32
       -
             let filepath = Filename.concat ideas_dir idea_file in

     

       33
       33
       -
             try

     

       34
       34
       -
               let idea = Bushel.Idea.of_md filepath in

     

       35
       35
       -
               match Bushel.Idea.status idea with

     

       36
       36
       -
               | Bushel.Idea.Completed -> Some idea

     

       37
       37
       -
               | _ -> None

     

       38
       38
       -
             with e ->

     

       39
       39
       -
               Printf.eprintf "Error processing %s: %s\n" filepath (Printexc.to_string e);

     

       40
       40
       -
               None

     

       41
       41
       -
           ) idea_files in

     

       42
       42
       -
       

     

       43
       43
       -
           (* Sort by year descending *)

     

       44
       44
       -
           let sorted_ideas = List.sort (fun a b ->

     

       45
       45
       -
             compare (Bushel.Idea.year b) (Bushel.Idea.year a)

     

       46
       46
       -
           ) ideas in

     

       47
       47
       -
       

     

       48
       48
       -
           (* Output as markdown bullet list *)

     

       49
       49
       -
           List.iter (fun idea ->

     

       50
       50
       -
             let student_names =

     

       51
       51
       -
               Bushel.Idea.students idea

     

       52
       52
       -
               |> List.filter_map (fun handle ->

     

       53
       53
       -
                 match Bushel.Contact.find_by_handle contacts handle with

     

       54
       54
       -
                 | Some contact -> Some (Bushel.Contact.name contact)

     

       55
       55
       -
                 | None ->

     

       56
       56
       -
                   Printf.eprintf "Warning: contact not found for handle %s\n" handle;

     

       57
       57
       -
                   Some handle

     

       58
       58
       -
               )

     

       59
       59
       -
               |> String.concat ", "

     

       60
       60
       -
             in

     

       61
       61
       -
             let level_str = Bushel.Idea.level_to_string (Bushel.Idea.level idea) in

     

       62
       62
       -
             Printf.printf "- %d: \"%s\", %s (%s)\n"

     

       63
       63
       -
               (Bushel.Idea.year idea)

     

       64
       64
       -
               (Bushel.Idea.title idea)

     

       65
       65
       -
               student_names

     

       66
       66
       -
               level_str

     

       67
       67
       -
           ) sorted_ideas;

     

       68
       68
       -
           0

     

       69
       69
       -
         )

     

       70
       70
       -
       

     

       71
       71
       -
       let term =

     

       72
       72
       -
         Term.(const list_ideas_md $ Bushel_common.base_dir)

     

       73
       73
       -
       

     

       74
       74
       -
       let cmd =

     

       75
       75
       -
         let doc = "List completed ideas as markdown bullet list" in

     

       76
       76
       -
         let info = Cmd.info "ideas-md" ~doc in

     

       77
       77
       -
         Cmd.v info term

-227

stack/bushel/bin/bushel_info.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       open Bushel

     

       3
       3
       -
       

     

       4
       4
       -
       (** Determine the color for a note based on DOI and perma status *)

     

       5
       5
       -
       let note_color n =

     

       6
       6
       -
         match Note.doi n, Note.perma n with

     

       7
       7
       -
         | None, false -> `Red          (* No DOI, no perma - red (normal note) *)

     

       8
       8
       -
         | None, true -> `Magenta       (* Has perma but no DOI - magenta (needs DOI assignment) *)

     

       9
       9
       -
         | Some _, true -> `Green       (* Has DOI with perma:true - green (correct state) *)

     

       10
       10
       -
         | Some _, false -> `Yellow     (* Has DOI without perma:true - yellow (bug in metadata) *)

     

       11
       11
       -
       

     

       12
       12
       -
       (** TODO:claude List all slugs with their types *)

     

       13
       13
       -
       let list_all_slugs entries ~notes_only =

     

       14
       14
       -
         let all = Entry.all_entries entries in

     

       15
       15
       -
         (* Filter for notes only if requested *)

     

       16
       16
       -
         let filtered = if notes_only then

     

       17
       17
       -
           List.filter (fun entry -> match entry with `Note _ -> true | _ -> false) all

     

       18
       18
       -
         else all in

     

       19
       19
       -
         (* Sort by slug for consistent output *)

     

       20
       20
       -
         let sorted = List.sort (fun a b ->

     

       21
       21
       -
           String.compare (Entry.slug a) (Entry.slug b)

     

       22
       22
       -
         ) filtered in

     

       23
       23
       -
         Fmt.pr "@[<v>";

     

       24
       24
       -
         Fmt.pr "%a@," (Fmt.styled `Bold Fmt.string) (if notes_only then "Available notes:" else "Available entries:");

     

       25
       25
       -
         Fmt.pr "@,";

     

       26
       26
       -
         List.iter (fun entry ->

     

       27
       27
       -
           let slug = Entry.slug entry in

     

       28
       28
       -
           let type_str = Entry.to_type_string entry in

     

       29
       29
       -
           let title = Entry.title entry in

     

       30
       30
       -
           (* Color code notes based on DOI/perma status *)

     

       31
       31
       -
           match entry with

     

       32
       32
       -
           | `Note n ->

     

       33
       33
       -
             let color = note_color n in

     

       34
       34
       -
             Fmt.pr "  %a %a - %a@,"

     

       35
       35
       -
               (Fmt.styled color Fmt.string) slug

     

       36
       36
       -
               (Fmt.styled `Faint Fmt.string) (Printf.sprintf "(%s)" type_str)

     

       37
       37
       -
               Fmt.string title

     

       38
       38
       -
           | _ ->

     

       39
       39
       -
             Fmt.pr "  %a %a - %a@,"

     

       40
       40
       -
               (Fmt.styled `Cyan Fmt.string) slug

     

       41
       41
       -
               (Fmt.styled `Faint Fmt.string) (Printf.sprintf "(%s)" type_str)

     

       42
       42
       -
               Fmt.string title

     

       43
       43
       -
         ) sorted;

     

       44
       44
       -
         Fmt.pr "@]@.";

     

       45
       45
       -
         0

     

       46
       46
       -
       

     

       47
       47
       -
       (** TODO:claude Main info command implementation *)

     

       48
       48
       -
       let info_cmd base_dir notes_only slug_opt _env _xdg _profile =

     

       49
       49
       -
         let entries = load base_dir in

     

       50
       50
       -
         match slug_opt with

     

       51
       51
       -
         | None ->

     

       52
       52
       -
           list_all_slugs entries ~notes_only

     

       53
       53
       -
         | Some slug ->

     

       54
       54
       -
           (* Handle contact handles starting with @ *)

     

       55
       55
       -
           if String.starts_with ~prefix:"@" slug then

     

       56
       56
       -
             let handle = String.sub slug 1 (String.length slug - 1) in

     

       57
       57
       -
             match Contact.find_by_handle (Entry.contacts entries) handle with

     

       58
       58
       -
             | None ->

     

       59
       59
       -
               Fmt.epr "Error: No contact found with handle '@%s'@." handle;

     

       60
       60
       -
               1

     

       61
       61
       -
             | Some contact ->

     

       62
       62
       -
               Contact.pp Fmt.stdout contact;

     

       63
       63
       -
               (* Add thumbnail information for contact *)

     

       64
       64
       -
               (match Entry.contact_thumbnail_slug contact with

     

       65
       65
       -
                | Some thumb_slug ->

     

       66
       66
       -
                  Fmt.pr "@.@.";

     

       67
       67
       -
                  Fmt.pr "@[<v>%a: %s@," (Fmt.styled `Bold Fmt.string) "Thumbnail Slug" thumb_slug;

     

       68
       68
       -
                  (* Look up the image in srcsetter *)

     

       69
       69
       -
                  (match Entry.lookup_image entries thumb_slug with

     

       70
       70
       -
                   | Some img ->

     

       71
       71
       -
                     let thumbnail_url = Entry.smallest_webp_variant img in

     

       72
       72
       -
                     Fmt.pr "%a: %s@," (Fmt.styled `Bold Fmt.string) "Thumbnail URL" thumbnail_url;

     

       73
       73
       -
                     Fmt.pr "%a: %s@," (Fmt.styled `Bold Fmt.string) "Origin" (Srcsetter.origin img);

     

       74
       74
       -
                     let (w, h) = Srcsetter.dims img in

     

       75
       75
       -
                     Fmt.pr "%a: %dx%d@," (Fmt.styled `Bold Fmt.string) "Dimensions" w h;

     

       76
       76
       -
                     let variants = Srcsetter.variants img in

     

       77
       77
       -
                     if not (Srcsetter.MS.is_empty variants) then begin

     

       78
       78
       -
                       Fmt.pr "%a:@," (Fmt.styled `Bold Fmt.string) "Variants";

     

       79
       79
       -
                       Srcsetter.MS.iter (fun name (vw, vh) ->

     

       80
       80
       -
                         Fmt.pr "  %s: %dx%d@," name vw vh

     

       81
       81
       -
                       ) variants

     

       82
       82
       -
                     end;

     

       83
       83
       -
                     Fmt.pr "@]"

     

       84
       84
       -
                   | None ->

     

       85
       85
       -
                     Fmt.epr "Warning: Contact thumbnail image not in srcsetter: %s@." thumb_slug;

     

       86
       86
       -
                     Fmt.pr "@]";

     

       87
       87
       -
                     ())

     

       88
       88
       -
                | None -> ());

     

       89
       89
       -
               (* Add Typesense JSON *)

     

       90
       90
       -
               let doc = Typesense.contact_to_document contact in

     

       91
       91
       -
               Fmt.pr "@.@.";

     

       92
       92
       -
               Fmt.pr "%a:@," (Fmt.styled `Bold Fmt.string) "Typesense Document";

     

       93
       93
       -
               Fmt.pr "%s@," (Ezjsonm.value_to_string ~minify:false doc);

     

       94
       94
       -
               (* Add backlinks information for contact *)

     

       95
       95
       -
               let backlinks = Bushel.Link_graph.get_backlinks_for_slug handle in

     

       96
       96
       -
               if backlinks <> [] then begin

     

       97
       97
       -
                 Fmt.pr "@.@.";

     

       98
       98
       -
                 Fmt.pr "%a (%d):@," (Fmt.styled `Bold Fmt.string) "Backlinks" (List.length backlinks);

     

       99
       99
       -
                 List.iter (fun source_slug ->

     

       100
       100
       -
                   match Entry.lookup entries source_slug with

     

       101
       101
       -
                   | Some source_entry ->

     

       102
       102
       -
                     let source_type = Entry.to_type_string source_entry in

     

       103
       103
       -
                     let source_title = Entry.title source_entry in

     

       104
       104
       -
                     Fmt.pr "  %a %a - %a@,"

     

       105
       105
       -
                       (Fmt.styled `Cyan Fmt.string) source_slug

     

       106
       106
       -
                       (Fmt.styled `Faint Fmt.string) (Printf.sprintf "(%s)" source_type)

     

       107
       107
       -
                       Fmt.string source_title

     

       108
       108
       -
                   | None ->

     

       109
       109
       -
                     Fmt.pr "  %a %a@,"

     

       110
       110
       -
                       (Fmt.styled `Cyan Fmt.string) source_slug

     

       111
       111
       -
                       (Fmt.styled `Red Fmt.string) "(not found)"

     

       112
       112
       -
                 ) backlinks

     

       113
       113
       -
               end;

     

       114
       114
       -
               Fmt.pr "@.";

     

       115
       115
       -
               0

     

       116
       116
       -
           else

     

       117
       117
       -
             (* Remove leading ':' if present, as slugs are stored without it *)

     

       118
       118
       -
             let normalized_slug =

     

       119
       119
       -
               if String.starts_with ~prefix:":" slug

     

       120
       120
       -
               then String.sub slug 1 (String.length slug - 1)

     

       121
       121
       -
               else slug

     

       122
       122
       -
             in

     

       123
       123
       -
             match Entry.lookup entries normalized_slug with

     

       124
       124
       -
             | None ->

     

       125
       125
       -
               Fmt.epr "Error: No entry found with slug '%s'@." slug;

     

       126
       126
       -
               1

     

       127
       127
       -
             | Some entry ->

     

       128
       128
       -
               (match entry with

     

       129
       129
       -
                | `Paper p -> Paper.pp Fmt.stdout p

     

       130
       130
       -
                | `Project p -> Project.pp Fmt.stdout p

     

       131
       131
       -
                | `Idea i -> Idea.pp Fmt.stdout i

     

       132
       132
       -
                | `Video v -> Video.pp Fmt.stdout v

     

       133
       133
       -
                | `Note n -> Note.pp Fmt.stdout n);

     

       134
       134
       -
               (* Add thumbnail information if available *)

     

       135
       135
       -
               (match Entry.thumbnail_slug entries entry with

     

       136
       136
       -
                | Some thumb_slug ->

     

       137
       137
       -
                  Fmt.pr "@.@.";

     

       138
       138
       -
                  Fmt.pr "@[<v>%a: %s@," (Fmt.styled `Bold Fmt.string) "Thumbnail Slug" thumb_slug;

     

       139
       139
       -
                  (* Look up the image in srcsetter *)

     

       140
       140
       -
                  (match Entry.lookup_image entries thumb_slug with

     

       141
       141
       -
                   | Some img ->

     

       142
       142
       -
                     let thumbnail_url = Entry.smallest_webp_variant img in

     

       143
       143
       -
                     Fmt.pr "%a: %s@," (Fmt.styled `Bold Fmt.string) "Thumbnail URL" thumbnail_url;

     

       144
       144
       -
                     Fmt.pr "%a: %s@," (Fmt.styled `Bold Fmt.string) "Origin" (Srcsetter.origin img);

     

       145
       145
       -
                     let (w, h) = Srcsetter.dims img in

     

       146
       146
       -
                     Fmt.pr "%a: %dx%d@," (Fmt.styled `Bold Fmt.string) "Dimensions" w h;

     

       147
       147
       -
                     let variants = Srcsetter.variants img in

     

       148
       148
       -
                     if not (Srcsetter.MS.is_empty variants) then begin

     

       149
       149
       -
                       Fmt.pr "%a:@," (Fmt.styled `Bold Fmt.string) "Variants";

     

       150
       150
       -
                       Srcsetter.MS.iter (fun name (vw, vh) ->

     

       151
       151
       -
                         Fmt.pr "  %s: %dx%d@," name vw vh

     

       152
       152
       -
                       ) variants

     

       153
       153
       -
                     end;

     

       154
       154
       -
                     Fmt.pr "@]"

     

       155
       155
       -
                   | None ->

     

       156
       156
       -
                     Fmt.epr "Warning: Thumbnail image not in srcsetter: %s@." thumb_slug;

     

       157
       157
       -
                     Fmt.pr "@]";

     

       158
       158
       -
                     ())

     

       159
       159
       -
                | None -> ());

     

       160
       160
       -
               (* Add Typesense JSON *)

     

       161
       161
       -
               let doc = match entry with

     

       162
       162
       -
                 | `Paper p -> Typesense.paper_to_document entries p

     

       163
       163
       -
                 | `Project p -> Typesense.project_to_document entries p

     

       164
       164
       -
                 | `Idea i -> Typesense.idea_to_document entries i

     

       165
       165
       -
                 | `Video v -> Typesense.video_to_document entries v

     

       166
       166
       -
                 | `Note n -> Typesense.note_to_document entries n

     

       167
       167
       -
               in

     

       168
       168
       -
               Fmt.pr "@.@.";

     

       169
       169
       -
               Fmt.pr "%a:@," (Fmt.styled `Bold Fmt.string) "Typesense Document";

     

       170
       170
       -
               Fmt.pr "%s@," (Ezjsonm.value_to_string ~minify:false doc);

     

       171
       171
       -
               (* Add backlinks information *)

     

       172
       172
       -
               let backlinks = Bushel.Link_graph.get_backlinks_for_slug normalized_slug in

     

       173
       173
       -
               if backlinks <> [] then begin

     

       174
       174
       -
                 Fmt.pr "@.@.";

     

       175
       175
       -
                 Fmt.pr "%a (%d):@," (Fmt.styled `Bold Fmt.string) "Backlinks" (List.length backlinks);

     

       176
       176
       -
                 List.iter (fun source_slug ->

     

       177
       177
       -
                   match Entry.lookup entries source_slug with

     

       178
       178
       -
                   | Some source_entry ->

     

       179
       179
       -
                     let source_type = Entry.to_type_string source_entry in

     

       180
       180
       -
                     let source_title = Entry.title source_entry in

     

       181
       181
       -
                     Fmt.pr "  %a %a - %a@,"

     

       182
       182
       -
                       (Fmt.styled `Cyan Fmt.string) source_slug

     

       183
       183
       -
                       (Fmt.styled `Faint Fmt.string) (Printf.sprintf "(%s)" source_type)

     

       184
       184
       -
                       Fmt.string source_title

     

       185
       185
       -
                   | None ->

     

       186
       186
       -
                     Fmt.pr "  %a %a@,"

     

       187
       187
       -
                       (Fmt.styled `Cyan Fmt.string) source_slug

     

       188
       188
       -
                       (Fmt.styled `Red Fmt.string) "(not found)"

     

       189
       189
       -
                 ) backlinks

     

       190
       190
       -
               end;

     

       191
       191
       -
               (* Add references information for notes *)

     

       192
       192
       -
               (match entry with

     

       193
       193
       -
                | `Note n ->

     

       194
       194
       -
                  let default_author = match Contact.find_by_handle (Entry.contacts entries) "avsm" with

     

       195
       195
       -
                    | Some c -> c

     

       196
       196
       -
                    | None -> failwith "Default author 'avsm' not found"

     

       197
       197
       -
                  in

     

       198
       198
       -
                  let references = Md.note_references entries default_author n in

     

       199
       199
       -
                  if references <> [] then begin

     

       200
       200
       -
                    Fmt.pr "@.@.";

     

       201
       201
       -
                    Fmt.pr "%a (%d):@," (Fmt.styled `Bold Fmt.string) "References" (List.length references);

     

       202
       202
       -
                    List.iter (fun (doi, citation, _is_paper) ->

     

       203
       203
       -
                      Fmt.pr "  %a: %s@,"

     

       204
       204
       -
                        (Fmt.styled `Cyan Fmt.string) doi

     

       205
       205
       -
                        citation

     

       206
       206
       -
                    ) references

     

       207
       207
       -
                  end

     

       208
       208
       -
                | _ -> ());

     

       209
       209
       -
               Fmt.pr "@.";

     

       210
       210
       -
               0

     

       211
       211
       -
       

     

       212
       212
       -
       (** TODO:claude Command line interface definition *)

     

       213
       213
       -
       let notes_only_flag =

     

       214
       214
       -
         let doc = "Show only notes when listing entries" in

     

       215
       215
       -
         Arg.(value & flag & info ["notes-only"; "n"] ~doc)

     

       216
       216
       -
       

     

       217
       217
       -
       let slug_arg =

     

       218
       218
       -
         let doc = "The slug of the entry to display (with or without leading ':'), or contact handle (with '@' prefix). If not provided, lists all available slugs." in

     

       219
       219
       -
         Arg.(value & pos 0 (some string) None & info [] ~docv:"SLUG" ~doc)

     

       220
       220
       -
       

     

       221
       221
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       222
       222
       -
         Term.(const info_cmd $ Bushel_common.base_dir $ notes_only_flag $ slug_arg)

     

       223
       223
       -
       

     

       224
       224
       -
       let cmd =

     

       225
       225
       -
         let doc = "Display all information for a given slug" in

     

       226
       226
       -
         let info = Cmd.info "info" ~doc in

     

       227
       227
       -
         Cmd.v info term

-549

stack/bushel/bin/bushel_links.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       open Lwt.Infix

     

       3
       3
       -
       

     

       4
       4
       -
       (* Helper function for logging with proper flushing *)

     

       5
       5
       -
       let log fmt = Fmt.kstr (fun s -> prerr_string s; flush stderr) fmt

     

       6
       6
       -
       let log_verbose verbose fmt = 

     

       7
       7
       -
         if verbose then Fmt.kstr (fun s -> prerr_string s; flush stderr) fmt 

     

       8
       8
       -
         else Fmt.kstr (fun _ -> ()) fmt

     

       9
       9
       -
       

     

       10
       10
       -
       (* Initialize a new links.yml file or ensure it exists *)

     

       11
       11
       -
       let init_links_file links_file =

     

       12
       12
       -
         if Sys.file_exists links_file then

     

       13
       13
       -
           print_endline (Fmt.str "Links file %s already exists" links_file)

     

       14
       14
       -
         else begin

     

       15
       15
       -
           (* Create an empty links file *)

     

       16
       16
       -
           Bushel.Link.save_links_file links_file [];

     

       17
       17
       -
           print_endline (Fmt.str "Created empty links file: %s" links_file)

     

       18
       18
       -
         end;

     

       19
       19
       -
         0

     

       20
       20
       -
       

     

       21
       21
       -
       (* Update links.yml from Karakeep *)

     

       22
       22
       -
       let update_from_karakeep base_url api_key_opt tag links_file download_assets =

     

       23
       23
       -
         match api_key_opt with

     

       24
       24
       -
         | None ->

     

       25
       25
       -
             prerr_endline "Error: API key is required.";

     

       26
       26
       -
             prerr_endline "Please provide one with --api-key or create a ~/.karakeep-api file.";

     

       27
       27
       -
             1

     

       28
       28
       -
         | Some api_key ->

     

       29
       29
       -
             let assets_dir = "data/assets" in

     

       30
       30
       -
             

     

       31
       31
       -
             (* Run the Lwt program *)

     

       32
       32
       -
             Lwt_main.run (

     

       33
       33
       -
               print_endline (Fmt.str "Fetching links from %s with tag '%s'..." base_url tag);

     

       34
       34
       -
               

     

       35
       35
       -
               (* Prepare tag filter *)

     

       36
       36
       -
               let filter_tags = if tag = "" then [] else [tag] in

     

       37
       37
       -
               

     

       38
       38
       -
               (* Fetch bookmarks from Karakeep with error handling *)

     

       39
       39
       -
               Lwt.catch

     

       40
       40
       -
                 (fun () ->

     

       41
       41
       -
                   Karakeep.fetch_all_bookmarks ~api_key ~filter_tags base_url >>= fun bookmarks ->

     

       42
       42
       -
                   

     

       43
       43
       -
                   print_endline (Fmt.str "Retrieved %d bookmarks from Karakeep" (List.length bookmarks));

     

       44
       44
       -
                   

     

       45
       45
       -
                   (* Read existing links if file exists *)

     

       46
       46
       -
                   let existing_links = Bushel.Link.load_links_file links_file in

     

       47
       47
       -
                   

     

       48
       48
       -
                   (* Convert bookmarks to bushel links *)

     

       49
       49
       -
                   let new_links = List.map (fun bookmark ->

     

       50
       50
       -
                     Karakeep.to_bushel_link ~base_url bookmark

     

       51
       51
       -
                   ) bookmarks in

     

       52
       52
       -
                   

     

       53
       53
       -
                   (* Merge with existing links - keep existing dates (karakeep dates may be unreliable) *)

     

       54
       54
       -
                   let merged_links = Bushel.Link.merge_links existing_links new_links in

     

       55
       55
       -
                   

     

       56
       56
       -
                   (* Save the updated links file *)

     

       57
       57
       -
                   Bushel.Link.save_links_file links_file merged_links;

     

       58
       58
       -
                   

     

       59
       59
       -
                   print_endline (Fmt.str "Updated %s with %d links" links_file (List.length merged_links));

     

       60
       60
       -
                   

     

       61
       61
       -
                   (* Download assets if requested *)

     

       62
       62
       -
                   if download_assets then begin

     

       63
       63
       -
                     print_endline "Downloading assets for bookmarks...";

     

       64
       64
       -
                     

     

       65
       65
       -
                     (* Ensure the assets directory exists *)

     

       66
       66
       -
                     (try Unix.mkdir assets_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());

     

       67
       67
       -
                     

     

       68
       68
       -
                     (* Process each bookmark with assets *)

     

       69
       69
       -
                     Lwt_list.iter_s (fun bookmark ->

     

       70
       70
       -
                       (* Extract asset IDs from bookmark *)

     

       71
       71
       -
                       let assets = bookmark.Karakeep.assets in

     

       72
       72
       -
                       

     

       73
       73
       -
                       (* Skip if no assets *)

     

       74
       74
       -
                       if assets = [] then

     

       75
       75
       -
                         Lwt.return_unit

     

       76
       76
       -
                       else

     

       77
       77
       -
                         (* Process each asset *)

     

       78
       78
       -
                         Lwt_list.iter_s (fun (asset_id, asset_type) ->

     

       79
       79
       -
                           let asset_dir = Fmt.str "%s/%s" assets_dir asset_id in

     

       80
       80
       -
                           let asset_file = Fmt.str "%s/asset.bin" asset_dir in

     

       81
       81
       -
                           let meta_file = Fmt.str "%s/metadata.json" asset_dir in

     

       82
       82
       -
                           

     

       83
       83
       -
                           (* Skip if the asset already exists *)

     

       84
       84
       -
                           if Sys.file_exists asset_file then

     

       85
       85
       -
                             Lwt.return_unit

     

       86
       86
       -
                           else begin

     

       87
       87
       -
                             (* Create the asset directory *)

     

       88
       88
       -
                             (try Unix.mkdir asset_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());

     

       89
       89
       -
                             

     

       90
       90
       -
                             (* Download the asset *)

     

       91
       91
       -
                             print_endline (Fmt.str "Downloading %s asset %s..." asset_type asset_id);

     

       92
       92
       -
                             Karakeep.fetch_asset ~api_key base_url asset_id >>= fun data ->

     

       93
       93
       -
                             

     

       94
       94
       -
                             (* Guess content type based on first bytes *)

     

       95
       95
       -
                             let content_type = 

     

       96
       96
       -
                               if String.length data >= 4 && String.sub data 0 4 = "\x89PNG" then

     

       97
       97
       -
                                 "image/png"

     

       98
       98
       -
                               else if String.length data >= 3 && String.sub data 0 3 = "\xFF\xD8\xFF" then

     

       99
       99
       -
                                 "image/jpeg"

     

       100
       100
       -
                               else if String.length data >= 4 && String.sub data 0 4 = "%PDF" then

     

       101
       101
       -
                                 "application/pdf"

     

       102
       102
       -
                               else

     

       103
       103
       -
                                 "application/octet-stream"

     

       104
       104
       -
                             in

     

       105
       105
       -
                             

     

       106
       106
       -
                             (* Write the asset data *)

     

       107
       107
       -
                             Lwt_io.with_file ~mode:Lwt_io.Output asset_file (fun oc ->

     

       108
       108
       -
                               Lwt_io.write oc data

     

       109
       109
       -
                             ) >>= fun () ->

     

       110
       110
       -
                             

     

       111
       111
       -
                             (* Write metadata file *)

     

       112
       112
       -
                             let metadata = Fmt.str "{\n  \"contentType\": \"%s\",\n  \"assetType\": \"%s\"\n}" 

     

       113
       113
       -
                               content_type asset_type in

     

       114
       114
       -
                             Lwt_io.with_file ~mode:Lwt_io.Output meta_file (fun oc ->

     

       115
       115
       -
                               Lwt_io.write oc metadata

     

       116
       116
       -
                             )

     

       117
       117
       -
                           end

     

       118
       118
       -
                         ) assets

     

       119
       119
       -
                     ) bookmarks >>= fun () ->

     

       120
       120
       -
                     

     

       121
       121
       -
                     print_endline "Asset download completed.";

     

       122
       122
       -
                     Lwt.return 0

     

       123
       123
       -
                   end else

     

       124
       124
       -
                     Lwt.return 0

     

       125
       125
       -
                 )

     

       126
       126
       -
                 (fun exn ->

     

       127
       127
       -
                   prerr_endline (Fmt.str "Error fetching bookmarks: %s" (Printexc.to_string exn));

     

       128
       128
       -
                   Lwt.return 1

     

       129
       129
       -
                 )

     

       130
       130
       -
             )

     

       131
       131
       -
       

     

       132
       132
       -
       (* Extract outgoing links from Bushel entries *)

     

       133
       133
       -
       let update_from_bushel bushel_dir links_file include_domains exclude_domains =

     

       134
       134
       -
         (* Parse domain filters if provided *)

     

       135
       135
       -
         let include_domains_list = match include_domains with

     

       136
       136
       -
           | None -> []

     

       137
       137
       -
           | Some s -> String.split_on_char ',' s |> List.map String.trim

     

       138
       138
       -
         in

     

       139
       139
       -
         

     

       140
       140
       -
         let exclude_domains_list = match exclude_domains with

     

       141
       141
       -
           | None -> []

     

       142
       142
       -
           | Some s -> String.split_on_char ',' s |> List.map String.trim

     

       143
       143
       -
         in

     

       144
       144
       -
         

     

       145
       145
       -
         (* Show filter settings if any *)

     

       146
       146
       -
         if include_domains_list <> [] then

     

       147
       147
       -
           print_endline (Fmt.str "Including only domains: %s" (String.concat ", " include_domains_list));

     

       148
       148
       -
         

     

       149
       149
       -
         if exclude_domains_list <> [] then

     

       150
       150
       -
           print_endline (Fmt.str "Excluding domains: %s" (String.concat ", " exclude_domains_list));

     

       151
       151
       -
         

     

       152
       152
       -
         (* Load all entries from the bushel directory *)

     

       153
       153
       -
         let notes_dir = Filename.concat bushel_dir "data/notes" in

     

       154
       154
       -
         

     

       155
       155
       -
         (* Make sure the notes directory exists *)

     

       156
       156
       -
         if not (Sys.file_exists notes_dir) then begin

     

       157
       157
       -
           prerr_endline (Fmt.str "Error: Notes directory %s does not exist" notes_dir);

     

       158
       158
       -
           exit 1

     

       159
       159
       -
         end;

     

       160
       160
       -
         

     

       161
       161
       -
         (* Load all entries with fallback *)

     

       162
       162
       -
         print_endline (Fmt.str "Loading entries from %s..." bushel_dir);

     

       163
       163
       -
         

     

       164
       164
       -
         let entries_data = Bushel.load bushel_dir in

     

       165
       165
       -
         let all_entries = Bushel.Entry.all_entries entries_data in

     

       166
       166
       -
         print_endline (Fmt.str "Loaded %d entries" (List.length all_entries));

     

       167
       167
       -
         

     

       168
       168
       -
         (* Extract outgoing links from all entries *)

     

       169
       169
       -
         print_endline "Extracting outgoing links...";

     

       170
       170
       -
         let extracted_links = ref [] in

     

       171
       171
       -
         

     

       172
       172
       -
         (* Process each entry *)

     

       173
       173
       -
         List.iter (fun entry ->

     

       174
       174
       -
           let entry_body = Bushel.Entry.body entry in

     

       175
       175
       -
           let entry_slug = Bushel.Entry.slug entry in

     

       176
       176
       -
           

     

       177
       177
       -
           (* Skip empty bodies *)

     

       178
       178
       -
           if entry_body <> "" then begin

     

       179
       179
       -
             let links = Bushel.Entry.extract_external_links entry_body in

     

       180
       180
       -
             if links <> [] then begin

     

       181
       181
       -
               (* Add each link from this entry *)

     

       182
       182
       -
               List.iter (fun url ->

     

       183
       183
       -
                 (* Try to extract domain from URL *)

     

       184
       184
       -
                 let domain = 

     

       185
       185
       -
                   try

     

       186
       186
       -
                     let uri = Uri.of_string url in

     

       187
       187
       -
                     match Uri.host uri with

     

       188
       188
       -
                     | Some host -> host

     

       189
       189
       -
                     | None -> "unknown"

     

       190
       190
       -
                   with _ -> "unknown"

     

       191
       191
       -
                 in

     

       192
       192
       -
                 

     

       193
       193
       -
                 (* Filter by domain if filters are specified *)

     

       194
       194
       -
                 let include_by_domain =

     

       195
       195
       -
                   if include_domains_list <> [] then

     

       196
       196
       -
                     List.exists (fun filter -> 

     

       197
       197
       -
                       domain = filter || String.ends_with ~suffix:filter domain

     

       198
       198
       -
                     ) include_domains_list

     

       199
       199
       -
                   else true

     

       200
       200
       -
                 in

     

       201
       201
       -
                 

     

       202
       202
       -
                 let exclude_by_domain =

     

       203
       203
       -
                   List.exists (fun filter -> 

     

       204
       204
       -
                     domain = filter || String.ends_with ~suffix:filter domain

     

       205
       205
       -
                   ) exclude_domains_list

     

       206
       206
       -
                 in

     

       207
       207
       -
                 

     

       208
       208
       -
                 if include_by_domain && not exclude_by_domain then begin

     

       209
       209
       -
                   let date = Bushel.Entry.date entry in

     

       210
       210
       -
                   

     

       211
       211
       -
                   (* Extract tags from the entry *)

     

       212
       212
       -
                   let entry_tags = Bushel.Tags.tags_of_ent entries_data entry in

     

       213
       213
       -
                   let tag_strings = List.map Bushel.Tags.to_string entry_tags in

     

       214
       214
       -
                   

     

       215
       215
       -
                   let link = { 

     

       216
       216
       -
                     Bushel.Link.url; 

     

       217
       217
       -
                     date; 

     

       218
       218
       -
                     description = ""; 

     

       219
       219
       -
                     karakeep = None;

     

       220
       220
       -
                     bushel = Some { 

     

       221
       221
       -
                       Bushel.Link.slugs = [entry_slug]; 

     

       222
       222
       -
                       tags = tag_strings 

     

       223
       223
       -
                     };

     

       224
       224
       -
                   } in

     

       225
       225
       -
                   extracted_links := link :: !extracted_links

     

       226
       226
       -
                 end

     

       227
       227
       -
               ) links

     

       228
       228
       -
             end

     

       229
       229
       -
           end

     

       230
       230
       -
         ) all_entries;

     

       231
       231
       -
         

     

       232
       232
       -
         (* Load existing links *)

     

       233
       233
       -
         let existing_links = Bushel.Link.load_links_file links_file in

     

       234
       234
       -
         

     

       235
       235
       -
         (* Merge with existing links - prefer bushel entry dates *)

     

       236
       236
       -
         let merged_links = Bushel.Link.merge_links ~prefer_new_date:true existing_links !extracted_links in

     

       237
       237
       -
         

     

       238
       238
       -
         (* Save the updated links file *)

     

       239
       239
       -
         Bushel.Link.save_links_file links_file merged_links;

     

       240
       240
       -
         

     

       241
       241
       -
         print_endline (Fmt.str "Added %d extracted links from Bushel to %s" 

     

       242
       242
       -
           (List.length !extracted_links) links_file);

     

       243
       243
       -
         print_endline (Fmt.str "Total links in file: %d" (List.length merged_links));

     

       244
       244
       -
         0

     

       245
       245
       -
       

     

       246
       246
       -
       (* Helper function to filter links that don't have karakeep data for a specific remote *)

     

       247
       247
       -
       let filter_links_without_karakeep base_url links =

     

       248
       248
       -
         List.filter (fun link ->

     

       249
       249
       -
           match link.Bushel.Link.karakeep with

     

       250
       250
       -
           | Some { remote_url; _ } when remote_url = base_url -> false

     

       251
       251
       -
           | _ -> true

     

       252
       252
       -
         ) links

     

       253
       253
       -
       

     

       254
       254
       -
       (* Helper function to apply limit to links if specified *)

     

       255
       255
       -
       let apply_limit_to_links limit links =

     

       256
       256
       -
         match limit with

     

       257
       257
       -
         | Some n when n > 0 -> 

     

       258
       258
       -
             let rec take_n acc count = function

     

       259
       259
       -
               | [] -> List.rev acc

     

       260
       260
       -
               | _ when count = 0 -> List.rev acc

     

       261
       261
       -
               | x :: xs -> take_n (x :: acc) (count - 1) xs

     

       262
       262
       -
             in

     

       263
       263
       -
             let limited = take_n [] n links in

     

       264
       264
       -
             if List.length links > n then

     

       265
       265
       -
               log "Limited to first %d links (out of %d available)\n" n (List.length links);

     

       266
       266
       -
             limited

     

       267
       267
       -
         | _ -> links

     

       268
       268
       -
       

     

       269
       269
       -
       (* Helper function to prepare tags for a link *)

     

       270
       270
       -
       let prepare_tags_for_link tag link =

     

       271
       271
       -
         let slug_tags = 

     

       272
       272
       -
           match link.Bushel.Link.bushel with

     

       273
       273
       -
           | Some { slugs; _ } -> List.map (fun slug -> "bushel:" ^ slug) slugs

     

       274
       274
       -
           | None -> []

     

       275
       275
       -
         in

     

       276
       276
       -
         if tag = "" then slug_tags

     

       277
       277
       -
         else tag :: slug_tags

     

       278
       278
       -
       

     

       279
       279
       -
       (* Helper function to create batches for parallel processing *)

     

       280
       280
       -
       let create_batches max_concurrent links =

     

       281
       281
       -
         let rec create_batches_aux links acc =

     

       282
       282
       -
           match links with

     

       283
       283
       -
           | [] -> List.rev acc

     

       284
       284
       -
           | _ ->

     

       285
       285
       -
               let batch, rest = 

     

       286
       286
       -
                 if List.length links <= max_concurrent then

     

       287
       287
       -
                   links, []

     

       288
       288
       -
                 else

     

       289
       289
       -
                   let rec take n lst batch =

     

       290
       290
       -
                     if n = 0 || lst = [] then List.rev batch, lst

     

       291
       291
       -
                     else take (n-1) (List.tl lst) (List.hd lst :: batch)

     

       292
       292
       -
                   in

     

       293
       293
       -
                   take max_concurrent links []

     

       294
       294
       -
               in

     

       295
       295
       -
               create_batches_aux rest (batch :: acc)

     

       296
       296
       -
         in

     

       297
       297
       -
         create_batches_aux links []

     

       298
       298
       -
       

     

       299
       299
       -
       (* Helper function to upload a single link to Karakeep *)

     

       300
       300
       -
       let upload_single_link api_key base_url tag verbose updated_links link =

     

       301
       301
       -
         let url = link.Bushel.Link.url in

     

       302
       302
       -
         let title = 

     

       303
       303
       -
           if link.Bushel.Link.description <> "" then 

     

       304
       304
       -
             Some link.Bushel.Link.description 

     

       305
       305
       -
           else None 

     

       306
       306
       -
         in

     

       307
       307
       -
         let tags = prepare_tags_for_link tag link in

     

       308
       308
       -
         

     

       309
       309
       -
         if verbose then begin

     

       310
       310
       -
           log "  Uploading: %s\n" url;

     

       311
       311
       -
           if tags <> [] then 

     

       312
       312
       -
             log "    Tags: %s\n" (String.concat ", " tags);

     

       313
       313
       -
           if title <> None then 

     

       314
       314
       -
             log "    Title: %s\n" (Option.get title);

     

       315
       315
       -
         end else begin

     

       316
       316
       -
           log "Uploading: %s\n" url;

     

       317
       317
       -
         end;

     

       318
       318
       -
         

     

       319
       319
       -
         (* Create the bookmark with tags *)

     

       320
       320
       -
         Lwt.catch

     

       321
       321
       -
           (fun () ->

     

       322
       322
       -
             Karakeep.create_bookmark 

     

       323
       323
       -
               ~api_key 

     

       324
       324
       -
               ~url 

     

       325
       325
       -
               ?title 

     

       326
       326
       -
               ~tags 

     

       327
       327
       -
               base_url 

     

       328
       328
       -
             >>= fun bookmark ->

     

       329
       329
       -
             

     

       330
       330
       -
             (* Create updated link with karakeep data *)

     

       331
       331
       -
             let updated_link = {

     

       332
       332
       -
               link with 

     

       333
       333
       -
               Bushel.Link.karakeep = 

     

       334
       334
       -
                 Some { 

     

       335
       335
       -
                   Bushel.Link.remote_url = base_url; 

     

       336
       336
       -
                   id = bookmark.id;

     

       337
       337
       -
                   tags = bookmark.tags;

     

       338
       338
       -
                   metadata = [];  (* Will be populated on next sync *)

     

       339
       339
       -
                 }

     

       340
       340
       -
             } in

     

       341
       341
       -
             updated_links := updated_link :: !updated_links;

     

       342
       342
       -
             

     

       343
       343
       -
             if verbose then

     

       344
       344
       -
               log "    ✓ Added to Karakeep with ID: %s\n" bookmark.id

     

       345
       345
       -
             else

     

       346
       346
       -
               log "  - Added to Karakeep with ID: %s\n" bookmark.id;

     

       347
       347
       -
             Lwt.return 1 (* Success *)

     

       348
       348
       -
           )

     

       349
       349
       -
           (fun exn ->

     

       350
       350
       -
             if verbose then

     

       351
       351
       -
               log "    ✗ Error uploading %s: %s\n" url (Printexc.to_string exn)

     

       352
       352
       -
             else

     

       353
       353
       -
               log "  - Error uploading %s: %s\n" url (Printexc.to_string exn);

     

       354
       354
       -
             Lwt.return 0 (* Failure *)

     

       355
       355
       -
           )

     

       356
       356
       -
       

     

       357
       357
       -
       (* Helper function to process a batch of links *)

     

       358
       358
       -
       let process_batch api_key base_url tag verbose updated_links batch_num total_batches batch =

     

       359
       359
       -
         log_verbose verbose "\nProcessing batch %d/%d (%d links)...\n" 

     

       360
       360
       -
           (batch_num + 1) total_batches (List.length batch);

     

       361
       361
       -
         

     

       362
       362
       -
         (* Process links in this batch concurrently *)

     

       363
       363
       -
         Lwt_list.map_p (upload_single_link api_key base_url tag verbose updated_links) batch

     

       364
       364
       -
       

     

       365
       365
       -
       (* Helper function to update links file with new karakeep data *)

     

       366
       366
       -
       let update_links_file links_file original_links updated_links =

     

       367
       367
       -
         if !updated_links <> [] then begin

     

       368
       368
       -
           (* Replace the updated links in the original list *)

     

       369
       369
       -
           let final_links =

     

       370
       370
       -
             List.map (fun link ->

     

       371
       371
       -
               let url = link.Bushel.Link.url in

     

       372
       372
       -
               let updated = List.find_opt (fun ul -> ul.Bushel.Link.url = url) !updated_links in

     

       373
       373
       -
               match updated with

     

       374
       374
       -
               | Some ul -> ul

     

       375
       375
       -
               | None -> link

     

       376
       376
       -
             ) original_links

     

       377
       377
       -
           in

     

       378
       378
       -
           

     

       379
       379
       -
           (* Save the updated links file *)

     

       380
       380
       -
           Bushel.Link.save_links_file links_file final_links;

     

       381
       381
       -
           

     

       382
       382
       -
           log "Updated %s with %d new karakeep_ids\n" 

     

       383
       383
       -
             links_file (List.length !updated_links);

     

       384
       384
       -
         end

     

       385
       385
       -
       

     

       386
       386
       -
       (* Upload links to Karakeep that don't already have karakeep data *)

     

       387
       387
       -
       let upload_to_karakeep base_url api_key_opt links_file tag max_concurrent delay_seconds limit verbose =

     

       388
       388
       -
         match api_key_opt with

     

       389
       389
       -
         | None ->

     

       390
       390
       -
             log "Error: API key is required.\n";

     

       391
       391
       -
             log "Please provide one with --api-key or create a ~/.karakeep-api file.\n";

     

       392
       392
       -
             1

     

       393
       393
       -
         | Some api_key ->

     

       394
       394
       -
             (* Load links from file *)

     

       395
       395
       -
             log_verbose verbose "Loading links from %s...\n" links_file;

     

       396
       396
       -
             let links = Bushel.Link.load_links_file links_file in

     

       397
       397
       -
             log_verbose verbose "Loaded %d total links\n" (List.length links);

     

       398
       398
       -
             

     

       399
       399
       -
             (* Filter links that don't have karakeep data for this remote *)

     

       400
       400
       -
             log_verbose verbose "Filtering links that don't have karakeep data for %s...\n" base_url;

     

       401
       401
       -
             let filtered_links = filter_links_without_karakeep base_url links in

     

       402
       402
       -
             log_verbose verbose "Found %d links without karakeep data\n" (List.length filtered_links);

     

       403
       403
       -
             

     

       404
       404
       -
             (* Apply limit if specified *)

     

       405
       405
       -
             let links_to_upload = apply_limit_to_links limit filtered_links in

     

       406
       406
       -
         

     

       407
       407
       -
             if links_to_upload = [] then begin

     

       408
       408
       -
               log "No links to upload to %s (all links already have karakeep data)\n" base_url;

     

       409
       409
       -
               0

     

       410
       410
       -
             end else begin

     

       411
       411
       -
               log "Found %d links to upload to %s\n" (List.length links_to_upload) base_url;

     

       412
       412
       -
               

     

       413
       413
       -
               (* Split links into batches for parallel processing *)

     

       414
       414
       -
               let batches = create_batches max_concurrent links_to_upload in

     

       415
       415
       -
               log_verbose verbose "Processing in %d batches of up to %d links each...\n" 

     

       416
       416
       -
                 (List.length batches) max_concurrent;

     

       417
       417
       -
               log_verbose verbose "Delay between batches: %.1f seconds\n" delay_seconds;

     

       418
       418
       -
               

     

       419
       419
       -
               (* Process batches and accumulate updated links *)

     

       420
       420
       -
               let updated_links = ref [] in

     

       421
       421
       -
               

     

       422
       422
       -
               let result = Lwt_main.run (

     

       423
       423
       -
                 Lwt.catch

     

       424
       424
       -
                   (fun () ->

     

       425
       425
       -
                     Lwt_list.fold_left_s (fun (total_count, batch_num) batch ->

     

       426
       426
       -
                       process_batch api_key base_url tag verbose updated_links 

     

       427
       427
       -
                         batch_num (List.length batches) batch >>= fun results ->

     

       428
       428
       -
                       

     

       429
       429
       -
                       (* Count successes in this batch *)

     

       430
       430
       -
                       let batch_successes = List.fold_left (+) 0 results in

     

       431
       431
       -
                       let new_total = total_count + batch_successes in

     

       432
       432
       -
                       

     

       433
       433
       -
                       log_verbose verbose "  Batch %d complete: %d/%d successful (Total: %d/%d)\n" 

     

       434
       434
       -
                         (batch_num + 1) batch_successes (List.length batch) new_total (new_total + (List.length links_to_upload - new_total));

     

       435
       435
       -
                       

     

       436
       436
       -
                       (* Add a delay before processing the next batch *)

     

       437
       437
       -
                       if batch_num + 1 < List.length batches then begin

     

       438
       438
       -
                         log_verbose verbose "  Waiting %.1f seconds before next batch...\n" delay_seconds;

     

       439
       439
       -
                         Lwt_unix.sleep delay_seconds >>= fun () ->

     

       440
       440
       -
                         Lwt.return (new_total, batch_num + 1)

     

       441
       441
       -
                       end else

     

       442
       442
       -
                         Lwt.return (new_total, batch_num + 1)

     

       443
       443
       -
                     ) (0, 0) batches >>= fun (final_count, _) ->

     

       444
       444
       -
                     Lwt.return final_count

     

       445
       445
       -
                   )

     

       446
       446
       -
                   (fun exn ->

     

       447
       447
       -
                     log "Error during upload operation: %s\n" (Printexc.to_string exn);

     

       448
       448
       -
                     Lwt.return 0

     

       449
       449
       -
                   )

     

       450
       450
       -
               ) in

     

       451
       451
       -
               

     

       452
       452
       -
               (* Update the links file with the new karakeep_ids *)

     

       453
       453
       -
               update_links_file links_file links updated_links;

     

       454
       454
       -
               

     

       455
       455
       -
               log "Upload complete. %d/%d links uploaded successfully.\n" 

     

       456
       456
       -
                 result (List.length links_to_upload);

     

       457
       457
       -
               

     

       458
       458
       -
               0

     

       459
       459
       -
             end

     

       460
       460
       -
       

     

       461
       461
       -
       (* Common arguments *)

     

       462
       462
       -
       let links_file_arg =

     

       463
       463
       -
         let doc = "Links YAML file. Defaults to links.yml." in

     

       464
       464
       -
         Arg.(value & opt string "links.yml" & info ["file"; "f"] ~doc ~docv:"FILE")

     

       465
       465
       -
       

     

       466
       466
       -
       let base_url_arg =

     

       467
       467
       -
         let doc = "Base URL of the Karakeep instance" in

     

       468
       468
       -
         let default = "https://hoard.recoil.org" in

     

       469
       469
       -
         Arg.(value & opt string default & info ["url"] ~doc ~docv:"URL")

     

       470
       470
       -
       

     

       471
       471
       -
       let api_key_arg =

     

       472
       472
       -
         let doc = "API key for Karakeep authentication (ak1_<key_id>_<secret>)" in

     

       473
       473
       -
         let get_api_key () =

     

       474
       474
       -
           let home = try Sys.getenv "HOME" with Not_found -> "." in

     

       475
       475
       -
           let key_path = Filename.concat home ".karakeep-api" in

     

       476
       476
       -
           try

     

       477
       477
       -
             let ic = open_in key_path in

     

       478
       478
       -
             let key = input_line ic in

     

       479
       479
       -
             close_in ic;

     

       480
       480
       -
             Some (String.trim key)

     

       481
       481
       -
           with _ -> None

     

       482
       482
       -
         in

     

       483
       483
       -
         Arg.(value & opt (some string) (get_api_key ()) & info ["api-key"] ~doc ~docv:"API_KEY")

     

       484
       484
       -
       

     

       485
       485
       -
       let tag_arg =

     

       486
       486
       -
         let doc = "Tag to filter or apply to bookmarks" in

     

       487
       487
       -
         Arg.(value & opt string "" & info ["tag"; "t"] ~doc ~docv:"TAG")

     

       488
       488
       -
       

     

       489
       489
       -
       let download_assets_arg =

     

       490
       490
       -
         let doc = "Download assets (screenshots, etc.) from Karakeep" in

     

       491
       491
       -
         Arg.(value & flag & info ["download-assets"; "d"] ~doc)

     

       492
       492
       -
       

     

       493
       493
       -
       let base_dir_arg =

     

       494
       494
       -
         let doc = "Base directory of the Bushel project" in

     

       495
       495
       -
         Arg.(value & opt string "." & info ["dir"; "d"] ~doc ~docv:"DIR")

     

       496
       496
       -
       

     

       497
       497
       -
       let include_domains_arg =

     

       498
       498
       -
         let doc = "Only include links to these domains (comma-separated list)" in

     

       499
       499
       -
         Arg.(value & opt (some string) None & info ["include"] ~doc ~docv:"DOMAINS")

     

       500
       500
       -
       

     

       501
       501
       -
       let exclude_domains_arg =

     

       502
       502
       -
         let doc = "Exclude links to these domains (comma-separated list)" in

     

       503
       503
       -
         Arg.(value & opt (some string) None & info ["exclude"] ~doc ~docv:"DOMAINS")

     

       504
       504
       -
       

     

       505
       505
       -
       let concurrent_arg =

     

       506
       506
       -
         let doc = "Maximum number of concurrent uploads (default: 5)" in

     

       507
       507
       -
         Arg.(value & opt int 5 & info ["concurrent"; "c"] ~doc ~docv:"NUM")

     

       508
       508
       -
       

     

       509
       509
       -
       let delay_arg =

     

       510
       510
       -
         let doc = "Delay in seconds between batches (default: 1.0)" in

     

       511
       511
       -
         Arg.(value & opt float 1.0 & info ["delay"] ~doc ~docv:"SECONDS")

     

       512
       512
       -
       

     

       513
       513
       -
       let limit_arg =

     

       514
       514
       -
         let doc = "Limit number of links to upload (for testing)" in

     

       515
       515
       -
         Arg.(value & opt (some int) None & info ["limit"; "l"] ~doc ~docv:"NUM")

     

       516
       516
       -
       

     

       517
       517
       -
       let verbose_arg =

     

       518
       518
       -
         let doc = "Show detailed progress information during upload" in

     

       519
       519
       -
         Arg.(value & flag & info ["verbose"; "v"] ~doc)

     

       520
       520
       -
       

     

       521
       521
       -
       (* Command definitions *)

     

       522
       522
       -
       let init_cmd =

     

       523
       523
       -
         let doc = "Initialize a new links.yml file" in

     

       524
       524
       -
         let info = Cmd.info "init" ~doc in

     

       525
       525
       -
         Cmd.v info Term.(const init_links_file $ links_file_arg)

     

       526
       526
       -
       

     

       527
       527
       -
       let karakeep_cmd =

     

       528
       528
       -
         let doc = "Update links.yml with links from Karakeep" in

     

       529
       529
       -
         let info = Cmd.info "karakeep" ~doc in

     

       530
       530
       -
         Cmd.v info Term.(const update_from_karakeep $ base_url_arg $ api_key_arg $ tag_arg $ links_file_arg $ download_assets_arg)

     

       531
       531
       -
       

     

       532
       532
       -
       let bushel_cmd =

     

       533
       533
       -
         let doc = "Update links.yml with outgoing links from Bushel entries" in

     

       534
       534
       -
         let info = Cmd.info "bushel" ~doc in

     

       535
       535
       -
         Cmd.v info Term.(const update_from_bushel $ base_dir_arg $ links_file_arg $ include_domains_arg $ exclude_domains_arg)

     

       536
       536
       -
       

     

       537
       537
       -
       let upload_cmd =

     

       538
       538
       -
         let doc = "Upload links without karakeep data to Karakeep" in

     

       539
       539
       -
         let info = Cmd.info "upload" ~doc in

     

       540
       540
       -
         Cmd.v info Term.(const upload_to_karakeep $ base_url_arg $ api_key_arg $ links_file_arg $ tag_arg $ concurrent_arg $ delay_arg $ limit_arg $ verbose_arg)

     

       541
       541
       -
       

     

       542
       542
       -
       (* Export the term and cmd for use in main bushel.ml *)

     

       543
       543
       -
       let cmd =

     

       544
       544
       -
         let doc = "Manage links between Bushel and Karakeep" in

     

       545
       545
       -
         let info = Cmd.info "links" ~doc in

     

       546
       546
       -
         Cmd.group info [init_cmd; karakeep_cmd; bushel_cmd; upload_cmd]

     

       547
       547
       -
       

     

       548
       548
       -
       (* For standalone execution *)

     

       549
       549
       -
       (* Main entry point removed - accessed through bushel_main.ml *)

-119

stack/bushel/bin/bushel_main.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       

     

       3
       3
       -
       let version = "0.1.0"

     

       4
       4
       -
       

     

       5
       5
       -
       (* Import actual command implementations from submodules *)

     

       6
       6
       -
       

     

       7
       7
       -
       (* Obsidian command - no API keys needed *)

     

       8
       8
       -
       let obsidian_cmd =

     

       9
       9
       -
         let doc = "Convert Bushel entries to Obsidian format" in

     

       10
       10
       -
         Eiocmd.run

     

       11
       11
       -
           ~use_keyeio:false

     

       12
       12
       -
           ~info:(Cmd.info "obsidian" ~version ~doc)

     

       13
       13
       -
           ~app_name:"bushel"

     

       14
       14
       -
           ~service:"bushel"

     

       15
       15
       -
           Bushel_obsidian.term

     

       16
       16
       -
       

     

       17
       17
       -
       (* Paper classify command *)

     

       18
       18
       -
       let paper_classify_cmd = Bushel_paper_classify.cmd

     

       19
       19
       -
       

     

       20
       20
       -
       (* Paper tex command *)

     

       21
       21
       -
       let paper_tex_cmd = Bushel_paper_tex.cmd

     

       22
       22
       -
       

     

       23
       23
       -
       (* Thumbs command - no API keys needed *)

     

       24
       24
       -
       let thumbs_cmd =

     

       25
       25
       -
         let doc = "Generate thumbnails from paper PDFs" in

     

       26
       26
       -
         Eiocmd.run

     

       27
       27
       -
           ~use_keyeio:false

     

       28
       28
       -
           ~info:(Cmd.info "thumbs" ~version ~doc)

     

       29
       29
       -
           ~app_name:"bushel"

     

       30
       30
       -
           ~service:"bushel"

     

       31
       31
       -
           Bushel_thumbs.term

     

       32
       32
       -
       

     

       33
       33
       -
       (* Query command - needs Typesense API key *)

     

       34
       34
       -
       let query_cmd =

     

       35
       35
       -
         let doc = "Query Bushel collections using multisearch" in

     

       36
       36
       -
         Eiocmd.run

     

       37
       37
       -
           ~use_keyeio:true

     

       38
       38
       -
           ~info:(Cmd.info "query" ~version ~doc)

     

       39
       39
       -
           ~app_name:"bushel"

     

       40
       40
       -
           ~service:"bushel"

     

       41
       41
       -
           Bushel_search.term

     

       42
       42
       -
       

     

       43
       43
       -
       (* Bibtex command - no API keys needed *)

     

       44
       44
       -
       let bibtex_cmd =

     

       45
       45
       -
         let doc = "Export bibtex for all papers" in

     

       46
       46
       -
         Eiocmd.run

     

       47
       47
       -
           ~use_keyeio:false

     

       48
       48
       -
           ~info:(Cmd.info "bibtex" ~version ~doc)

     

       49
       49
       -
           ~app_name:"bushel"

     

       50
       50
       -
           ~service:"bushel"

     

       51
       51
       -
           Bushel_bibtex.term

     

       52
       52
       -
       

     

       53
       53
       -
       (* Ideas command *)

     

       54
       54
       -
       let ideas_cmd = Bushel_ideas.cmd

     

       55
       55
       -
       

     

       56
       56
       -
       (* Info command - no API keys needed *)

     

       57
       57
       -
       let info_cmd =

     

       58
       58
       -
         let doc = "Display all information for a given slug" in

     

       59
       59
       -
         Eiocmd.run

     

       60
       60
       -
           ~use_keyeio:false

     

       61
       61
       -
           ~info:(Cmd.info "info" ~version ~doc)

     

       62
       62
       -
           ~app_name:"bushel"

     

       63
       63
       -
           ~service:"bushel"

     

       64
       64
       -
           Bushel_info.term

     

       65
       65
       -
       

     

       66
       66
       -
       (* Missing command - no API keys needed *)

     

       67
       67
       -
       let missing_cmd =

     

       68
       68
       -
         let doc = "Check for missing metadata in entries" in

     

       69
       69
       -
         Eiocmd.run

     

       70
       70
       -
           ~use_keyeio:false

     

       71
       71
       -
           ~info:(Cmd.info "missing" ~version ~doc)

     

       72
       72
       -
           ~app_name:"bushel"

     

       73
       73
       -
           ~service:"bushel"

     

       74
       74
       -
           Bushel_missing.term

     

       75
       75
       -
       

     

       76
       76
       -
       (* Note DOI command - no API keys needed *)

     

       77
       77
       -
       let note_doi_cmd =

     

       78
       78
       -
         let doc = "Assign DOIs to notes with perma:true" in

     

       79
       79
       -
         Eiocmd.run

     

       80
       80
       -
           ~use_keyeio:false

     

       81
       81
       -
           ~info:(Cmd.info "note-doi" ~version ~doc)

     

       82
       82
       -
           ~app_name:"bushel"

     

       83
       83
       -
           ~service:"bushel"

     

       84
       84
       -
           Bushel_note_doi.term

     

       85
       85
       -
       

     

       86
       86
       -
       (* Main command *)

     

       87
       87
       -
       let bushel_cmd =

     

       88
       88
       -
         let doc = "Bushel content management toolkit" in

     

       89
       89
       -
         let sdocs = Manpage.s_common_options in

     

       90
       90
       -
         let man = [

     

       91
       91
       -
           `S Manpage.s_description;

     

       92
       92
       -
           `P "$(tname) is a unified command-line tool for managing various types of \

     

       93
       93
       -
               content in the Bushel system, including papers, videos, links, and more.";

     

       94
       94
       -
           `P "$(tname) provides unified access to all Bushel functionality through \

     

       95
       95
       -
               integrated subcommands.";

     

       96
       96
       -
           `S Manpage.s_commands;

     

       97
       97
       -
           `S Manpage.s_common_options;

     

       98
       98
       -
           `S "ENVIRONMENT";

     

       99
       99
       -
           `P "BUSHEL_CONFIG - Path to configuration file with default settings";

     

       100
       100
       -
           `S Manpage.s_authors;

     

       101
       101
       -
           `P "Anil Madhavapeddy";

     

       102
       102
       -
           `S Manpage.s_bugs;

     

       103
       103
       -
           `P "Report bugs at https://github.com/avsm/bushel/issues";

     

       104
       104
       -
         ] in

     

       105
       105
       -
         let info = Cmd.info "bushel" ~version ~doc ~sdocs ~man in

     

       106
       106
       -
         Cmd.group info [

     

       107
       107
       -
           bibtex_cmd;

     

       108
       108
       -
           ideas_cmd;

     

       109
       109
       -
           info_cmd;

     

       110
       110
       -
           missing_cmd;

     

       111
       111
       -
           note_doi_cmd;

     

       112
       112
       -
           obsidian_cmd;

     

       113
       113
       -
           paper_classify_cmd;

     

       114
       114
       -
           paper_tex_cmd;

     

       115
       115
       -
           query_cmd;

     

       116
       116
       -
           thumbs_cmd;

     

       117
       117
       -
         ]

     

       118
       118
       -
       

     

       119
       119
       -
       let () = exit (Cmd.eval' bushel_cmd)

-186

stack/bushel/bin/bushel_missing.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       open Bushel

     

       3
       3
       -
       

     

       4
       4
       -
       (** Check if an entry has a thumbnail *)

     

       5
       5
       -
       let has_thumbnail entries entry =

     

       6
       6
       -
         match Entry.thumbnail_slug entries entry with

     

       7
       7
       -
         | Some _ -> true

     

       8
       8
       -
         | None -> false

     

       9
       9
       -
       

     

       10
       10
       -
       (** Check if an entry has a synopsis or description *)

     

       11
       11
       -
       let has_synopsis = function

     

       12
       12
       -
         | `Paper p -> Paper.abstract p <> ""  (* Papers have abstracts *)

     

       13
       13
       -
         | `Note n -> Note.synopsis n <> None  (* Notes have optional synopsis *)

     

       14
       14
       -
         | `Idea _ -> true  (* Ideas don't have synopsis field *)

     

       15
       15
       -
         | `Project _ -> true  (* Projects don't have synopsis field *)

     

       16
       16
       -
         | `Video _ -> true  (* Videos don't have synopsis field *)

     

       17
       17
       -
       

     

       18
       18
       -
       (** Check if an entry has tags *)

     

       19
       19
       -
       let has_tags = function

     

       20
       20
       -
         | `Paper p -> Paper.tags p <> []

     

       21
       21
       -
         | `Note n -> Note.tags n <> []

     

       22
       22
       -
         | `Idea i -> i.Idea.tags <> []  (* Access record field directly *)

     

       23
       23
       -
         | `Project p -> Project.tags p <> []

     

       24
       24
       -
         | `Video v -> v.Video.tags <> []  (* Access record field directly *)

     

       25
       25
       -
       

     

       26
       26
       -
       (** Entry with broken references *)

     

       27
       27
       -
       type entry_with_broken_refs = {

     

       28
       28
       -
         entry : Entry.entry;

     

       29
       29
       -
         broken_slugs : string list;

     

       30
       30
       -
         broken_contacts : string list;

     

       31
       31
       -
       }

     

       32
       32
       -
       

     

       33
       33
       -
       (** Find entries missing thumbnails *)

     

       34
       34
       -
       let find_missing_thumbnails entries =

     

       35
       35
       -
         let all = Entry.all_entries entries in

     

       36
       36
       -
         List.filter (fun entry -> not (has_thumbnail entries entry)) all

     

       37
       37
       -
       

     

       38
       38
       -
       (** Find entries missing synopsis *)

     

       39
       39
       -
       let find_missing_synopsis entries =

     

       40
       40
       -
         let all = Entry.all_entries entries in

     

       41
       41
       -
         List.filter (fun entry -> not (has_synopsis entry)) all

     

       42
       42
       -
       

     

       43
       43
       -
       (** Find entries missing tags *)

     

       44
       44
       -
       let find_missing_tags entries =

     

       45
       45
       -
         let all = Entry.all_entries entries in

     

       46
       46
       -
         List.filter (fun entry -> not (has_tags entry)) all

     

       47
       47
       -
       

     

       48
       48
       -
       (** Find entries with broken slugs or contact handles *)

     

       49
       49
       -
       let find_broken_references entries =

     

       50
       50
       -
         let all = Entry.all_entries entries in

     

       51
       51
       -
         List.filter_map (fun entry ->

     

       52
       52
       -
           let body = Entry.body entry in

     

       53
       53
       -
           let broken_slugs, broken_contacts = Md.validate_references entries body in

     

       54
       54
       -
           if broken_slugs <> [] || broken_contacts <> [] then

     

       55
       55
       -
             Some { entry; broken_slugs; broken_contacts }

     

       56
       56
       -
           else

     

       57
       57
       -
             None

     

       58
       58
       -
         ) all

     

       59
       59
       -
       

     

       60
       60
       -
       (** Print a list of entries *)

     

       61
       61
       -
       let print_entries title entries_list =

     

       62
       62
       -
         if entries_list <> [] then begin

     

       63
       63
       -
           Fmt.pr "@.%a (%d):@," (Fmt.styled `Bold Fmt.string) title (List.length entries_list);

     

       64
       64
       -
           List.iter (fun entry ->

     

       65
       65
       -
             let slug = Entry.slug entry in

     

       66
       66
       -
             let type_str = Entry.to_type_string entry in

     

       67
       67
       -
             let title = Entry.title entry in

     

       68
       68
       -
             Fmt.pr "  %a %a - %a@,"

     

       69
       69
       -
               (Fmt.styled `Cyan Fmt.string) slug

     

       70
       70
       -
               (Fmt.styled `Faint Fmt.string) (Printf.sprintf "(%s)" type_str)

     

       71
       71
       -
               Fmt.string title

     

       72
       72
       -
           ) entries_list

     

       73
       73
       -
         end

     

       74
       74
       -
       

     

       75
       75
       -
       (** Print entries with broken references *)

     

       76
       76
       -
       let print_broken_references title entries_with_broken_refs =

     

       77
       77
       -
         if entries_with_broken_refs <> [] then begin

     

       78
       78
       -
           Fmt.pr "@.%a (%d):@," (Fmt.styled `Bold Fmt.string) title (List.length entries_with_broken_refs);

     

       79
       79
       -
           List.iter (fun { entry; broken_slugs; broken_contacts } ->

     

       80
       80
       -
             let slug = Entry.slug entry in

     

       81
       81
       -
             let type_str = Entry.to_type_string entry in

     

       82
       82
       -
             let entry_title = Entry.title entry in

     

       83
       83
       -
             Fmt.pr "  %a %a - %a@,"

     

       84
       84
       -
               (Fmt.styled `Cyan Fmt.string) slug

     

       85
       85
       -
               (Fmt.styled `Faint Fmt.string) (Printf.sprintf "(%s)" type_str)

     

       86
       86
       -
               Fmt.string entry_title;

     

       87
       87
       -
             if broken_slugs <> [] then

     

       88
       88
       -
               Fmt.pr "    %a %a@,"

     

       89
       89
       -
                 (Fmt.styled `Red Fmt.string) "Broken slugs:"

     

       90
       90
       -
                 (Fmt.list ~sep:Fmt.comma Fmt.string) broken_slugs;

     

       91
       91
       -
             if broken_contacts <> [] then

     

       92
       92
       -
               Fmt.pr "    %a %a@,"

     

       93
       93
       -
                 (Fmt.styled `Red Fmt.string) "Broken contacts:"

     

       94
       94
       -
                 (Fmt.list ~sep:Fmt.comma Fmt.string) broken_contacts;

     

       95
       95
       -
           ) entries_with_broken_refs

     

       96
       96
       -
         end

     

       97
       97
       -
       

     

       98
       98
       -
       (** Main missing command implementation *)

     

       99
       99
       -
       let missing_cmd base_dir check_thumbnails check_synopsis check_tags check_refs _env _xdg _profile =

     

       100
       100
       -
         let entries = load base_dir in

     

       101
       101
       -
       

     

       102
       102
       -
         let count = ref 0 in

     

       103
       103
       -
       

     

       104
       104
       -
         if check_thumbnails then begin

     

       105
       105
       -
           let missing = find_missing_thumbnails entries in

     

       106
       106
       -
           print_entries "Entries missing thumbnails" missing;

     

       107
       107
       -
           count := !count + List.length missing

     

       108
       108
       -
         end;

     

       109
       109
       -
       

     

       110
       110
       -
         if check_synopsis then begin

     

       111
       111
       -
           let missing = find_missing_synopsis entries in

     

       112
       112
       -
           print_entries "Entries missing synopsis" missing;

     

       113
       113
       -
           count := !count + List.length missing

     

       114
       114
       -
         end;

     

       115
       115
       -
       

     

       116
       116
       -
         if check_tags then begin

     

       117
       117
       -
           let missing = find_missing_tags entries in

     

       118
       118
       -
           print_entries "Entries missing tags" missing;

     

       119
       119
       -
           count := !count + List.length missing

     

       120
       120
       -
         end;

     

       121
       121
       -
       

     

       122
       122
       -
         if check_refs then begin

     

       123
       123
       -
           let broken = find_broken_references entries in

     

       124
       124
       -
           print_broken_references "Entries with broken references" broken;

     

       125
       125
       -
           (* Count total number of broken references, not just entries *)

     

       126
       126
       -
           let broken_count = List.fold_left (fun acc { broken_slugs; broken_contacts; _ } ->

     

       127
       127
       -
             acc + List.length broken_slugs + List.length broken_contacts

     

       128
       128
       -
           ) 0 broken in

     

       129
       129
       -
           count := !count + broken_count

     

       130
       130
       -
         end;

     

       131
       131
       -
       

     

       132
       132
       -
         if !count = 0 then

     

       133
       133
       -
           Fmt.pr "@.No missing metadata or broken references found.@."

     

       134
       134
       -
         else

     

       135
       135
       -
           Fmt.pr "@.Total issues found: %d@." !count;

     

       136
       136
       -
       

     

       137
       137
       -
         0

     

       138
       138
       -
       

     

       139
       139
       -
       (** Command line arguments *)

     

       140
       140
       -
       let thumbnails_flag =

     

       141
       141
       -
         let doc = "Check for entries missing thumbnails" in

     

       142
       142
       -
         Arg.(value & flag & info ["thumbnails"; "t"] ~doc)

     

       143
       143
       -
       

     

       144
       144
       -
       let synopsis_flag =

     

       145
       145
       -
         let doc = "Check for entries missing synopsis" in

     

       146
       146
       -
         Arg.(value & flag & info ["synopsis"; "s"] ~doc)

     

       147
       147
       -
       

     

       148
       148
       -
       let tags_flag =

     

       149
       149
       -
         let doc = "Check for entries missing tags" in

     

       150
       150
       -
         Arg.(value & flag & info ["tags"; "g"] ~doc)

     

       151
       151
       -
       

     

       152
       152
       -
       let refs_flag =

     

       153
       153
       -
         let doc = "Check for broken slugs and contact handles" in

     

       154
       154
       -
         Arg.(value & flag & info ["refs"; "r"] ~doc)

     

       155
       155
       -
       

     

       156
       156
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       157
       157
       -
         Term.(const (fun base thumbnails synopsis tags refs env xdg profile ->

     

       158
       158
       -
           (* If no flags specified, check everything *)

     

       159
       159
       -
           let check_all = not (thumbnails || synopsis || tags || refs) in

     

       160
       160
       -
           missing_cmd base

     

       161
       161
       -
             (check_all || thumbnails)

     

       162
       162
       -
             (check_all || synopsis)

     

       163
       163
       -
             (check_all || tags)

     

       164
       164
       -
             (check_all || refs)

     

       165
       165
       -
             env xdg profile

     

       166
       166
       -
         ) $ Bushel_common.base_dir $ thumbnails_flag $ synopsis_flag $ tags_flag $ refs_flag)

     

       167
       167
       -
       

     

       168
       168
       -
       let cmd =

     

       169
       169
       -
         let doc = "List entries with missing metadata or broken references" in

     

       170
       170
       -
         let man = [

     

       171
       171
       -
           `S Manpage.s_description;

     

       172
       172
       -
           `P "This command scans all entries and reports any that are missing thumbnails, synopsis, tags, or have broken slugs/contact handles.";

     

       173
       173
       -
           `P "By default, all checks are performed. Use flags to select specific checks.";

     

       174
       174
       -
           `S Manpage.s_options;

     

       175
       175
       -
           `S Manpage.s_examples;

     

       176
       176
       -
           `P "Check for all issues:";

     

       177
       177
       -
           `Pre "  $(mname) $(tname)";

     

       178
       178
       -
           `P "Check only for missing thumbnails:";

     

       179
       179
       -
           `Pre "  $(mname) $(tname) --thumbnails";

     

       180
       180
       -
           `P "Check for missing synopsis and tags:";

     

       181
       181
       -
           `Pre "  $(mname) $(tname) --synopsis --tags";

     

       182
       182
       -
           `P "Check only for broken references:";

     

       183
       183
       -
           `Pre "  $(mname) $(tname) --refs";

     

       184
       184
       -
         ] in

     

       185
       185
       -
         let info = Cmd.info "missing" ~doc ~man in

     

       186
       186
       -
         Cmd.v info term

-131

stack/bushel/bin/bushel_note_doi.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       open Bushel

     

       3
       3
       -
       

     

       4
       4
       -
       (** Generate a roguedoi identifier using Crockford base32 encoding *)

     

       5
       5
       -
       let generate_roguedoi () =

     

       6
       6
       -
         Random.self_init ();

     

       7
       7
       -
         (* Generate a 10-character roguedoi with checksum and split every 5 chars *)

     

       8
       8
       -
         let id = Crockford.generate ~length:10 ~split_every:5 ~checksum:true () in

     

       9
       9
       -
         Printf.sprintf "10.59999/%s" id

     

       10
       10
       -
       

     

       11
       11
       -
       (** Add DOI to a specific note's frontmatter if it doesn't already have one *)

     

       12
       12
       -
       let add_doi_to_note note_path =

     

       13
       13
       -
         let content = In_channel.with_open_bin note_path In_channel.input_all in

     

       14
       14
       -
         (* Check if note already has a doi: field *)

     

       15
       15
       -
         let has_doi = try

     

       16
       16
       -
           let _ = String.index content 'd' in

     

       17
       17
       -
           let re = Str.regexp "^doi:" in

     

       18
       18
       -
           let lines = String.split_on_char '\n' content in

     

       19
       19
       -
           List.exists (fun line -> Str.string_match re (String.trim line) 0) lines

     

       20
       20
       -
         with Not_found -> false

     

       21
       21
       -
         in

     

       22
       22
       -
         if has_doi then begin

     

       23
       23
       -
           Fmt.pr "%a: Note already has a DOI, skipping@."

     

       24
       24
       -
             (Fmt.styled `Yellow Fmt.string) note_path;

     

       25
       25
       -
           false

     

       26
       26
       -
         end else begin

     

       27
       27
       -
           let roguedoi = generate_roguedoi () in

     

       28
       28
       -
           (* Parse the file to extract frontmatter *)

     

       29
       29
       -
           match String.split_on_char '\n' content with

     

       30
       30
       -
           | "---" :: rest ->

     

       31
       31
       -
               (* Find the end of frontmatter *)

     

       32
       32
       -
               let rec find_end_fm acc = function

     

       33
       33
       -
                 | [] -> None

     

       34
       34
       -
                 | "---" :: body_lines -> Some (List.rev acc, body_lines)

     

       35
       35
       -
                 | line :: lines -> find_end_fm (line :: acc) lines

     

       36
       36
       -
               in

     

       37
       37
       -
               (match find_end_fm [] rest with

     

       38
       38
       -
                | Some (fm_lines, body_lines) ->

     

       39
       39
       -
                    (* Add doi field to frontmatter *)

     

       40
       40
       -
                    let new_fm = fm_lines @ [Printf.sprintf "doi: %s" roguedoi] in

     

       41
       41
       -
                    let new_content =

     

       42
       42
       -
                      String.concat "\n" (["---"] @ new_fm @ ["---"] @ body_lines)

     

       43
       43
       -
                    in

     

       44
       44
       -
                    Out_channel.with_open_bin note_path (fun oc ->

     

       45
       45
       -
                      Out_channel.output_string oc new_content

     

       46
       46
       -
                    );

     

       47
       47
       -
                    Fmt.pr "%a: Added DOI %a@."

     

       48
       48
       -
                      (Fmt.styled `Green Fmt.string) note_path

     

       49
       49
       -
                      (Fmt.styled `Cyan Fmt.string) roguedoi;

     

       50
       50
       -
                    true

     

       51
       51
       -
                | None ->

     

       52
       52
       -
                    Fmt.epr "%a: Could not parse frontmatter@."

     

       53
       53
       -
                      (Fmt.styled `Red Fmt.string) note_path;

     

       54
       54
       -
                    false)

     

       55
       55
       -
           | _ ->

     

       56
       56
       -
               Fmt.epr "%a: No frontmatter found@."

     

       57
       57
       -
                 (Fmt.styled `Red Fmt.string) note_path;

     

       58
       58
       -
               false

     

       59
       59
       -
         end

     

       60
       60
       -
       

     

       61
       61
       -
       (** Main command implementation *)

     

       62
       62
       -
       let note_doi_cmd base_dir dry_run _env _xdg _profile =

     

       63
       63
       -
         let entries = load base_dir in

     

       64
       64
       -
         let notes = Entry.notes entries in

     

       65
       65
       -
       

     

       66
       66
       -
         (* Filter for perma notes without DOI *)

     

       67
       67
       -
         let perma_notes = List.filter (fun n ->

     

       68
       68
       -
           Note.perma n && Option.is_none (Note.doi n)

     

       69
       69
       -
         ) notes in

     

       70
       70
       -
       

     

       71
       71
       -
         if perma_notes = [] then begin

     

       72
       72
       -
           Fmt.pr "No permanent notes without DOI found.@.";

     

       73
       73
       -
           0

     

       74
       74
       -
         end else begin

     

       75
       75
       -
           Fmt.pr "@[<v>";

     

       76
       76
       -
           Fmt.pr "%a: Found %d permanent notes without DOI@.@."

     

       77
       77
       -
             (Fmt.styled `Bold Fmt.string) "Info"

     

       78
       78
       -
             (List.length perma_notes);

     

       79
       79
       -
       

     

       80
       80
       -
           let count = ref 0 in

     

       81
       81
       -
           List.iter (fun note ->

     

       82
       82
       -
             let slug = Note.slug note in

     

       83
       83
       -
             let note_path = Printf.sprintf "%s/data/notes/%s.md" base_dir slug in

     

       84
       84
       -
             Fmt.pr "Processing %a (%a)...@,"

     

       85
       85
       -
               (Fmt.styled `Cyan Fmt.string) slug

     

       86
       86
       -
               (Fmt.styled `Faint Fmt.string) (Note.title note);

     

       87
       87
       -
       

     

       88
       88
       -
             if not dry_run then begin

     

       89
       89
       -
               if add_doi_to_note note_path then

     

       90
       90
       -
                 incr count

     

       91
       91
       -
             end else begin

     

       92
       92
       -
               let roguedoi = generate_roguedoi () in

     

       93
       93
       -
               Fmt.pr "  Would add DOI: %a@,"

     

       94
       94
       -
                 (Fmt.styled `Cyan Fmt.string) roguedoi;

     

       95
       95
       -
               incr count

     

       96
       96
       -
             end

     

       97
       97
       -
           ) perma_notes;

     

       98
       98
       -
       

     

       99
       99
       -
           Fmt.pr "@.";

     

       100
       100
       -
           if dry_run then

     

       101
       101
       -
             Fmt.pr "%a: Would add DOI to %d notes (dry run)@."

     

       102
       102
       -
               (Fmt.styled `Bold Fmt.string) "Summary"

     

       103
       103
       -
               !count

     

       104
       104
       -
           else

     

       105
       105
       -
             Fmt.pr "%a: Added DOI to %d notes@."

     

       106
       106
       -
               (Fmt.styled `Bold Fmt.string) "Summary"

     

       107
       107
       -
               !count;

     

       108
       108
       -
           Fmt.pr "@]@.";

     

       109
       109
       -
           0

     

       110
       110
       -
         end

     

       111
       111
       -
       

     

       112
       112
       -
       (** Command line interface definition *)

     

       113
       113
       -
       let dry_run_flag =

     

       114
       114
       -
         let doc = "Show what would be done without making changes" in

     

       115
       115
       -
         Arg.(value & flag & info ["n"; "dry-run"] ~doc)

     

       116
       116
       -
       

     

       117
       117
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       118
       118
       -
         Term.(const note_doi_cmd $ Bushel_common.base_dir $ dry_run_flag)

     

       119
       119
       -
       

     

       120
       120
       -
       let cmd =

     

       121
       121
       -
         let doc = "Generate and add DOI identifiers to permanent notes" in

     

       122
       122
       -
         let man = [

     

       123
       123
       -
           `S Manpage.s_description;

     

       124
       124
       -
           `P "This command generates roguedoi identifiers using Crockford base32 encoding \

     

       125
       125
       -
               and adds them to the frontmatter of permanent notes (notes with perma: true) \

     

       126
       126
       -
               that don't already have a DOI.";

     

       127
       127
       -
           `P "Roguedoi format: 10.59999/xxxxx-xxxxx where x is a Crockford base32 character.";

     

       128
       128
       -
           `S Manpage.s_options;

     

       129
       129
       -
         ] in

     

       130
       130
       -
         let info = Cmd.info "note-doi" ~doc ~man in

     

       131
       131
       -
         Cmd.v info term

-88

stack/bushel/bin/bushel_obsidian.ml

···

       1
       1
       -
       open Bushel

     

       2
       2
       -
       

     

       3
       3
       -
       let obsidian_links =

     

       4
       4
       -
         let inline c = function

     

       5
       5
       -
           | Md.Obsidian_link l ->

     

       6
       6
       -
             Cmarkit_renderer.Context.string c l;

     

       7
       7
       -
             true

     

       8
       8
       -
           | _ -> false

     

       9
       9
       -
         in

     

       10
       10
       -
         Cmarkit_renderer.make ~inline ()

     

       11
       11
       -
       ;;

     

       12
       12
       -
       

     

       13
       13
       -
       let obsidian_of_doc doc =

     

       14
       14
       -
         let default = Cmarkit_commonmark.renderer () in

     

       15
       15
       -
         let r = Cmarkit_renderer.compose default obsidian_links in

     

       16
       16
       -
         Cmarkit_renderer.doc_to_string r doc

     

       17
       17
       -
       ;;

     

       18
       18
       -
       

     

       19
       19
       -
       let md_to_obsidian entries md =

     

       20
       20
       -
         let open Cmarkit in

     

       21
       21
       -
         Doc.of_string ~strict:false ~resolver:Md.with_bushel_links md

     

       22
       22
       -
         |> Mapper.map_doc (Mapper.make ~inline:(Md.bushel_inline_mapper_to_obsidian entries) ())

     

       23
       23
       -
         |> obsidian_of_doc

     

       24
       24
       -
       ;;

     

       25
       25
       -
       

     

       26
       26
       -
       let obsidian_output base output_dir =

     

       27
       27
       -
         let e = load base in

     

       28
       28
       -
         let all = Entry.all_entries e @ Entry.all_papers e in

     

       29
       29
       -
         List.iter

     

       30
       30
       -
           (fun ent ->

     

       31
       31
       -
             let slug =

     

       32
       32
       -
               match ent with

     

       33
       33
       -
               | `Paper { Paper.latest; slug; ver; _ } when not latest ->

     

       34
       34
       -
                 Printf.sprintf "%s-%s" slug ver

     

       35
       35
       -
               | _ -> Entry.slug ent

     

       36
       36
       -
             in

     

       37
       37
       -
             let fname = Filename.concat output_dir (slug ^ ".md") in

     

       38
       38
       -
             let tags =

     

       39
       39
       -
               Tags.tags_of_ent e ent

     

       40
       40
       -
               |> List.filter_map (fun tag ->

     

       41
       41
       -
                 match tag with

     

       42
       42
       -
                 | `Slug _ -> None

     

       43
       43
       -
                 | `Set s -> Some (Printf.sprintf "\"#%s\"" s)

     

       44
       44
       -
                 | `Text s -> Some (Printf.sprintf "%s" s)

     

       45
       45
       -
                 | `Contact _ -> None

     

       46
       46
       -
                 | `Year y -> Some (Printf.sprintf "\"#y%d\"" y))

     

       47
       47
       -
               |> List.map (fun s -> "- " ^ s)

     

       48
       48
       -
               |> String.concat "\n"

     

       49
       49
       -
             in

     

       50
       50
       -
             let links =

     

       51
       51
       -
               Tags.tags_of_ent e ent

     

       52
       52
       -
               |> List.filter_map (fun tag ->

     

       53
       53
       -
                 match tag with

     

       54
       54
       -
                 | `Slug s when s <> slug -> Some (Printf.sprintf "- \"[[%s]]\"" s)

     

       55
       55
       -
                 | `Contact c -> Some (Printf.sprintf "- \"[[@%s]]\"" c)

     

       56
       56
       -
                 | _ -> None)

     

       57
       57
       -
               |> String.concat "\n"

     

       58
       58
       -
               |> function

     

       59
       59
       -
               | "" -> ""

     

       60
       60
       -
               | s -> "linklist:\n" ^ s ^ "\n"

     

       61
       61
       -
             in

     

       62
       62
       -
             let body = Entry.body ent |> md_to_obsidian e in

     

       63
       63
       -
             let buf = Printf.sprintf "---\ntags:\n%s\n%s---\n\n%s" tags links body in

     

       64
       64
       -
             Out_channel.with_open_bin fname (fun oc -> output_string oc buf))

     

       65
       65
       -
           all;

     

       66
       66
       -
         List.iter

     

       67
       67
       -
           (fun contact ->

     

       68
       68
       -
             let slug = Contact.handle contact in

     

       69
       69
       -
             let fname = Filename.concat output_dir ("@" ^ slug ^ ".md") in

     

       70
       70
       -
             let buf = String.concat "\n" (Contact.names contact) in

     

       71
       71
       -
             Out_channel.with_open_bin fname (fun oc -> output_string oc buf))

     

       72
       72
       -
           (Entry.contacts e)

     

       73
       73
       -
       ;;

     

       74
       74
       -
       

     

       75
       75
       -
       (* Export the term for use in main bushel.ml *)

     

       76
       76
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       77
       77
       -
         Cmdliner.Term.(

     

       78
       78
       -
           const (fun base_dir output_dir _env _xdg _profile -> obsidian_output base_dir output_dir; 0) $

     

       79
       79
       -
           Bushel_common.base_dir $ 

     

       80
       80
       -
           Bushel_common.output_dir ~default:"obsidian"

     

       81
       81
       -
         )

     

       82
       82
       -
       

     

       83
       83
       -
       let cmd =

     

       84
       84
       -
         let doc = "Generate Obsidian-compatible markdown files" in

     

       85
       85
       -
         let info = Cmdliner.Cmd.info "obsidian" ~doc in

     

       86
       86
       -
         Cmdliner.Cmd.v info term

     

       87
       87
       -
       

     

       88
       88
       -
       (* Main entry point removed - accessed through bushel_main.ml *)

-74

stack/bushel/bin/bushel_paper.ml

···

       1
       1
       -
       module ZT = Zotero_translation

     

       2
       2
       -
       open Lwt.Infix

     

       3
       3
       -
       open Printf

     

       4
       4
       -
       module J = Ezjsonm

     

       5
       5
       -
       open Cmdliner

     

       6
       6
       -
       

     

       7
       7
       -
       

     

       8
       8
       -
       let _authors b j =

     

       9
       9
       -
         let keys = J.get_dict j in

     

       10
       10
       -
         let authors = J.get_list J.get_string (List.assoc "author" keys) in

     

       11
       11
       -
         let a = 

     

       12
       12
       -
           List.fold_left (fun acc a ->

     

       13
       13
       -
               match Bushel.Entry.lookup_by_name b a with

     

       14
       14
       -
               | Some c -> `String ("@" ^ (Bushel.Contact.handle c)) :: acc

     

       15
       15
       -
               | None -> failwith (sprintf "author %s not found" a)

     

       16
       16
       -
             ) [] authors

     

       17
       17
       -
           in

     

       18
       18
       -
         J.update j ["author"] (Some (`A a))

     

       19
       19
       -
       

     

       20
       20
       -
       let of_doi zt ~base_dir ~slug ~version doi =

     

       21
       21
       -
         ZT.json_of_doi zt ~slug doi  >>= fun j ->

     

       22
       22
       -
         let papers_dir = Printf.sprintf "%s/papers/%s" base_dir slug in

     

       23
       23
       -
         (* Ensure papers directory exists *)

     

       24
       24
       -
         (try Unix.mkdir papers_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());

     

       25
       25
       -
         

     

       26
       26
       -
         (* Extract abstract from JSON data *)

     

       27
       27
       -
         let abstract = try

     

       28
       28
       -
           let keys = Ezjsonm.get_dict (j :> Ezjsonm.value) in

     

       29
       29
       -
           match List.assoc_opt "abstract" keys with

     

       30
       30
       -
           | Some abstract_json -> Some (Ezjsonm.get_string abstract_json)

     

       31
       31
       -
           | None -> None

     

       32
       32
       -
         with _ -> None in

     

       33
       33
       -
         

     

       34
       34
       -
         (* Remove abstract from frontmatter - it goes in body *)

     

       35
       35
       -
         let keys = Ezjsonm.get_dict (j :> Ezjsonm.value) in

     

       36
       36
       -
         let filtered_keys = List.filter (fun (k, _) -> k <> "abstract") keys in

     

       37
       37
       -
         let json_without_abstract = `O filtered_keys in

     

       38
       38
       -
         

     

       39
       39
       -
         (* Use library function to generate YAML with abstract in body *)

     

       40
       40
       -
         let content = Bushel.Paper.to_yaml ?abstract ~ver:version json_without_abstract in

     

       41
       41
       -
         

     

       42
       42
       -
         let filename = Printf.sprintf "%s.md" version in

     

       43
       43
       -
         let filepath = Filename.concat papers_dir filename in

     

       44
       44
       -
         let oc = open_out filepath in

     

       45
       45
       -
         output_string oc content;

     

       46
       46
       -
         close_out oc;

     

       47
       47
       -
         Printf.printf "Created paper file: %s\n" filepath;

     

       48
       48
       -
         Lwt.return ()

     

       49
       49
       -
       

     

       50
       50
       -
       let slug_arg =

     

       51
       51
       -
         let doc = "Slug for the entry." in

     

       52
       52
       -
         Arg.(required & pos 0 (some string) None & info [] ~docv:"SLUG" ~doc)

     

       53
       53
       -
       

     

       54
       54
       -
       let version_arg =

     

       55
       55
       -
         let doc = "Version of the entry." in

     

       56
       56
       -
         Arg.(required & pos 1 (some string) None & info [] ~docv:"VERSION" ~doc)

     

       57
       57
       -
       

     

       58
       58
       -
       let doi_arg =

     

       59
       59
       -
         let doc = "DOI of the entry." in

     

       60
       60
       -
         Arg.(required & pos 2 (some string) None & info [] ~docv:"DOI" ~doc)

     

       61
       61
       -
       

     

       62
       62
       -
       (* Export the term for use in main bushel.ml *)

     

       63
       63
       -
       let term =

     

       64
       64
       -
         Term.(const (fun base slug version doi ->

     

       65
       65
       -
           let zt = ZT.v "http://svr-avsm2-eeg-ce:1969" in

     

       66
       66
       -
           Lwt_main.run @@ of_doi zt ~base_dir:base ~slug ~version doi; 0

     

       67
       67
       -
         ) $ Bushel_common.base_dir $ slug_arg $ version_arg $ doi_arg)

     

       68
       68
       -
       

     

       69
       69
       -
       let cmd =

     

       70
       70
       -
         let doc = "Generate paper entry from DOI" in

     

       71
       71
       -
         let info = Cmd.info "paper" ~doc in

     

       72
       72
       -
         Cmd.v info term

     

       73
       73
       -
       

     

       74
       74
       -
       (* Main entry point removed - accessed through bushel_main.ml *)

-57

stack/bushel/bin/bushel_paper_classify.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       

     

       3
       3
       -
       (** TODO:claude Classify papers based on heuristics and update metadata *)

     

       4
       4
       -
       let classify_papers base_dir overwrite =

     

       5
       5
       -
         let papers_dir = Printf.sprintf "%s/papers" base_dir in

     

       6
       6
       -
         if not (Sys.file_exists papers_dir) then (

     

       7
       7
       -
           Printf.eprintf "Papers directory not found: %s\n" papers_dir;

     

       8
       8
       -
           1

     

       9
       9
       -
         ) else (

     

       10
       10
       -
           let paper_dirs = Sys.readdir papers_dir |> Array.to_list in

     

       11
       11
       -
           List.iter (fun paper_slug ->

     

       12
       12
       -
             let paper_path = Filename.concat papers_dir paper_slug in

     

       13
       13
       -
             if Sys.is_directory paper_path then (

     

       14
       14
       -
               let versions = Sys.readdir paper_path |> Array.to_list 

     

       15
       15
       -
                            |> List.filter (String.ends_with ~suffix:".md") in

     

       16
       16
       -
               List.iter (fun version_file ->

     

       17
       17
       -
                 let filepath = Filename.concat paper_path version_file in

     

       18
       18
       -
                 let version = Filename.remove_extension version_file in

     

       19
       19
       -
                 try

     

       20
       20
       -
                   let paper = Bushel.Paper.of_md ~slug:paper_slug ~ver:version filepath in

     

       21
       21
       -
                   let predicted_class = Bushel.Paper.classification paper in

     

       22
       22
       -
                   let class_str = Bushel.Paper.string_of_classification predicted_class in

     

       23
       23
       -
                   Printf.printf "%s/%s: %s\n" paper_slug version class_str;

     

       24
       24
       -
                   

     

       25
       25
       -
                   (* Update the file if overwrite is enabled *)

     

       26
       26
       -
                   if overwrite then (

     

       27
       27
       -
                     let json_data = Bushel.Paper.raw_json paper in

     

       28
       28
       -
                     let keys = Ezjsonm.get_dict json_data in

     

       29
       29
       -
                     let updated_keys = ("classification", `String class_str) :: 

     

       30
       30
       -
                                      (List.filter (fun (k, _) -> k <> "classification") keys) in

     

       31
       31
       -
                     let updated_json = `O updated_keys in

     

       32
       32
       -
                     let abstract = Some (Bushel.Paper.abstract paper) in

     

       33
       33
       -
                     let content = Bushel.Paper.to_yaml ?abstract ~ver:version updated_json in

     

       34
       34
       -
                     let oc = open_out filepath in

     

       35
       35
       -
                     output_string oc content;

     

       36
       36
       -
                     close_out oc;

     

       37
       37
       -
                     Printf.printf "  Updated %s\n" filepath

     

       38
       38
       -
                   )

     

       39
       39
       -
                 with e ->

     

       40
       40
       -
                   Printf.eprintf "Error processing %s: %s\n" filepath (Printexc.to_string e)

     

       41
       41
       -
               ) versions

     

       42
       42
       -
             )

     

       43
       43
       -
           ) paper_dirs;

     

       44
       44
       -
           0

     

       45
       45
       -
         )

     

       46
       46
       -
       

     

       47
       47
       -
       let overwrite_flag =

     

       48
       48
       -
         let doc = "Update paper files with classification metadata" in

     

       49
       49
       -
         Arg.(value & flag & info ["overwrite"] ~doc)

     

       50
       50
       -
       

     

       51
       51
       -
       let term =

     

       52
       52
       -
         Term.(const classify_papers $ Bushel_common.base_dir $ overwrite_flag)

     

       53
       53
       -
       

     

       54
       54
       -
       let cmd =

     

       55
       55
       -
         let doc = "Classify papers as full/short/preprint" in

     

       56
       56
       -
         let info = Cmd.info "paper-classify" ~doc in

     

       57
       57
       -
         Cmd.v info term

-325

stack/bushel/bin/bushel_paper_tex.ml

···

       1
       1
       -
       open Printf

     

       2
       2
       -
       open Cmdliner

     

       3
       3
       -
       

     

       4
       4
       -
       (** TODO:claude Format author name for LaTeX with initials and full last name *)

     

       5
       5
       -
       let format_author_name author =

     

       6
       6
       -
         (* Split author name and convert to "F.M.~Lastname" format *)

     

       7
       7
       -
         let parts = String.split_on_char ' ' author |> List.filter (fun s -> s <> "") in

     

       8
       8
       -
         match List.rev parts with

     

       9
       9
       -
         | [] -> ""

     

       10
       10
       -
         | lastname :: rest_rev ->

     

       11
       11
       -
           let firstname_parts = List.rev rest_rev in

     

       12
       12
       -
           let initials = List.map (fun name -> 

     

       13
       13
       -
             if String.length name > 0 then String.sub name 0 1 ^ "." else ""

     

       14
       14
       -
           ) firstname_parts in

     

       15
       15
       -
           let initials_str = String.concat "" initials in

     

       16
       16
       -
           if initials_str = "" then lastname

     

       17
       17
       -
           else initials_str ^ "~" ^ lastname

     

       18
       18
       -
       

     

       19
       19
       -
       (** TODO:claude Format author name for LaTeX with underline for target author *)

     

       20
       20
       -
       let format_author target_name author =

     

       21
       21
       -
         let formatted = format_author_name author in

     

       22
       22
       -
         (* Check if author contains target name substring for underlining *)

     

       23
       23
       -
         if String.lowercase_ascii author |> fun s -> 

     

       24
       24
       -
            Re.execp (Re.Perl.compile_pat ~opts:[`Caseless] target_name) s

     

       25
       25
       -
         then sprintf "\\underline{%s}" formatted

     

       26
       26
       -
         else formatted

     

       27
       27
       -
       

     

       28
       28
       -
       (** TODO:claude Format authors list for LaTeX *)

     

       29
       29
       -
       let format_authors target_name authors =

     

       30
       30
       -
         match authors with

     

       31
       31
       -
         | [] -> ""

     

       32
       32
       -
         | [single] -> format_author target_name single

     

       33
       33
       -
         | _ -> 

     

       34
       34
       -
           let formatted = List.map (format_author target_name) authors in

     

       35
       35
       -
           String.concat ", " formatted

     

       36
       36
       -
       

     

       37
       37
       -
       (** TODO:claude Escape special LaTeX characters *)

     

       38
       38
       -
       let escape_latex str =

     

       39
       39
       -
         let replacements = [

     

       40
       40
       -
           ("&", "\\&");

     

       41
       41
       -
           ("%", "\\%");

     

       42
       42
       -
           ("$", "\\$");

     

       43
       43
       -
           ("#", "\\#");

     

       44
       44
       -
           ("_", "\\_");

     

       45
       45
       -
           ("{", "\\{");

     

       46
       46
       -
           ("}", "\\}");

     

       47
       47
       -
           ("~", "\\textasciitilde{}");

     

       48
       48
       -
           ("^", "\\textasciicircum{}");

     

       49
       49
       -
         ] in

     

       50
       50
       -
         List.fold_left (fun s (from, to_) ->

     

       51
       51
       -
           Re.replace_string (Re.compile (Re.str from)) ~by:to_ s

     

       52
       52
       -
         ) str replacements

     

       53
       53
       -
       

     

       54
       54
       -
       (** TODO:claude Clean venue name by removing common prefixes and handling arXiv *)

     

       55
       55
       -
       let clean_venue_name venue =

     

       56
       56
       -
         (* Special handling for arXiv to avoid redundancy like "arXiv (arXiv:ID)" *)

     

       57
       57
       -
         let venue_lower = String.lowercase_ascii venue in

     

       58
       58
       -
         if Re.execp (Re.Perl.compile_pat ~opts:[`Caseless] "arxiv") venue_lower then

     

       59
       59
       -
           if String.contains venue ':' then

     

       60
       60
       -
             (* If it contains arXiv:ID format, just return the ID part *)

     

       61
       61
       -
             let parts = String.split_on_char ':' venue in

     

       62
       62
       -
             match parts with

     

       63
       63
       -
             | _ :: id :: _ -> String.trim id

     

       64
       64
       -
             | _ -> venue

     

       65
       65
       -
           else venue

     

       66
       66
       -
         else

     

       67
       67
       -
           let prefixes = [

     

       68
       68
       -
             "in proceedings of the ";

     

       69
       69
       -
             "proceedings of the ";

     

       70
       70
       -
             "in proceedings of ";

     

       71
       71
       -
             "proceedings of ";

     

       72
       72
       -
             "in the ";

     

       73
       73
       -
             "the ";

     

       74
       74
       -
           ] in

     

       75
       75
       -
           let rec remove_prefixes v = function

     

       76
       76
       -
             | [] -> v

     

       77
       77
       -
             | prefix :: rest ->

     

       78
       78
       -
               if String.length v >= String.length prefix && 

     

       79
       79
       -
                  String.sub (String.lowercase_ascii v) 0 (String.length prefix) = prefix

     

       80
       80
       -
               then String.sub v (String.length prefix) (String.length v - String.length prefix)

     

       81
       81
       -
               else remove_prefixes v rest

     

       82
       82
       -
           in

     

       83
       83
       -
           let cleaned = remove_prefixes venue prefixes in

     

       84
       84
       -
           (* Capitalize first letter *)

     

       85
       85
       -
           if String.length cleaned > 0 then

     

       86
       86
       -
             String.mapi (fun i c -> if i = 0 then Char.uppercase_ascii c else c) cleaned

     

       87
       87
       -
           else cleaned

     

       88
       88
       -
       

     

       89
       89
       -
       (** TODO:claude Format venue for LaTeX with volume/number details for full papers *)

     

       90
       90
       -
       let format_venue paper =

     

       91
       91
       -
         let open Bushel.Paper in

     

       92
       92
       -
         let classification = classification paper in

     

       93
       93
       -
         match bibtype paper with

     

       94
       94
       -
         | "article" -> 

     

       95
       95
       -
           let journal_name = try journal paper |> clean_venue_name |> escape_latex with _ -> "Journal" in

     

       96
       96
       -
           if classification = Full then (

     

       97
       97
       -
             let vol_info = 

     

       98
       98
       -
               let vol = volume paper in

     

       99
       99
       -
               let num = issue paper in

     

       100
       100
       -
               match vol, num with

     

       101
       101
       -
               | Some v, Some n -> sprintf ", %s(%s)" v n

     

       102
       102
       -
               | Some v, None -> sprintf ", vol. %s" v

     

       103
       103
       -
               | None, Some n -> sprintf ", no. %s" n

     

       104
       104
       -
               | None, None -> ""

     

       105
       105
       -
             in

     

       106
       106
       -
             sprintf "\\textit{%s%s}" journal_name vol_info

     

       107
       107
       -
           ) else 

     

       108
       108
       -
             sprintf "\\textit{%s}" journal_name

     

       109
       109
       -
         | "inproceedings" ->

     

       110
       110
       -
           let conf_name = try booktitle paper |> clean_venue_name |> escape_latex with _ -> "Conference" in

     

       111
       111
       -
           sprintf "\\textit{%s}" conf_name

     

       112
       112
       -
         | "techreport" ->

     

       113
       113
       -
           let inst = try institution paper |> escape_latex with _ -> "Institution" in

     

       114
       114
       -
           sprintf "\\textit{Technical Report, %s}" inst

     

       115
       115
       -
         | "phdthesis" ->

     

       116
       116
       -
           let school = try institution paper |> escape_latex with _ -> "University" in

     

       117
       117
       -
           sprintf "\\textit{PhD thesis, %s}" school

     

       118
       118
       -
         | "mastersthesis" ->

     

       119
       119
       -
           let school = try institution paper |> escape_latex with _ -> "University" in

     

       120
       120
       -
           sprintf "\\textit{Master's thesis, %s}" school

     

       121
       121
       -
         | "book" ->

     

       122
       122
       -
           let publisher_str = try Bushel.Paper.publisher paper |> escape_latex with _ -> "" in

     

       123
       123
       -
           let edition_str = try 

     

       124
       124
       -
             let json = Bushel.Paper.raw_json paper in

     

       125
       125
       -
             let keys = Ezjsonm.get_dict json in

     

       126
       126
       -
             List.assoc "edition" keys |> Ezjsonm.get_string |> escape_latex 

     

       127
       127
       -
           with _ -> "" in

     

       128
       128
       -
           let isbn_str = try Bushel.Paper.isbn paper |> escape_latex with _ -> "" in

     

       129
       129
       -
           let venue_info = 

     

       130
       130
       -
             let base = match publisher_str, edition_str with

     

       131
       131
       -
               | pub, ed when pub <> "" && ed <> "" -> sprintf "%s, %s edition" pub ed

     

       132
       132
       -
               | pub, _ when pub <> "" -> pub

     

       133
       133
       -
               | _, ed when ed <> "" -> sprintf "%s edition" ed

     

       134
       134
       -
               | _, _ -> "Book"

     

       135
       135
       -
             in

     

       136
       136
       -
             if isbn_str <> "" then

     

       137
       137
       -
               sprintf "%s, ISBN %s" base isbn_str

     

       138
       138
       -
             else

     

       139
       139
       -
               base

     

       140
       140
       -
           in

     

       141
       141
       -
           sprintf "\\textit{%s}" venue_info

     

       142
       142
       -
         | "misc" ->

     

       143
       143
       -
           (* Try to get meaningful venue info for misc entries *)

     

       144
       144
       -
           let journal_str = try Bushel.Paper.journal paper |> clean_venue_name |> escape_latex with _ -> "" in

     

       145
       145
       -
           let booktitle_str = try Bushel.Paper.booktitle paper |> clean_venue_name |> escape_latex with _ -> "" in

     

       146
       146
       -
           let publisher_str = try Bushel.Paper.publisher paper |> escape_latex with _ -> "" in

     

       147
       147
       -
           if journal_str <> "" then

     

       148
       148
       -
             sprintf "\\textit{%s}" journal_str

     

       149
       149
       -
           else if booktitle_str <> "" then

     

       150
       150
       -
             sprintf "\\textit{%s}" booktitle_str

     

       151
       151
       -
           else if publisher_str <> "" then

     

       152
       152
       -
             sprintf "\\textit{%s}" publisher_str  

     

       153
       153
       -
           else

     

       154
       154
       -
             sprintf "\\textit{Preprint}"

     

       155
       155
       -
         | "abstract" ->

     

       156
       156
       -
           (* Handle conference abstracts *)

     

       157
       157
       -
           let conf_name = try Bushel.Paper.booktitle paper |> clean_venue_name |> escape_latex with _ -> "" in

     

       158
       158
       -
           let journal_str = try Bushel.Paper.journal paper |> clean_venue_name |> escape_latex with _ -> "" in

     

       159
       159
       -
           if conf_name <> "" then

     

       160
       160
       -
             sprintf "\\textit{%s (Abstract)}" conf_name

     

       161
       161
       -
           else if journal_str <> "" then

     

       162
       162
       -
             sprintf "\\textit{%s (Abstract)}" journal_str

     

       163
       163
       -
           else

     

       164
       164
       -
             sprintf "\\textit{Conference Abstract}"

     

       165
       165
       -
         | _ -> 

     

       166
       166
       -
           (* Fallback for other types with special arXiv handling *)

     

       167
       167
       -
           let journal_str = try Bushel.Paper.journal paper with _ -> "" in

     

       168
       168
       -
           let publisher_str = try Bushel.Paper.publisher paper |> escape_latex with _ -> "" in

     

       169
       169
       -
           

     

       170
       170
       -
           (* Special handling for arXiv papers - skip venue, let note handle it *)

     

       171
       171
       -
           if String.lowercase_ascii journal_str = "arxiv" then

     

       172
       172
       -
             ""

     

       173
       173
       -
           else if journal_str <> "" then

     

       174
       174
       -
             sprintf "\\textit{%s}" (journal_str |> clean_venue_name |> escape_latex)

     

       175
       175
       -
           else if publisher_str <> "" then

     

       176
       176
       -
             sprintf "\\textit{%s}" publisher_str  

     

       177
       177
       -
           else

     

       178
       178
       -
             sprintf "\\textit{Preprint}"

     

       179
       179
       -
       

     

       180
       180
       -
       (** TODO:claude Generate LaTeX PubItem for a paper *)

     

       181
       181
       -
       let generate_latex_entry target_name paper =

     

       182
       182
       -
         let open Bushel.Paper in

     

       183
       183
       -
         let slug_str = slug paper in

     

       184
       184
       -
         let title_str = title paper |> escape_latex in

     

       185
       185
       -
         let authors_str = format_authors target_name (authors paper) in

     

       186
       186
       -
         let venue_str = format_venue paper in

     

       187
       187
       -
         let year_str = year paper |> string_of_int in

     

       188
       188
       -
         let month_str = 

     

       189
       189
       -
           let (_, m, _) = date paper in

     

       190
       190
       -
           sprintf "%02d" m

     

       191
       191
       -
         in

     

       192
       192
       -
         

     

       193
       193
       -
         (* Check if paper is in the future *)

     

       194
       194
       -
         let is_in_press =

     

       195
       195
       -
           let paper_time = datetime paper in

     

       196
       196
       -
           let now = Ptime_clock.now () in

     

       197
       197
       -
           Ptime.compare paper_time now > 0

     

       198
       198
       -
         in

     

       199
       199
       -
         

     

       200
       200
       -
         (* Add DOI or PDF link if available, but not for in-press papers unless they have explicit URL *)

     

       201
       201
       -
         let title_with_link = 

     

       202
       202
       -
           if is_in_press then

     

       203
       203
       -
             (* For in-press papers, only add link if there's an explicit URL field *)

     

       204
       204
       -
             match Bushel.Paper.url paper with

     

       205
       205
       -
             | Some u -> sprintf "\\href{%s}{%s}" u title_str

     

       206
       206
       -
             | None -> title_str  (* No link for in-press papers without explicit URL *)

     

       207
       207
       -
           else

     

       208
       208
       -
             (* For published papers, use DOI or URL or default PDF link *)

     

       209
       209
       -
             match Bushel.Paper.doi paper with

     

       210
       210
       -
             | Some doi -> sprintf "\\href{https://doi.org/%s}{%s}" doi title_str

     

       211
       211
       -
             | None -> 

     

       212
       212
       -
               (* Check if there's a URL, otherwise default to PDF link *)

     

       213
       213
       -
               let url = match Bushel.Paper.url paper with

     

       214
       214
       -
                 | Some u -> u

     

       215
       215
       -
                 | None -> sprintf "https://anil.recoil.org/papers/%s.pdf" slug_str

     

       216
       216
       -
               in

     

       217
       217
       -
               sprintf "\\href{%s}{%s}" url title_str

     

       218
       218
       -
         in

     

       219
       219
       -
         

     

       220
       220
       -
         (* Add "(in press)" if paper is in the future *)

     

       221
       221
       -
         let in_press_str = if is_in_press then " \\textit{(in press)}" else "" in

     

       222
       222
       -
         

     

       223
       223
       -
         (* Add note if present *)

     

       224
       224
       -
         let note_str = match Bushel.Paper.note paper with

     

       225
       225
       -
           | Some n -> sprintf " \\textit{(%s)}" (escape_latex n)

     

       226
       226
       -
           | None -> ""

     

       227
       227
       -
         in

     

       228
       228
       -
         

     

       229
       229
       -
         sprintf "\\BigGap\n\\PubItemLabeled{%s}\n{``%s,''\n%s,\n%s%s%s,\n\\DatestampYM{%s}{%s}.}\n"

     

       230
       230
       -
           slug_str title_with_link authors_str venue_str in_press_str note_str year_str month_str

     

       231
       231
       -
       

     

       232
       232
       -
       (** TODO:claude Generate LaTeX output files for papers *)

     

       233
       233
       -
       let generate_tex base_dir output_dir target_name =

     

       234
       234
       -
         try

     

       235
       235
       -
           let papers = Bushel.load_papers base_dir in

     

       236
       236
       -
           let latest_papers = List.filter (fun p -> p.Bushel.Paper.latest) papers in

     

       237
       237
       -
           

     

       238
       238
       -
           (* Extract selected papers first *)

     

       239
       239
       -
           let selected_papers = List.filter Bushel.Paper.selected latest_papers in

     

       240
       240
       -
           

     

       241
       241
       -
           (* Group remaining papers by classification, excluding selected ones *)

     

       242
       242
       -
           let non_selected_papers = List.filter (fun p -> not (Bushel.Paper.selected p)) latest_papers in

     

       243
       243
       -
           let full_papers = List.filter (fun p -> 

     

       244
       244
       -
             Bushel.Paper.classification p = Bushel.Paper.Full) non_selected_papers in

     

       245
       245
       -
           let short_papers = List.filter (fun p -> 

     

       246
       246
       -
             Bushel.Paper.classification p = Bushel.Paper.Short) non_selected_papers in

     

       247
       247
       -
           let preprint_papers = List.filter (fun p -> 

     

       248
       248
       -
             Bushel.Paper.classification p = Bushel.Paper.Preprint) non_selected_papers in

     

       249
       249
       -
           

     

       250
       250
       -
           (* Sort each group by date, newest first *)

     

       251
       251
       -
           let sorted_full = List.sort Bushel.Paper.compare full_papers in

     

       252
       252
       -
           let sorted_short = List.sort Bushel.Paper.compare short_papers in

     

       253
       253
       -
           let sorted_preprint = List.sort Bushel.Paper.compare preprint_papers in

     

       254
       254
       -
           let sorted_selected = List.sort Bushel.Paper.compare selected_papers in

     

       255
       255
       -
           

     

       256
       256
       -
           (* Ensure output directory exists *)

     

       257
       257
       -
           (try Unix.mkdir output_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());

     

       258
       258
       -
           

     

       259
       259
       -
           (* Write papers_full.tex *)

     

       260
       260
       -
           let oc_full = open_out (Filename.concat output_dir "papers_full.tex") in

     

       261
       261
       -
           List.iter (fun paper ->

     

       262
       262
       -
             let latex = generate_latex_entry target_name paper in

     

       263
       263
       -
             output_string oc_full latex;

     

       264
       264
       -
             output_char oc_full '\n'

     

       265
       265
       -
           ) sorted_full;

     

       266
       266
       -
           close_out oc_full;

     

       267
       267
       -
           Printf.printf "Generated %s/papers_full.tex with %d entries\n" output_dir (List.length sorted_full);

     

       268
       268
       -
           

     

       269
       269
       -
           (* Write papers_short.tex *)

     

       270
       270
       -
           let oc_short = open_out (Filename.concat output_dir "papers_short.tex") in

     

       271
       271
       -
           List.iter (fun paper ->

     

       272
       272
       -
             let latex = generate_latex_entry target_name paper in

     

       273
       273
       -
             output_string oc_short latex;

     

       274
       274
       -
             output_char oc_short '\n'

     

       275
       275
       -
           ) sorted_short;

     

       276
       276
       -
           close_out oc_short;

     

       277
       277
       -
           Printf.printf "Generated %s/papers_short.tex with %d entries\n" output_dir (List.length sorted_short);

     

       278
       278
       -
           

     

       279
       279
       -
           (* Write papers_preprint.tex *)

     

       280
       280
       -
           let oc_preprint = open_out (Filename.concat output_dir "papers_preprint.tex") in

     

       281
       281
       -
           List.iter (fun paper ->

     

       282
       282
       -
             let latex = generate_latex_entry target_name paper in

     

       283
       283
       -
             output_string oc_preprint latex;

     

       284
       284
       -
             output_char oc_preprint '\n'

     

       285
       285
       -
           ) sorted_preprint;

     

       286
       286
       -
           close_out oc_preprint;

     

       287
       287
       -
           Printf.printf "Generated %s/papers_preprint.tex with %d entries\n" output_dir (List.length sorted_preprint);

     

       288
       288
       -
           

     

       289
       289
       -
           (* Write papers_selected.tex *)

     

       290
       290
       -
           let oc_selected = open_out (Filename.concat output_dir "papers_selected.tex") in

     

       291
       291
       -
           List.iter (fun paper ->

     

       292
       292
       -
             let latex = generate_latex_entry target_name paper in

     

       293
       293
       -
             output_string oc_selected latex;

     

       294
       294
       -
             output_char oc_selected '\n'

     

       295
       295
       -
           ) sorted_selected;

     

       296
       296
       -
           close_out oc_selected;

     

       297
       297
       -
           Printf.printf "Generated %s/papers_selected.tex with %d entries\n" output_dir (List.length sorted_selected);

     

       298
       298
       -
           

     

       299
       299
       -
           (* Write paper_count.tex *)

     

       300
       300
       -
           let total_count = List.length latest_papers in

     

       301
       301
       -
           let oc_count = open_out (Filename.concat output_dir "paper_count.tex") in

     

       302
       302
       -
           output_string oc_count (sprintf "\\setcounter{pubcounter}{%d}\n" total_count);

     

       303
       303
       -
           close_out oc_count;

     

       304
       304
       -
           Printf.printf "Generated %s/paper_count.tex with total count: %d\n" output_dir total_count;

     

       305
       305
       -
           

     

       306
       306
       -
           0

     

       307
       307
       -
         with e ->

     

       308
       308
       -
           Printf.eprintf "Error loading papers: %s\n" (Printexc.to_string e);

     

       309
       309
       -
           1

     

       310
       310
       -
       

     

       311
       311
       -
       let output_dir_arg =

     

       312
       312
       -
         let doc = "Output directory for generated LaTeX files" in

     

       313
       313
       -
         Arg.(value & opt string "." & info ["output"; "o"] ~docv:"DIR" ~doc)

     

       314
       314
       -
       

     

       315
       315
       -
       let target_name_arg =

     

       316
       316
       -
         let doc = "Name to underline in author list (e.g., 'Madhavapeddy')" in

     

       317
       317
       -
         Arg.(value & opt string "Madhavapeddy" & info ["target"; "t"] ~docv:"NAME" ~doc)

     

       318
       318
       -
       

     

       319
       319
       -
       let term =

     

       320
       320
       -
         Term.(const generate_tex $ Bushel_common.base_dir $ output_dir_arg $ target_name_arg)

     

       321
       321
       -
       

     

       322
       322
       -
       let cmd =

     

       323
       323
       -
         let doc = "Generate LaTeX publication entries" in

     

       324
       324
       -
         let info = Cmd.info "paper-tex" ~doc in

     

       325
       325
       -
         Cmd.v info term

-48

stack/bushel/bin/bushel_search.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       

     

       3
       3
       -
       (** Bushel search command for integration with main CLI *)

     

       4
       4
       -
       

     

       5
       5
       -
       let limit =

     

       6
       6
       -
         let doc = "Maximum number of results to return" in

     

       7
       7
       -
         Arg.(value & opt int 50 & info ["limit"; "l"] ~doc)

     

       8
       8
       -
       

     

       9
       9
       -
       let offset =

     

       10
       10
       -
         let doc = "Number of results to skip (for pagination)" in

     

       11
       11
       -
         Arg.(value & opt int 0 & info ["offset"; "o"] ~doc)

     

       12
       12
       -
       

     

       13
       13
       -
       let query_text =

     

       14
       14
       -
         let doc = "Search query text" in

     

       15
       15
       -
         Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc)

     

       16
       16
       -
       

     

       17
       17
       -
       (** Search function using multisearch *)

     

       18
       18
       -
       let search query_text limit offset env _xdg _profile =

     

       19
       19
       -
         let config = Bushel.Typesense.load_config_from_files () in

     

       20
       20
       -
       

     

       21
       21
       -
         if config.api_key = "" then (

     

       22
       22
       -
           Printf.eprintf "Error: API key is required. Use TYPESENSE_API_KEY environment variable or create .typesense-key file.\n";

     

       23
       23
       -
           1

     

       24
       24
       -
         ) else (

     

       25
       25
       -
           Printf.printf "Searching Typesense at %s\n" config.endpoint;

     

       26
       26
       -
           Printf.printf "Query: \"%s\"\n" query_text;

     

       27
       27
       -
           Printf.printf "Limit: %d, Offset: %d\n\n" limit offset;

     

       28
       28
       -
       

     

       29
       29
       -
           Eio.Switch.run (fun sw ->

     

       30
       30
       -
             let result = Bushel.Typesense.multisearch ~sw ~env config query_text ~limit:50 () in

     

       31
       31
       -
             match result with

     

       32
       32
       -
             | Ok multisearch_resp ->

     

       33
       33
       -
               let combined_response = Bushel.Typesense.combine_multisearch_results multisearch_resp ~limit ~offset () in

     

       34
       34
       -
               Printf.printf "Found %d results (%.2fms)\n\n" combined_response.total combined_response.query_time;

     

       35
       35
       -
       

     

       36
       36
       -
               List.iteri (fun i (hit : Bushel.Typesense.search_result) ->

     

       37
       37
       -
                 Printf.printf "%d. %s (score: %.2f)\n" (i + 1) (Bushel.Typesense.pp_search_result_oneline hit) hit.Bushel.Typesense.score

     

       38
       38
       -
               ) combined_response.hits

     

       39
       39
       -
             | Error err ->

     

       40
       40
       -
               Format.eprintf "Search error: %a\n" Bushel.Typesense.pp_error err;

     

       41
       41
       -
               exit 1

     

       42
       42
       -
           );

     

       43
       43
       -
           0

     

       44
       44
       -
         )

     

       45
       45
       -
       

     

       46
       46
       -
       (** Command line term for integration with eiocmd *)

     

       47
       47
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       48
       48
       -
         Term.(const search $ query_text $ limit $ offset)

-70

stack/bushel/bin/bushel_thumbs.ml

···

       1
       1
       -
       open Printf

     

       2
       2
       -
       open Cmdliner

     

       3
       3
       -
       

     

       4
       4
       -
       (** TODO:claude

     

       5
       5
       -
           Helper module for ImageMagick operations *)

     

       6
       6
       -
       module Imagemagick = struct

     

       7
       7
       -
         (* Generate thumbnail from PDF *)

     

       8
       8
       -
         let generate_thumbnail ~pdf_path ~size ~output_path =

     

       9
       9
       -
           let cmd = 

     

       10
       10
       -
             sprintf "magick -density 600 -quality 100 %s[0] -gravity North -crop 100%%x50%%+0+0 -resize %s %s" 

     

       11
       11
       -
               pdf_path size output_path

     

       12
       12
       -
           in

     

       13
       13
       -
           eprintf "Running: %s\n%!" cmd;

     

       14
       14
       -
           Sys.command cmd

     

       15
       15
       -
       end

     

       16
       16
       -
       

     

       17
       17
       -
       (** TODO:claude

     

       18
       18
       -
           Process a single paper to generate its thumbnail *)

     

       19
       19
       -
       let process_paper base_dir output_dir paper =

     

       20
       20
       -
         let slug = Bushel.Paper.slug paper in

     

       21
       21
       -
         let pdf_path = sprintf "%s/static/papers/%s.pdf" base_dir slug in

     

       22
       22
       -
         let thumbnail_path = sprintf "%s/%s.png" output_dir slug in

     

       23
       23
       -
         

     

       24
       24
       -
         (* Skip if thumbnail already exists *)

     

       25
       25
       -
         if Sys.file_exists thumbnail_path then (

     

       26
       26
       -
           printf "Thumbnail already exists for %s, skipping\n%!" slug

     

       27
       27
       -
         ) else if Sys.file_exists pdf_path then (

     

       28
       28
       -
           try

     

       29
       29
       -
             let size = sprintf "2048x" in

     

       30
       30
       -
             printf "Generating high-res thumbnail for %s (size: %s)\n%!" slug size;

     

       31
       31
       -
             match Imagemagick.generate_thumbnail ~pdf_path ~size ~output_path:thumbnail_path with

     

       32
       32
       -
             | 0 -> printf "Successfully generated thumbnail for %s\n%!" slug

     

       33
       33
       -
             | n -> eprintf "Error generating thumbnail for %s (exit code: %d)\n%!" slug n

     

       34
       34
       -
           with

     

       35
       35
       -
           | e -> eprintf "Error processing paper %s: %s\n%!" slug (Printexc.to_string e)

     

       36
       36
       -
         ) else (

     

       37
       37
       -
           eprintf "PDF file not found for paper: %s\n%!" slug

     

       38
       38
       -
         )

     

       39
       39
       -
       

     

       40
       40
       -
       (** TODO:claude

     

       41
       41
       -
           Main function to process all papers in a directory *)

     

       42
       42
       -
       let process_papers base_dir output_dir =

     

       43
       43
       -
         (* Create output directory if it doesn't exist *)

     

       44
       44
       -
         if not (Sys.file_exists output_dir) then (

     

       45
       45
       -
           printf "Creating output directory: %s\n%!" output_dir;

     

       46
       46
       -
           Unix.mkdir output_dir 0o755

     

       47
       47
       -
         );

     

       48
       48
       -
         

     

       49
       49
       -
         (* Load Bushel entries and get papers *)

     

       50
       50
       -
         printf "Loading papers from %s\n%!" base_dir;

     

       51
       51
       -
         let e = Bushel.load base_dir in

     

       52
       52
       -
         let papers = Bushel.Entry.papers e in

     

       53
       53
       -
         

     

       54
       54
       -
         (* Process each paper *)

     

       55
       55
       -
         printf "Found %d papers\n%!" (List.length papers);

     

       56
       56
       -
         List.iter (process_paper base_dir output_dir) papers

     

       57
       57
       -
       

     

       58
       58
       -
       (* Command line arguments are now imported from Bushel_common *)

     

       59
       59
       -
       

     

       60
       60
       -
       (* Export the term for use in main bushel.ml *)

     

       61
       61
       -
       let term : (Eio_unix.Stdenv.base -> Xdge.t -> Keyeio.Profile.t -> int) Cmdliner.Term.t =

     

       62
       62
       -
         Term.(const (fun base_dir output_dir _env _xdg _profile -> process_papers base_dir output_dir; 0) $

     

       63
       63
       -
           Bushel_common.base_dir $ Bushel_common.output_dir ~default:".")

     

       64
       64
       -
       

     

       65
       65
       -
       let cmd =

     

       66
       66
       -
         let doc = "Generate thumbnails for paper PDFs" in

     

       67
       67
       -
         let info = Cmd.info "thumbs" ~doc in

     

       68
       68
       -
         Cmd.v info term

     

       69
       69
       -
       

     

       70
       70
       -
       (* Main entry point removed - accessed through bushel_main.ml *)

-188

stack/bushel/bin/bushel_typesense.ml

···

       1
       1
       -
       open Cmdliner

     

       2
       2
       -
       

     

       3
       3
       -
       (** Bushel Typesense binary with upload and query functionality *)

     

       4
       4
       -
       

     

       5
       5
       -
       let data_dir =

     

       6
       6
       -
         let doc = "Directory containing bushel data files" in

     

       7
       7
       -
         Arg.(value & opt string "." & info ["data-dir"; "d"] ~doc)

     

       8
       8
       -
       

     

       9
       9
       -
       (** Main upload function *)

     

       10
       10
       -
       let upload data_dir openai_key env _xdg _profile =

     

       11
       11
       -
         let config = Bushel.Typesense.load_config_from_files () in

     

       12
       12
       -
       

     

       13
       13
       -
         let config = { config with

     

       14
       14
       -
           openai_key = if openai_key = "" then config.openai_key else openai_key

     

       15
       15
       -
         } in

     

       16
       16
       -
       

     

       17
       17
       -
         if config.api_key = "" then (

     

       18
       18
       -
           Printf.eprintf "Error: API key is required. Use TYPESENSE_API_KEY environment variable or create .typesense-key file.\n";

     

       19
       19
       -
           1

     

       20
       20
       -
         ) else if config.openai_key = "" then (

     

       21
       21
       -
           Printf.eprintf "Error: OpenAI API key is required for embeddings. Use OPENAI_API_KEY environment variable or create .openrouter-api file.\n";

     

       22
       22
       -
           1

     

       23
       23
       -
         ) else (

     

       24
       24
       -
           Printf.printf "Loading bushel data from %s\n%!" data_dir;

     

       25
       25
       -
           let entries = Bushel.load data_dir in

     

       26
       26
       -
       

     

       27
       27
       -
           Printf.printf "Uploading bushel data to Typesense at %s\n%!" config.endpoint;

     

       28
       28
       -
       

     

       29
       29
       -
           Eio.Switch.run (fun sw ->

     

       30
       30
       -
             Bushel.Typesense.upload_all ~sw ~env config entries

     

       31
       31
       -
           );

     

       32
       32
       -
           0

     

       33
       33
       -
         )

     

       34
       34
       -
       

     

       35
       35
       -
       

     

       36
       36
       -
       (** Query function *)

     

       37
       37
       -
       let query query_text collection limit offset env _xdg _profile =

     

       38
       38
       -
         let config = Bushel.Typesense.load_config_from_files () in

     

       39
       39
       -
       

     

       40
       40
       -
         if config.api_key = "" then (

     

       41
       41
       -
           Printf.eprintf "Error: API key is required. Use TYPESENSE_API_KEY environment variable or create .typesense-key file.\n";

     

       42
       42
       -
           1

     

       43
       43
       -
         ) else (

     

       44
       44
       -
           Printf.printf "Searching Typesense at %s\n%!" config.endpoint;

     

       45
       45
       -
           Printf.printf "Query: \"%s\"\n%!" query_text;

     

       46
       46
       -
           if collection <> "" then Printf.printf "Collection: %s\n%!" collection;

     

       47
       47
       -
           Printf.printf "Limit: %d, Offset: %d\n\n%!" limit offset;

     

       48
       48
       -
       

     

       49
       49
       -
           Eio.Switch.run (fun sw ->

     

       50
       50
       -
             let search_fn = if collection = "" then

     

       51
       51
       -
               Bushel.Typesense.search_all ~sw ~env config query_text ~limit ~offset

     

       52
       52
       -
             else

     

       53
       53
       -
               Bushel.Typesense.search_collection ~sw ~env config collection query_text ~limit ~offset

     

       54
       54
       -
             in

     

       55
       55
       -
             let result = search_fn () in

     

       56
       56
       -
             match result with

     

       57
       57
       -
             | Ok response ->

     

       58
       58
       -
               Printf.printf "Found %d results (%.2fms)\n\n%!" response.total response.query_time;

     

       59
       59
       -
               List.iteri (fun i (hit : Bushel.Typesense.search_result) ->

     

       60
       60
       -
                 Printf.printf "%d. [%s] %s (score: %.2f)\n%!" (i + 1) hit.collection hit.title hit.score;

     

       61
       61
       -
                 if hit.content <> "" then Printf.printf "   %s\n%!" hit.content;

     

       62
       62
       -
                 if hit.highlights <> [] then (

     

       63
       63
       -
                   Printf.printf "   Highlights:\n%!";

     

       64
       64
       -
                   List.iter (fun (field, snippets) ->

     

       65
       65
       -
                     List.iter (fun snippet ->

     

       66
       66
       -
                       Printf.printf "     %s: %s\n%!" field snippet

     

       67
       67
       -
                     ) snippets

     

       68
       68
       -
                   ) hit.highlights

     

       69
       69
       -
                 );

     

       70
       70
       -
                 Printf.printf "\n%!"

     

       71
       71
       -
               ) response.hits

     

       72
       72
       -
             | Error err ->

     

       73
       73
       -
               Format.eprintf "Search error: %a\n%!" Bushel.Typesense.pp_error err;

     

       74
       74
       -
               exit 1

     

       75
       75
       -
           );

     

       76
       76
       -
           0

     

       77
       77
       -
         )

     

       78
       78
       -
       

     

       79
       79
       -
       (** List collections function *)

     

       80
       80
       -
       let list env _xdg _profile =

     

       81
       81
       -
         let config = Bushel.Typesense.load_config_from_files () in

     

       82
       82
       -
       

     

       83
       83
       -
         if config.api_key = "" then (

     

       84
       84
       -
           Printf.eprintf "Error: API key is required. Use TYPESENSE_API_KEY environment variable or create .typesense-key file.\n";

     

       85
       85
       -
           1

     

       86
       86
       -
         ) else (

     

       87
       87
       -
           Printf.printf "Listing collections at %s\n\n%!" config.endpoint;

     

       88
       88
       -
       

     

       89
       89
       -
           Eio.Switch.run (fun sw ->

     

       90
       90
       -
             let result = Bushel.Typesense.list_collections ~sw ~env config in

     

       91
       91
       -
             match result with

     

       92
       92
       -
             | Ok collections ->

     

       93
       93
       -
               Printf.printf "Collections:\n%!";

     

       94
       94
       -
               List.iter (fun (name, count) ->

     

       95
       95
       -
                 Printf.printf "  %s (%d documents)\n%!" name count

     

       96
       96
       -
               ) collections

     

       97
       97
       -
             | Error err ->

     

       98
       98
       -
               Format.eprintf "List error: %a\n%!" Bushel.Typesense.pp_error err;

     

       99
       99
       -
               exit 1

     

       100
       100
       -
           );

     

       101
       101
       -
           0

     

       102
       102
       -
         )

     

       103
       103
       -
       

     

       104
       104
       -
       (** Command line arguments *)

     

       105
       105
       -
       let openai_key =

     

       106
       106
       -
         let doc = "OpenAI API key for embeddings" in

     

       107
       107
       -
         Arg.(value & opt string "" & info ["openai-key"; "oa"] ~doc)

     

       108
       108
       -
       

     

       109
       109
       -
       let query_text =

     

       110
       110
       -
         let doc = "Search query text" in

     

       111
       111
       -
         Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc)

     

       112
       112
       -
       

     

       113
       113
       -
       let collection =

     

       114
       114
       -
         let doc = "Specific collection to search (contacts, papers, projects, notes, videos, ideas)" in

     

       115
       115
       -
         Arg.(value & opt string "" & info ["collection"; "c"] ~doc)

     

       116
       116
       -
       

     

       117
       117
       -
       let limit =

     

       118
       118
       -
         let doc = "Maximum number of results to return" in

     

       119
       119
       -
         Arg.(value & opt int 10 & info ["limit"; "l"] ~doc)

     

       120
       120
       -
       

     

       121
       121
       -
       let offset =

     

       122
       122
       -
         let doc = "Number of results to skip (for pagination)" in

     

       123
       123
       -
         Arg.(value & opt int 0 & info ["offset"; "o"] ~doc)

     

       124
       124
       -
       

     

       125
       125
       -
       (** Query command *)

     

       126
       126
       -
       let query_cmd =

     

       127
       127
       -
         let doc = "Search bushel collections in Typesense" in

     

       128
       128
       -
         let man = [

     

       129
       129
       -
           `S Manpage.s_description;

     

       130
       130
       -
           `P "Search across all or specific bushel collections in Typesense.";

     

       131
       131
       -
           `P "The API key can be read from .typesense-key file or TYPESENSE_API_KEY environment variable.";

     

       132
       132
       -
           `S Manpage.s_examples;

     

       133
       133
       -
           `P "Search all collections:";

     

       134
       134
       -
           `Pre "  bushel-typesense query \"machine learning\"";

     

       135
       135
       -
           `P "Search specific collection:";

     

       136
       136
       -
           `Pre "  bushel-typesense query \"OCaml\" --collection papers";

     

       137
       137
       -
           `P "Search with pagination:";

     

       138
       138
       -
           `Pre "  bushel-typesense query \"AI\" --limit 5 --offset 10";

     

       139
       139
       -
         ] in

     

       140
       140
       -
         Eiocmd.run

     

       141
       141
       -
           ~info:(Cmd.info "query" ~doc ~man)

     

       142
       142
       -
           ~app_name:"bushel-typesense"

     

       143
       143
       -
           ~service:"typesense"

     

       144
       144
       -
           Term.(const query $ query_text $ collection $ limit $ offset)

     

       145
       145
       -
       

     

       146
       146
       -
       (** List command *)

     

       147
       147
       -
       let list_cmd =

     

       148
       148
       -
         let doc = "List all collections in Typesense" in

     

       149
       149
       -
         let man = [

     

       150
       150
       -
           `S Manpage.s_description;

     

       151
       151
       -
           `P "List all available collections and their document counts.";

     

       152
       152
       -
         ] in

     

       153
       153
       -
         Eiocmd.run

     

       154
       154
       -
           ~info:(Cmd.info "list" ~doc ~man)

     

       155
       155
       -
           ~app_name:"bushel-typesense"

     

       156
       156
       -
           ~service:"typesense"

     

       157
       157
       -
           Term.(const list)

     

       158
       158
       -
       

     

       159
       159
       -
       (** Upload command *)

     

       160
       160
       -
       let upload_cmd =

     

       161
       161
       -
         let doc = "Upload bushel collections to Typesense search engine" in

     

       162
       162
       -
         let man = [

     

       163
       163
       -
           `S Manpage.s_description;

     

       164
       164
       -
           `P "Upload all bushel object types (contacts, papers, projects, notes, videos, ideas) to a Typesense search engine instance.";

     

       165
       165
       -
           `P "The API keys can be read from files or environment variables.";

     

       166
       166
       -
           `S Manpage.s_examples;

     

       167
       167
       -
           `P "Upload to Typesense instance:";

     

       168
       168
       -
           `Pre "  bushel-typesense upload --data-dir /path/to/data";

     

       169
       169
       -
         ] in

     

       170
       170
       -
         Eiocmd.run

     

       171
       171
       -
           ~info:(Cmd.info "upload" ~doc ~man)

     

       172
       172
       -
           ~app_name:"bushel-typesense"

     

       173
       173
       -
           ~service:"typesense"

     

       174
       174
       -
           Term.(const upload $ data_dir $ openai_key)

     

       175
       175
       -
       

     

       176
       176
       -
       (** Main command group *)

     

       177
       177
       -
       let main_cmd =

     

       178
       178
       -
         let doc = "Bushel Typesense client" in

     

       179
       179
       -
         let man = [

     

       180
       180
       -
           `S Manpage.s_description;

     

       181
       181
       -
           `P "Client for uploading to and querying Bushel collections in Typesense search engine.";

     

       182
       182
       -
           `S Manpage.s_commands;

     

       183
       183
       -
           `S Manpage.s_common_options;

     

       184
       184
       -
         ] in

     

       185
       185
       -
         let info = Cmd.info "bushel-typesense" ~doc ~man in

     

       186
       186
       -
         Cmd.group info [upload_cmd; query_cmd; list_cmd]

     

       187
       187
       -
       

     

       188
       188
       -
       let () = exit (Cmd.eval' main_cmd)

-138

stack/bushel/bin/bushel_video.ml

···

       1
       1
       -
       [@@@warning "-26-27-32"]

     

       2
       2
       -
       

     

       3
       3
       -
       open Lwt.Infix

     

       4
       4
       -
       open Cmdliner

     

       5
       5
       -
       

     

       6
       6
       -
       let setup_log style_renderer level =

     

       7
       7
       -
         Fmt_tty.setup_std_outputs ?style_renderer ();

     

       8
       8
       -
         Logs.set_level level;

     

       9
       9
       -
         Logs.set_reporter (Logs_fmt.reporter ());

     

       10
       10
       -
         ()

     

       11
       11
       -
       

     

       12
       12
       -
       let process_videos output_dir overwrite base_url channel fetch_thumbs thumbs_dir =

     

       13
       13
       -
         Peertube.fetch_all_channel_videos base_url channel >>= fun all_videos ->

     

       14
       14
       -
         Logs.info (fun f -> f "Total videos: %d" (List.length all_videos));

     

       15
       15
       -
       

     

       16
       16
       -
         (* Create thumbnails directory if needed *)

     

       17
       17
       -
         (if fetch_thumbs && not (Sys.file_exists thumbs_dir) then

     

       18
       18
       -
           Unix.mkdir thumbs_dir 0o755);

     

       19
       19
       -
       

     

       20
       20
       -
         (* Process each video, fetching full details for complete descriptions *)

     

       21
       21
       -
         Lwt_list.map_s (fun video ->

     

       22
       22
       -
           (* Fetch complete video details to get full description *)

     

       23
       23
       -
           Peertube.fetch_video_details base_url video.Peertube.uuid >>= fun full_video ->

     

       24
       24
       -
           let (description, published_date, title, url, uuid, slug) =

     

       25
       25
       -
             Peertube.to_bushel_video full_video

     

       26
       26
       -
           in

     

       27
       27
       -
           Logs.info (fun f -> f "Title: %s, URL: %s" title url);

     

       28
       28
       -
       

     

       29
       29
       -
           (* Download thumbnail if requested *)

     

       30
       30
       -
           (if fetch_thumbs then

     

       31
       31
       -
             let thumb_path = Filename.concat thumbs_dir (uuid ^ ".jpg") in

     

       32
       32
       -
             Peertube.download_thumbnail base_url full_video thumb_path >>= fun result ->

     

       33
       33
       -
             match result with

     

       34
       34
       -
             | Ok () ->

     

       35
       35
       -
                 Logs.info (fun f -> f "Downloaded thumbnail for %s to %s" title thumb_path);

     

       36
       36
       -
                 Lwt.return_unit

     

       37
       37
       -
             | Error (`Msg e) ->

     

       38
       38
       -
                 Logs.warn (fun f -> f "Failed to download thumbnail for %s: %s" title e);

     

       39
       39
       -
                 Lwt.return_unit

     

       40
       40
       -
           else

     

       41
       41
       -
             Lwt.return_unit) >>= fun () ->

     

       42
       42
       -
       

     

       43
       43
       -
           Lwt.return {Bushel.Video.description; published_date; title; url; uuid; slug;

     

       44
       44
       -
                       talk=false; paper=None; project=None; tags=full_video.tags}

     

       45
       45
       -
         ) all_videos >>= fun vids ->

     

       46
       46
       -
         

     

       47
       47
       -
         (* Write video files *)

     

       48
       48
       -
         Lwt_list.iter_s (fun video ->

     

       49
       49
       -
           let file_path = Filename.concat output_dir (video.Bushel.Video.uuid ^ ".md") in

     

       50
       50
       -
           let file_exists = Sys.file_exists file_path in

     

       51
       51
       -
           

     

       52
       52
       -
           if file_exists then

     

       53
       53
       -
             try

     

       54
       54
       -
               (* If file exists, load it to preserve specific fields *)

     

       55
       55
       -
               let existing_video = Bushel.Video.of_md file_path in

     

       56
       56
       -
               (* Create merged video with preserved fields *)

     

       57
       57
       -
               let merged_video = {

     

       58
       58
       -
                 video with

     

       59
       59
       -
                 tags = existing_video.tags;  (* Preserve existing tags *)

     

       60
       60
       -
                 paper = existing_video.paper;  (* Preserve paper field *)

     

       61
       61
       -
                 project = existing_video.project;  (* Preserve project field *)

     

       62
       62
       -
                 talk = existing_video.talk;  (* Preserve talk field *)

     

       63
       63
       -
               } in

     

       64
       64
       -
               

     

       65
       65
       -
               (* Write the merged video data *)

     

       66
       66
       -
               if overwrite then

     

       67
       67
       -
                 match Bushel.Video.to_file output_dir merged_video with

     

       68
       68
       -
                 | Ok () -> 

     

       69
       69
       -
                     Logs.info (fun f -> f "Updated video %s with preserved fields in %s" 

     

       70
       70
       -
                       merged_video.Bushel.Video.title file_path);

     

       71
       71
       -
                     Lwt.return_unit

     

       72
       72
       -
                 | Error (`Msg e) -> 

     

       73
       73
       -
                     Logs.err (fun f -> f "Failed to update video %s: %s" 

     

       74
       74
       -
                       merged_video.Bushel.Video.title e);

     

       75
       75
       -
                     Lwt.return_unit

     

       76
       76
       -
               else begin

     

       77
       77
       -
                 Logs.info (fun f -> f "Skipping existing video %s (use --overwrite to replace)" 

     

       78
       78
       -
                   video.Bushel.Video.title);

     

       79
       79
       -
                 Lwt.return_unit

     

       80
       80
       -
               end

     

       81
       81
       -
             with _ ->

     

       82
       82
       -
               (* If reading existing file fails, proceed with new data *)

     

       83
       83
       -
               if overwrite then

     

       84
       84
       -
                 match Bushel.Video.to_file output_dir video with

     

       85
       85
       -
                 | Ok () -> 

     

       86
       86
       -
                     Logs.info (fun f -> f "Wrote video %s to %s (existing file could not be read)" 

     

       87
       87
       -
                       video.Bushel.Video.title file_path);

     

       88
       88
       -
                     Lwt.return_unit

     

       89
       89
       -
                 | Error (`Msg e) -> 

     

       90
       90
       -
                     Logs.err (fun f -> f "Failed to write video %s: %s" 

     

       91
       91
       -
                       video.Bushel.Video.title e);

     

       92
       92
       -
                     Lwt.return_unit

     

       93
       93
       -
               else begin

     

       94
       94
       -
                 Logs.info (fun f -> f "Skipping existing video %s (use --overwrite to replace)" 

     

       95
       95
       -
                   video.Bushel.Video.title);

     

       96
       96
       -
                 Lwt.return_unit

     

       97
       97
       -
               end

     

       98
       98
       -
           else

     

       99
       99
       -
             (* If file doesn't exist, just write new data *)

     

       100
       100
       -
             match Bushel.Video.to_file output_dir video with

     

       101
       101
       -
             | Ok () -> 

     

       102
       102
       -
                 Logs.info (fun f -> f "Wrote new video %s to %s" 

     

       103
       103
       -
                   video.Bushel.Video.title file_path);

     

       104
       104
       -
                 Lwt.return_unit

     

       105
       105
       -
             | Error (`Msg e) -> 

     

       106
       106
       -
                 Logs.err (fun f -> f "Failed to write video %s: %s" 

     

       107
       107
       -
                   video.Bushel.Video.title e);

     

       108
       108
       -
                 Lwt.return_unit

     

       109
       109
       -
         ) vids

     

       110
       110
       -
       

     

       111
       111
       -
       (* Command line arguments are now imported from Bushel_common *)

     

       112
       112
       -
       

     

       113
       113
       -
       (* Export the term for use in main bushel.ml *)

     

       114
       114
       -
       let term =

     

       115
       115
       -
         let fetch_thumbs =

     

       116
       116
       -
           let doc = "Download video thumbnails" in

     

       117
       117
       -
           Arg.(value & flag & info ["fetch-thumbs"] ~doc)

     

       118
       118
       -
         in

     

       119
       119
       -
         let thumbs_dir =

     

       120
       120
       -
           let doc = "Directory to save thumbnails (default: images/videos)" in

     

       121
       121
       -
           Arg.(value & opt string "images/videos" & info ["thumbs-dir"] ~docv:"DIR" ~doc)

     

       122
       122
       -
         in

     

       123
       123
       -
         Term.(const (fun output_dir overwrite base_url channel fetch_thumbs thumbs_dir () ->

     

       124
       124
       -
           Lwt_main.run (process_videos output_dir overwrite base_url channel fetch_thumbs thumbs_dir); 0)

     

       125
       125
       -
           $ Bushel_common.output_dir ~default:"." $

     

       126
       126
       -
           Bushel_common.overwrite $

     

       127
       127
       -
           Bushel_common.url_term ~default:"https://crank.recoil.org" ~doc:"PeerTube base URL" $

     

       128
       128
       -
           Bushel_common.channel ~default:"anil" $

     

       129
       129
       -
           fetch_thumbs $

     

       130
       130
       -
           thumbs_dir $

     

       131
       131
       -
           Bushel_common.setup_term)

     

       132
       132
       -
       

     

       133
       133
       -
       let cmd =

     

       134
       134
       -
         let doc = "Fetch and process videos from PeerTube" in

     

       135
       135
       -
         let info = Cmd.info "video" ~doc in

     

       136
       136
       -
         Cmd.v info term

     

       137
       137
       -
       

     

       138
       138
       -
       (* Main entry point removed - accessed through bushel_main.ml *)

-81

stack/bushel/bin/bushel_video_thumbs.ml

···

       1
       1
       -
       [@@@warning "-26-27-32"]

     

       2
       2
       -
       

     

       3
       3
       -
       open Lwt.Infix

     

       4
       4
       -
       open Cmdliner

     

       5
       5
       -
       

     

       6
       6
       -
       let setup_log style_renderer level =

     

       7
       7
       -
         Fmt_tty.setup_std_outputs ?style_renderer ();

     

       8
       8
       -
         Logs.set_level level;

     

       9
       9
       -
         Logs.set_reporter (Logs_fmt.reporter ());

     

       10
       10
       -
         ()

     

       11
       11
       -
       

     

       12
       12
       -
       let process_video_thumbs videos_dir thumbs_dir base_url =

     

       13
       13
       -
         (* Ensure thumbnail directory exists *)

     

       14
       14
       -
         (if not (Sys.file_exists thumbs_dir) then

     

       15
       15
       -
           Unix.mkdir thumbs_dir 0o755);

     

       16
       16
       -
       

     

       17
       17
       -
         (* Read all video markdown files *)

     

       18
       18
       -
         let video_files = Sys.readdir videos_dir

     

       19
       19
       -
           |> Array.to_list

     

       20
       20
       -
           |> List.filter (fun f -> Filename.check_suffix f ".md")

     

       21
       21
       -
           |> List.map (fun f -> Filename.concat videos_dir f)

     

       22
       22
       -
         in

     

       23
       23
       -
       

     

       24
       24
       -
         Logs.info (fun f -> f "Found %d video files to process" (List.length video_files));

     

       25
       25
       -
       

     

       26
       26
       -
         (* Process each video file *)

     

       27
       27
       -
         Lwt_list.iter_s (fun video_file ->

     

       28
       28
       -
           try

     

       29
       29
       -
             (* Load existing video *)

     

       30
       30
       -
             let video = Bushel.Video.of_md video_file in

     

       31
       31
       -
             let uuid = video.Bushel.Video.uuid in

     

       32
       32
       -
       

     

       33
       33
       -
             Logs.info (fun f -> f "Processing video: %s (UUID: %s)" video.title uuid);

     

       34
       34
       -
       

     

       35
       35
       -
             (* Fetch video details from PeerTube to get thumbnail info *)

     

       36
       36
       -
             Peertube.fetch_video_details base_url uuid >>= fun peertube_video ->

     

       37
       37
       -
       

     

       38
       38
       -
             (* Download thumbnail *)

     

       39
       39
       -
             let thumb_path = Filename.concat thumbs_dir (uuid ^ ".jpg") in

     

       40
       40
       -
             Peertube.download_thumbnail base_url peertube_video thumb_path >>= fun result ->

     

       41
       41
       -
       

     

       42
       42
       -
             match result with

     

       43
       43
       -
             | Ok () ->

     

       44
       44
       -
                 Logs.info (fun f -> f "Downloaded thumbnail for %s to %s" video.title thumb_path);

     

       45
       45
       -
       

     

       46
       46
       -
                 (* Update video file with thumbnail_url field *)

     

       47
       47
       -
                 (match Peertube.thumbnail_url base_url peertube_video with

     

       48
       48
       -
                  | Some url ->

     

       49
       49
       -
                      Logs.info (fun f -> f "Thumbnail URL: %s" url);

     

       50
       50
       -
                      Lwt.return_unit

     

       51
       51
       -
                  | None ->

     

       52
       52
       -
                      Logs.warn (fun f -> f "No thumbnail URL for video %s" video.title);

     

       53
       53
       -
                      Lwt.return_unit)

     

       54
       54
       -
             | Error (`Msg e) ->

     

       55
       55
       -
                 Logs.err (fun f -> f "Failed to download thumbnail for %s: %s" video.title e);

     

       56
       56
       -
                 Lwt.return_unit

     

       57
       57
       -
           with exn ->

     

       58
       58
       -
             Logs.err (fun f -> f "Error processing %s: %s" video_file (Printexc.to_string exn));

     

       59
       59
       -
             Lwt.return_unit

     

       60
       60
       -
         ) video_files

     

       61
       61
       -
       

     

       62
       62
       -
       let term =

     

       63
       63
       -
         let videos_dir =

     

       64
       64
       -
           let doc = "Directory containing video markdown files" in

     

       65
       65
       -
           Arg.(value & opt string "data/videos" & info ["videos-dir"; "d"] ~docv:"DIR" ~doc)

     

       66
       66
       -
         in

     

       67
       67
       -
         let thumbs_dir =

     

       68
       68
       -
           let doc = "Directory to save thumbnails" in

     

       69
       69
       -
           Arg.(value & opt string "images/videos" & info ["thumbs-dir"; "t"] ~docv:"DIR" ~doc)

     

       70
       70
       -
         in

     

       71
       71
       -
         Term.(const (fun videos_dir thumbs_dir base_url () ->

     

       72
       72
       -
           Lwt_main.run (process_video_thumbs videos_dir thumbs_dir base_url); 0)

     

       73
       73
       -
           $ videos_dir $

     

       74
       74
       -
           thumbs_dir $

     

       75
       75
       -
           Bushel_common.url_term ~default:"https://crank.recoil.org" ~doc:"PeerTube base URL" $

     

       76
       76
       -
           Bushel_common.setup_term)

     

       77
       77
       -
       

     

       78
       78
       -
       let cmd =

     

       79
       79
       -
         let doc = "Download thumbnails for existing videos and update metadata" in

     

       80
       80
       -
         let info = Cmd.info "video-thumbs" ~doc in

     

       81
       81
       -
         Cmd.v info term

-20

stack/bushel/bin/dune

···

       1
       1
       -
       (library

     

       2
       2
       -
        (name bushel_common)

     

       3
       3
       -
        (modules bushel_common)

     

       4
       4
       -
        (libraries cmdliner))

     

       5
       5
       -
       

     

       6
       6
       -
       (executable

     

       7
       7
       -
        (name bushel_main)

     

       8
       8
       -
        (public_name bushel)

     

       9
       9
       -
        (package bushel)

     

       10
       10
       -
        (modules bushel_main bushel_bibtex bushel_ideas bushel_info bushel_missing bushel_note_doi bushel_obsidian bushel_paper_classify bushel_paper_tex bushel_thumbs bushel_search)

     

       11
       11
       -
        (flags (:standard -w -69))

     

       12
       12
       -
        (libraries bushel bushel_common cmdliner eio eio_main eiocmd yaml ezjsonm zotero-translation fmt cmarkit uri unix ptime.clock.os crockford))

     

       13
       13
       -
       

     

       14
       14
       -
       (executable

     

       15
       15
       -
        (name bushel_typesense)

     

       16
       16
       -
        (public_name bushel-typesense)

     

       17
       17
       -
        (package bushel)

     

       18
       18
       -
        (modules bushel_typesense)

     

       19
       19
       -
        (flags (:standard -w -69))

     

       20
       20
       -
        (libraries bushel bushel_common cmdliner eio eio_main eiocmd))

-51

stack/bushel/bushel.opam

···

       1
       1
       -
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       -
       opam-version: "2.0"

     

       3
       3
       -
       synopsis: "A webring but not as oldskool"

     

       4
       4
       -
       description: "This is all still a work in progress"

     

       5
       5
       -
       maintainer: ["anil@recoil.org"]

     

       6
       6
       -
       authors: ["Anil Madhavapeddy"]

     

       7
       7
       -
       license: "ISC"

     

       8
       8
       -
       homepage: "https://github.com/avsm/bushel"

     

       9
       9
       -
       bug-reports: "https://github.com/avsm/bushel/issues"

     

       10
       10
       -
       depends: [

     

       11
       11
       -
         "dune" {>= "3.17"}

     

       12
       12
       -
         "ocaml" {>= "5.2.0"}

     

       13
       13
       -
         "uri"

     

       14
       14
       -
         "cmarkit"

     

       15
       15
       -
         "ezjsonm"

     

       16
       16
       -
         "ptime"

     

       17
       17
       -
         "jsont"

     

       18
       18
       -
         "bytesrw"

     

       19
       19
       -
         "jekyll-format"

     

       20
       20
       -
         "yaml"

     

       21
       21
       -
         "eio"

     

       22
       22
       -
         "eio_main"

     

       23
       23
       -
         "requests"

     

       24
       24
       -
         "fmt"

     

       25
       25
       -
         "peertubee"

     

       26
       26
       -
         "karakeep"

     

       27
       27
       -
         "typesense-client"

     

       28
       28
       -
         "cmdliner"

     

       29
       29
       -
         "eiocmd"

     

       30
       30
       -
         "xdge"

     

       31
       31
       -
         "keyeio"

     

       32
       32
       -
         "odoc" {with-doc}

     

       33
       33
       -
       ]

     

       34
       34
       -
       build: [

     

       35
       35
       -
         ["dune" "subst"] {dev}

     

       36
       36
       -
         [

     

       37
       37
       -
           "dune"

     

       38
       38
       -
           "build"

     

       39
       39
       -
           "-p"

     

       40
       40
       -
           name

     

       41
       41
       -
           "-j"

     

       42
       42
       -
           jobs

     

       43
       43
       -
           "@install"

     

       44
       44
       -
           "@runtest" {with-test}

     

       45
       45
       -
           "@doc" {with-doc}

     

       46
       46
       -
         ]

     

       47
       47
       -
       ]

     

       48
       48
       -
       dev-repo: "git+https://github.com/avsm/bushel.git"

     

       49
       49
       -
       pin-depends: [

     

       50
       50
       -
        [ "zotero-translation.dev" "git+https://github.com/avsm/zotero-translation.git" ]

     

       51
       51
       -
       ]

-3

stack/bushel/bushel.opam.template

···

       1
       1
       -
       pin-depends: [

     

       2
       2
       -
        [ "zotero-translation.dev" "git+https://github.com/avsm/zotero-translation.git" ]

     

       3
       3
       -
       ]

-35

stack/bushel/dune-project

···

       1
       1
       -
       (lang dune 3.17)

     

       2
       2
       -
       (name bushel)

     

       3
       3
       -
       

     

       4
       4
       -
       (source (github avsm/bushel))

     

       5
       5
       -
       (license ISC)

     

       6
       6
       -
       (authors "Anil Madhavapeddy")

     

       7
       7
       -
       (maintainers "anil@recoil.org")

     

       8
       8
       -
       

     

       9
       9
       -
       (generate_opam_files true)

     

       10
       10
       -
       

     

       11
       11
       -
       (package

     

       12
       12
       -
        (name bushel)

     

       13
       13
       -
        (synopsis "A webring but not as oldskool")

     

       14
       14
       -
        (description "This is all still a work in progress")

     

       15
       15
       -
        (depends

     

       16
       16
       -
         (ocaml (>= "5.2.0"))

     

       17
       17
       -
         uri

     

       18
       18
       -
         cmarkit

     

       19
       19
       -
         ezjsonm

     

       20
       20
       -
         ptime

     

       21
       21
       -
         jsont

     

       22
       22
       -
         bytesrw

     

       23
       23
       -
         jekyll-format

     

       24
       24
       -
         yaml

     

       25
       25
       -
         eio

     

       26
       26
       -
         eio_main

     

       27
       27
       -
         requests

     

       28
       28
       -
         fmt

     

       29
       29
       -
         peertubee

     

       30
       30
       -
         karakeep

     

       31
       31
       -
         typesense-client

     

       32
       32
       -
         cmdliner

     

       33
       33
       -
         eiocmd

     

       34
       34
       -
         xdge

     

       35
       35
       -
         keyeio))

-79

stack/bushel/lib/bushel.ml

···

       1
       1
       -
       module Contact = Contact

     

       2
       2
       -
       module Idea = Idea

     

       3
       3
       -
       module Note = Note

     

       4
       4
       -
       module Paper = Paper

     

       5
       5
       -
       module Project = Project

     

       6
       6
       -
       module Video = Video

     

       7
       7
       -
       module Tags = Tags

     

       8
       8
       -
       module Link = Link

     

       9
       9
       -
       module Entry = Entry

     

       10
       10
       -
       module Util = Util

     

       11
       11
       -
       module Srcsetter = Srcsetter

     

       12
       12
       -
       module Md = Md

     

       13
       13
       -
       module Typesense = Typesense

     

       14
       14
       -
       module Link_graph = Link_graph

     

       15
       15
       -
       module Description = Description

     

       16
       16
       -
       module Doi_entry = Doi_entry

     

       17
       17
       -
       

     

       18
       18
       -
       let map_md base subdir fn =

     

       19
       19
       -
         let dir = base ^ "/data/" ^ subdir in

     

       20
       20
       -
         Sys.readdir dir

     

       21
       21
       -
         |> Array.to_list

     

       22
       22
       -
         |> List.filter (fun f -> Filename.check_suffix f ".md")

     

       23
       23
       -
         |> List.map (fun e -> fn dir e)

     

       24
       24
       -
       ;;

     

       25
       25
       -
       

     

       26
       26
       -
       let map_category base c fn = map_md base c (fun dir e -> fn @@ Filename.concat dir e)

     

       27
       27
       -
       let dbg l = Printf.eprintf "loading %s\n%!" l

     

       28
       28
       -
       

     

       29
       29
       -
       let load_contacts base = dbg "contacts"; map_category base "contacts" Contact.of_md

     

       30
       30
       -
       let load_projects base = dbg "projects"; map_category base "projects" Project.of_md

     

       31
       31
       -
       let load_notes base =

     

       32
       32
       -
         dbg "notes";

     

       33
       33
       -
         let notes_from_notes = map_category base "notes" Note.of_md in

     

       34
       34
       -
         let notes_from_news = map_category base "news" Note.of_md in

     

       35
       35
       -
         notes_from_notes @ notes_from_news

     

       36
       36
       -
       let load_ideas base = dbg "ideas"; map_category base "ideas" Idea.of_md

     

       37
       37
       -
       let load_videos base = dbg "videos"; map_category base "videos" Video.of_md

     

       38
       38
       -
       

     

       39
       39
       -
       let load_images base =

     

       40
       40
       -
         Printf.eprintf "load images %s/images\n%!" base;

     

       41
       41
       -
         try

     

       42
       42
       -
           Srcsetter.list_of_json (Util.read_file (base ^ "/images/index.json")) |> Result.get_ok

     

       43
       43
       -
         with

     

       44
       44
       -
         | _ -> [] (* FIXME log *)

     

       45
       45
       -
       ;;

     

       46
       46
       -
       

     

       47
       47
       -
       let load_papers base =

     

       48
       48
       -
         Printf.eprintf "load papers %s/data/papers\n%!" base;

     

       49
       49
       -
         Sys.readdir (base ^ "/data/papers")

     

       50
       50
       -
         |> Array.to_list

     

       51
       51
       -
         |> List.filter (fun slug -> Sys.is_directory (base ^ "/data/papers/" ^ slug))

     

       52
       52
       -
         |> List.map (fun slug ->

     

       53
       53
       -
           Sys.readdir (base ^ "/data/papers/" ^ slug)

     

       54
       54
       -
           |> Array.to_list

     

       55
       55
       -
           |> List.filter (fun ver -> Filename.check_suffix ver ".md")

     

       56
       56
       -
           |> List.map (fun ver ->

     

       57
       57
       -
             let ver = Filename.chop_extension ver in

     

       58
       58
       -
             Paper.of_md ~slug ~ver (base ^ "/data/papers/" ^ slug ^ "/" ^ ver ^ ".md")))

     

       59
       59
       -
         |> List.flatten

     

       60
       60
       -
         |> Paper.tv

     

       61
       61
       -
       ;;

     

       62
       62
       -
       

     

       63
       63
       -
       let load base =

     

       64
       64
       -
         let images = load_images base in

     

       65
       65
       -
         let papers = load_papers base in

     

       66
       66
       -
         let contacts = load_contacts base in

     

       67
       67
       -
         let projects = load_projects base in

     

       68
       68
       -
         let notes = load_notes base in

     

       69
       69
       -
         let ideas = load_ideas base in

     

       70
       70
       -
         let videos = load_videos base in

     

       71
       71
       -
         let entries = Entry.v ~images ~papers ~notes ~projects ~ideas ~videos ~contacts ~data_dir:(base ^ "/data") in

     

       72
       72
       -
         (* Build link graph *)

     

       73
       73
       -
         Printf.eprintf "Building link_graph...\n%!";

     

       74
       74
       -
         let graph = Link_graph.build_link_graph entries in

     

       75
       75
       -
         Fmt.epr "%a@." Link_graph.pp_graph graph;

     

       76
       76
       -
         Link_graph.set_graph graph;

     

       77
       77
       -
         entries

     

       78
       78
       -
       ;;

     

       79
       79
       -

-27

stack/bushel/lib/bushel.mli

···

       1
       1
       -
       (** Bushel *)

     

       2
       2
       -
       

     

       3
       3
       -
       module Contact = Contact

     

       4
       4
       -
       module Idea = Idea

     

       5
       5
       -
       module Note = Note

     

       6
       6
       -
       module Paper = Paper

     

       7
       7
       -
       module Project = Project

     

       8
       8
       -
       module Video = Video

     

       9
       9
       -
       module Tags = Tags

     

       10
       10
       -
       module Link = Link

     

       11
       11
       -
       module Entry = Entry

     

       12
       12
       -
       module Util = Util

     

       13
       13
       -
       module Md = Md

     

       14
       14
       -
       module Srcsetter = Srcsetter

     

       15
       15
       -
       module Typesense = Typesense

     

       16
       16
       -
       module Link_graph = Link_graph

     

       17
       17
       -
       module Description = Description

     

       18
       18
       -
       module Doi_entry = Doi_entry

     

       19
       19
       -
       

     

       20
       20
       -
       val load_contacts : string -> Contact.ts

     

       21
       21
       -
       val load_projects : string -> Project.ts

     

       22
       22
       -
       val load_notes : string -> Note.ts

     

       23
       23
       -
       val load_ideas : string -> Idea.ts

     

       24
       24
       -
       val load_videos : string -> Video.ts

     

       25
       25
       -
       val load_images : string -> Srcsetter.ts

     

       26
       26
       -
       val load_papers : string -> Paper.ts

     

       27
       27
       -
       val load : string -> Entry.t

-172

stack/bushel/lib/contact.ml

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { names : string list

     

       3
       3
       -
         ; handle : string

     

       4
       4
       -
         ; email : string option

     

       5
       5
       -
         ; icon : string option

     

       6
       6
       -
         ; github : string option

     

       7
       7
       -
         ; twitter : string option

     

       8
       8
       -
         ; bluesky : string option

     

       9
       9
       -
         ; mastodon : string option

     

       10
       10
       -
         ; orcid : string option

     

       11
       11
       -
         ; url : string option

     

       12
       12
       -
         ; atom : string list option

     

       13
       13
       -
         }

     

       14
       14
       -
       

     

       15
       15
       -
       type ts = t list

     

       16
       16
       -
       

     

       17
       17
       -
       let v ?email ?github ?twitter ?bluesky ?mastodon ?orcid ?icon ?url ?atom handle names =

     

       18
       18
       -
         { names; handle; email; github; twitter; bluesky; mastodon; orcid; url; icon; atom }

     

       19
       19
       -
       ;;

     

       20
       20
       -
       

     

       21
       21
       -
       let make names email icon github twitter bluesky mastodon orcid url atom =

     

       22
       22
       -
         v ?email ?github ?twitter ?bluesky ?mastodon ?orcid ?icon ?url ?atom "" names

     

       23
       23
       -
       ;;

     

       24
       24
       -
       

     

       25
       25
       -
       let names { names; _ } = names

     

       26
       26
       -
       let name { names; _ } = List.hd names

     

       27
       27
       -
       let handle { handle; _ } = handle

     

       28
       28
       -
       let email { email; _ } = email

     

       29
       29
       -
       let icon { icon; _ } = icon

     

       30
       30
       -
       let github { github; _ } = github

     

       31
       31
       -
       let twitter { twitter; _ } = twitter

     

       32
       32
       -
       let bluesky { bluesky; _ } = bluesky

     

       33
       33
       -
       let mastodon { mastodon; _ } = mastodon

     

       34
       34
       -
       let orcid { orcid; _ } = orcid

     

       35
       35
       -
       let url { url; _ } = url

     

       36
       36
       -
       let atom { atom; _ } = atom

     

       37
       37
       -
       

     

       38
       38
       -
       let json_t =

     

       39
       39
       -
         let open Jsont in

     

       40
       40
       -
         let open Jsont.Object in

     

       41
       41
       -
         let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in

     

       42
       42
       -
         map ~kind:"Contact" make

     

       43
       43
       -
         |> mem "names" (list string) ~dec_absent:[] ~enc:names

     

       44
       44
       -
         |> mem_opt "email" (some string) ~enc:email

     

       45
       45
       -
         |> mem_opt "icon" (some string) ~enc:icon

     

       46
       46
       -
         |> mem_opt "github" (some string) ~enc:github

     

       47
       47
       -
         |> mem_opt "twitter" (some string) ~enc:twitter

     

       48
       48
       -
         |> mem_opt "bluesky" (some string) ~enc:bluesky

     

       49
       49
       -
         |> mem_opt "mastodon" (some string) ~enc:mastodon

     

       50
       50
       -
         |> mem_opt "orcid" (some string) ~enc:orcid

     

       51
       51
       -
         |> mem_opt "url" (some string) ~enc:url

     

       52
       52
       -
         |> mem_opt "atom" (some (list string)) ~enc:atom

     

       53
       53
       -
         |> finish

     

       54
       54
       -
       ;;

     

       55
       55
       -
       

     

       56
       56
       -
       let v = Jsont_bytesrw.decode_string (Jsont.list json_t)

     

       57
       57
       -
       let compare a b = String.compare a.handle b.handle

     

       58
       58
       -
       let find_by_handle ts h = List.find_opt (fun { handle; _ } -> handle = h) ts

     

       59
       59
       -
       

     

       60
       60
       -
       let best_url c =

     

       61
       61
       -
         match c.url with

     

       62
       62
       -
         | Some v -> Some v

     

       63
       63
       -
         | None ->

     

       64
       64
       -
           (match c.github with

     

       65
       65
       -
            | Some v -> Some ("https://github.com/" ^ v)

     

       66
       66
       -
            | None ->

     

       67
       67
       -
              (match c.email with

     

       68
       68
       -
               | Some v -> Some ("mailto:" ^ v)

     

       69
       69
       -
               | None -> None))

     

       70
       70
       -
       ;;

     

       71
       71
       -
       

     

       72
       72
       -
       let of_md fname =

     

       73
       73
       -
         (* TODO fix Jekyll_post to not error on no date *)

     

       74
       74
       -
         let fname' = "2000-01-01-" ^ Filename.basename fname in

     

       75
       75
       -
         let handle = Filename.basename fname |> Filename.chop_extension in

     

       76
       76
       -
         match Jekyll_post.of_string ~fname:fname' (Util.read_file fname) with

     

       77
       77
       -
         | Error (`Msg m) -> failwith ("contact_of_md: " ^ m)

     

       78
       78
       -
         | Ok jp ->

     

       79
       79
       -
           let fields = jp.Jekyll_post.fields |> Jekyll_format.fields_to_yaml in

     

       80
       80
       -
           let c = Jsont_bytesrw.decode_string json_t (Ezjsonm.value_to_string fields) in

     

       81
       81
       -
           (match c with

     

       82
       82
       -
            | Error e -> failwith e

     

       83
       83
       -
            | Ok c -> { c with handle })

     

       84
       84
       -
       ;;

     

       85
       85
       -
       

     

       86
       86
       -
       (* Given a name, turn it lowercase and return the concatenation of the

     

       87
       87
       -
       initials of all the words in the name and the full last name. *)

     

       88
       88
       -
       let handle_of_name name =

     

       89
       89
       -
         let name = String.lowercase_ascii name in

     

       90
       90
       -
         let words = String.split_on_char ' ' name in

     

       91
       91
       -
         let initials = String.concat "" (List.map (fun w -> String.sub w 0 1) words) in

     

       92
       92
       -
         initials ^ List.hd (List.rev words)

     

       93
       93
       -
       ;;

     

       94
       94
       -
       

     

       95
       95
       -
       (* fuzzy lookup for an author. Strip out any non alpha numeric characters while

     

       96
       96
       -
          searching for the name *)

     

       97
       97
       -
       let lookup_by_name ts a =

     

       98
       98
       -
         let a = String.lowercase_ascii a in

     

       99
       99
       -
         let rec aux acc = function

     

       100
       100
       -
           | [] -> acc

     

       101
       101
       -
           | t :: ts ->

     

       102
       102
       -
             if List.exists (fun n -> String.lowercase_ascii n = a) t.names

     

       103
       103
       -
             then aux (t :: acc) ts

     

       104
       104
       -
             else aux acc ts

     

       105
       105
       -
         in

     

       106
       106
       -
         match aux [] ts with

     

       107
       107
       -
         | [ a ] -> a

     

       108
       108
       -
         | [] -> raise (Failure ("contact.ml: author not found: " ^ a))

     

       109
       109
       -
         | _ -> raise (Failure ("ambiguous author: " ^ a))

     

       110
       110
       -
       ;;

     

       111
       111
       -
       

     

       112
       112
       -
       (* TODO:claude *)

     

       113
       113
       -
       let typesense_schema =

     

       114
       114
       -
         let open Ezjsonm in

     

       115
       115
       -
         dict [

     

       116
       116
       -
           ("name", string "contacts");

     

       117
       117
       -
           ("fields", list (fun d -> dict d) [

     

       118
       118
       -
             [("name", string "id"); ("type", string "string")];

     

       119
       119
       -
             [("name", string "handle"); ("type", string "string")];

     

       120
       120
       -
             [("name", string "name"); ("type", string "string")];

     

       121
       121
       -
             [("name", string "names"); ("type", string "string[]"); ("optional", bool true)];

     

       122
       122
       -
             [("name", string "email"); ("type", string "string[]"); ("optional", bool true)];

     

       123
       123
       -
             [("name", string "icon"); ("type", string "string[]"); ("optional", bool true)];

     

       124
       124
       -
             [("name", string "github"); ("type", string "string[]"); ("optional", bool true)];

     

       125
       125
       -
             [("name", string "twitter"); ("type", string "string[]"); ("optional", bool true)];

     

       126
       126
       -
             [("name", string "bluesky"); ("type", string "string[]"); ("optional", bool true)];

     

       127
       127
       -
             [("name", string "mastodon"); ("type", string "string[]"); ("optional", bool true)];

     

       128
       128
       -
             [("name", string "orcid"); ("type", string "string[]"); ("optional", bool true)];

     

       129
       129
       -
             [("name", string "url"); ("type", string "string[]"); ("optional", bool true)];

     

       130
       130
       -
             [("name", string "atom"); ("type", string "string[]"); ("optional", bool true)];

     

       131
       131
       -
           ]);

     

       132
       132
       -
         ]

     

       133
       133
       -
       

     

       134
       134
       -
       (** TODO:claude Pretty-print a contact with ANSI formatting *)

     

       135
       135
       -
       let pp ppf c =

     

       136
       136
       -
         let open Fmt in

     

       137
       137
       -
         pf ppf "@[<v>";

     

       138
       138
       -
         pf ppf "%a: %a@," (styled `Bold string) "Type" (styled `Cyan string) "Contact";

     

       139
       139
       -
         pf ppf "%a: @%a@," (styled `Bold string) "Handle" string (handle c);

     

       140
       140
       -
         pf ppf "%a: %a@," (styled `Bold string) "Name" string (name c);

     

       141
       141
       -
         let ns = names c in

     

       142
       142
       -
         if List.length ns > 1 then

     

       143
       143
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Aliases" (list ~sep:comma string) (List.tl ns);

     

       144
       144
       -
         (match email c with

     

       145
       145
       -
          | Some e -> pf ppf "%a: %a@," (styled `Bold string) "Email" string e

     

       146
       146
       -
          | None -> ());

     

       147
       147
       -
         (match github c with

     

       148
       148
       -
          | Some g -> pf ppf "%a: https://github.com/%a@," (styled `Bold string) "GitHub" string g

     

       149
       149
       -
          | None -> ());

     

       150
       150
       -
         (match twitter c with

     

       151
       151
       -
          | Some t -> pf ppf "%a: https://twitter.com/%a@," (styled `Bold string) "Twitter" string t

     

       152
       152
       -
          | None -> ());

     

       153
       153
       -
         (match bluesky c with

     

       154
       154
       -
          | Some b -> pf ppf "%a: %a@," (styled `Bold string) "Bluesky" string b

     

       155
       155
       -
          | None -> ());

     

       156
       156
       -
         (match mastodon c with

     

       157
       157
       -
          | Some m -> pf ppf "%a: %a@," (styled `Bold string) "Mastodon" string m

     

       158
       158
       -
          | None -> ());

     

       159
       159
       -
         (match orcid c with

     

       160
       160
       -
          | Some o -> pf ppf "%a: https://orcid.org/%a@," (styled `Bold string) "ORCID" string o

     

       161
       161
       -
          | None -> ());

     

       162
       162
       -
         (match url c with

     

       163
       163
       -
          | Some u -> pf ppf "%a: %a@," (styled `Bold string) "URL" string u

     

       164
       164
       -
          | None -> ());

     

       165
       165
       -
         (match icon c with

     

       166
       166
       -
          | Some i -> pf ppf "%a: %a@," (styled `Bold string) "Icon" string i

     

       167
       167
       -
          | None -> ());

     

       168
       168
       -
         (match atom c with

     

       169
       169
       -
          | Some atoms when atoms <> [] ->

     

       170
       170
       -
            pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Atom Feeds" (list ~sep:comma string) atoms

     

       171
       171
       -
          | _ -> ());

     

       172
       172
       -
         pf ppf "@]"

-25

stack/bushel/lib/contact.mli

···

       1
       1
       -
       type t

     

       2
       2
       -
       type ts = t list

     

       3
       3
       -
       

     

       4
       4
       -
       val v : string -> (ts, string) result

     

       5
       5
       -
       val names : t -> string list

     

       6
       6
       -
       val name : t -> string

     

       7
       7
       -
       val handle : t -> string

     

       8
       8
       -
       val email : t -> string option

     

       9
       9
       -
       val icon : t -> string option

     

       10
       10
       -
       val github : t -> string option

     

       11
       11
       -
       val twitter : t -> string option

     

       12
       12
       -
       val bluesky : t -> string option

     

       13
       13
       -
       val mastodon : t -> string option

     

       14
       14
       -
       val orcid : t -> string option

     

       15
       15
       -
       val url : t -> string option

     

       16
       16
       -
       val atom : t -> string list option

     

       17
       17
       -
       val best_url : t -> string option

     

       18
       18
       -
       val find_by_handle : t list -> string -> t option

     

       19
       19
       -
       val handle_of_name : string -> string

     

       20
       20
       -
       val lookup_by_name : ts -> string -> t

     

       21
       21
       -
       val json_t : t Jsont.t

     

       22
       22
       -
       val compare : t -> t -> int

     

       23
       23
       -
       val of_md : string -> t

     

       24
       24
       -
       val typesense_schema : Ezjsonm.value

     

       25
       25
       -
       val pp : Format.formatter -> t -> unit

-72

stack/bushel/lib/description.ml

···

       1
       1
       -
       (** Generate descriptive text for bushel entries *)

     

       2
       2
       -
       

     

       3
       3
       -
       (* Helper to format a date as "Month Year" *)

     

       4
       4
       -
       let format_date date =

     

       5
       5
       -
         let (year, month, _day) = date in

     

       6
       6
       -
         let month_name = match month with

     

       7
       7
       -
           | 1 -> "January" | 2 -> "February" | 3 -> "March" | 4 -> "April"

     

       8
       8
       -
           | 5 -> "May" | 6 -> "June" | 7 -> "July" | 8 -> "August"

     

       9
       9
       -
           | 9 -> "September" | 10 -> "October" | 11 -> "November" | 12 -> "December"

     

       10
       10
       -
           | _ -> ""

     

       11
       11
       -
         in

     

       12
       12
       -
         Printf.sprintf "%s %d" month_name year

     

       13
       13
       -
       

     

       14
       14
       -
       (* Generate a descriptive sentence for a paper *)

     

       15
       15
       -
       let paper_description (p : Paper.t) ~date_str =

     

       16
       16
       -
         let venue = match String.lowercase_ascii (Paper.bibtype p) with

     

       17
       17
       -
           | "inproceedings" -> Paper.booktitle p

     

       18
       18
       -
           | "article" -> Paper.journal p

     

       19
       19
       -
           | "book" ->

     

       20
       20
       -
             let pub = Paper.publisher p in

     

       21
       21
       -
             if pub = "" then "Book" else "Book by " ^ pub

     

       22
       22
       -
           | "techreport" ->

     

       23
       23
       -
             (try "Technical report at " ^ Paper.institution p

     

       24
       24
       -
              with _ -> "Technical report")

     

       25
       25
       -
           | "misc" ->

     

       26
       26
       -
             let pub = Paper.publisher p in

     

       27
       27
       -
             if pub = "" then "Working paper" else "Working paper at " ^ pub

     

       28
       28
       -
           | _ -> "Publication"

     

       29
       29
       -
         in

     

       30
       30
       -
         Printf.sprintf "Paper in %s (%s)" venue date_str

     

       31
       31
       -
       

     

       32
       32
       -
       (* Generate a descriptive sentence for a note *)

     

       33
       33
       -
       let note_description (n : Note.t) ~date_str ~lookup_fn =

     

       34
       34
       -
         match Note.slug_ent n with

     

       35
       35
       -
         | Some slug_ent ->

     

       36
       36
       -
           (match lookup_fn slug_ent with

     

       37
       37
       -
            | Some related_title ->

     

       38
       38
       -
              Printf.sprintf "Note about %s (%s)" related_title date_str

     

       39
       39
       -
            | None -> Printf.sprintf "Research note (%s)" date_str)

     

       40
       40
       -
         | None -> Printf.sprintf "Research note (%s)" date_str

     

       41
       41
       -
       

     

       42
       42
       -
       (* Generate a descriptive sentence for an idea *)

     

       43
       43
       -
       let idea_description (i : Idea.t) ~date_str =

     

       44
       44
       -
         let status_str = String.lowercase_ascii (Idea.status_to_string (Idea.status i)) in

     

       45
       45
       -
         let level_str = Idea.level_to_string (Idea.level i) in

     

       46
       46
       -
         Printf.sprintf "Research idea (%s, %s level, %s)" status_str level_str date_str

     

       47
       47
       -
       

     

       48
       48
       -
       (* Generate a descriptive sentence for a video *)

     

       49
       49
       -
       let video_description (v : Video.t) ~date_str ~lookup_fn =

     

       50
       50
       -
         let video_type = if Video.talk v then "Talk video" else "Video" in

     

       51
       51
       -
         let context = match Video.paper v with

     

       52
       52
       -
           | Some paper_slug ->

     

       53
       53
       -
             (match lookup_fn paper_slug with

     

       54
       54
       -
              | Some title -> Printf.sprintf " about %s" title

     

       55
       55
       -
              | None -> "")

     

       56
       56
       -
           | None ->

     

       57
       57
       -
             (match Video.project v with

     

       58
       58
       -
              | Some project_slug ->

     

       59
       59
       -
                (match lookup_fn project_slug with

     

       60
       60
       -
                 | Some title -> Printf.sprintf " about %s" title

     

       61
       61
       -
                 | None -> "")

     

       62
       62
       -
              | None -> "")

     

       63
       63
       -
         in

     

       64
       64
       -
         Printf.sprintf "%s%s (%s)" video_type context date_str

     

       65
       65
       -
       

     

       66
       66
       -
       (* Generate a descriptive sentence for a project *)

     

       67
       67
       -
       let project_description (pr : Project.t) =

     

       68
       68
       -
         let end_str = match pr.Project.finish with

     

       69
       69
       -
           | Some year -> string_of_int year

     

       70
       70
       -
           | None -> "present"

     

       71
       71
       -
         in

     

       72
       72
       -
         Printf.sprintf "Project (%d–%s)" pr.Project.start end_str

-19

stack/bushel/lib/description.mli

···

       1
       1
       -
       (** Generate descriptive text for bushel entries *)

     

       2
       2
       -
       

     

       3
       3
       -
       (** Format a date as "Month Year" *)

     

       4
       4
       -
       val format_date : int * int * int -> string

     

       5
       5
       -
       

     

       6
       6
       -
       (** Generate a descriptive sentence for a paper with date string *)

     

       7
       7
       -
       val paper_description : Paper.t -> date_str:string -> string

     

       8
       8
       -
       

     

       9
       9
       -
       (** Generate a descriptive sentence for a note with date string and lookup function *)

     

       10
       10
       -
       val note_description : Note.t -> date_str:string -> lookup_fn:(string -> string option) -> string

     

       11
       11
       -
       

     

       12
       12
       -
       (** Generate a descriptive sentence for an idea with date string *)

     

       13
       13
       -
       val idea_description : Idea.t -> date_str:string -> string

     

       14
       14
       -
       

     

       15
       15
       -
       (** Generate a descriptive sentence for a video with date string and lookup function *)

     

       16
       16
       -
       val video_description : Video.t -> date_str:string -> lookup_fn:(string -> string option) -> string

     

       17
       17
       -
       

     

       18
       18
       -
       (** Generate a descriptive sentence for a project *)

     

       19
       19
       -
       val project_description : Project.t -> string

-147

stack/bushel/lib/doi_entry.ml

···

       1
       1
       -
       module J = Ezjsonm

     

       2
       2
       -
       

     

       3
       3
       -
       type status =

     

       4
       4
       -
         | Resolved

     

       5
       5
       -
         | Failed of string

     

       6
       6
       -
       

     

       7
       7
       -
       type t = {

     

       8
       8
       -
         doi: string;

     

       9
       9
       -
         title: string;

     

       10
       10
       -
         authors: string list;

     

       11
       11
       -
         year: int;

     

       12
       12
       -
         bibtype: string;

     

       13
       13
       -
         publisher: string;

     

       14
       14
       -
         resolved_at: string;

     

       15
       15
       -
         source_urls: string list;

     

       16
       16
       -
         status: status;

     

       17
       17
       -
         ignore: bool;

     

       18
       18
       -
       }

     

       19
       19
       -
       

     

       20
       20
       -
       type ts = t list

     

       21
       21
       -
       

     

       22
       22
       -
       let create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ?(source_urls=[]) () =

     

       23
       23
       -
         let resolved_at =

     

       24
       24
       -
           let now = Ptime_clock.now () in

     

       25
       25
       -
           let rfc3339 = Ptime.to_rfc3339 ~space:false ~frac_s:0 now in

     

       26
       26
       -
           String.sub rfc3339 0 10  (* Extract YYYY-MM-DD *)

     

       27
       27
       -
         in

     

       28
       28
       -
         { doi; title; authors; year; bibtype; publisher; resolved_at; source_urls; status = Resolved; ignore = false }

     

       29
       29
       -
       

     

       30
       30
       -
       let create_failed ~doi ~error ?(source_urls=[]) () =

     

       31
       31
       -
         let resolved_at =

     

       32
       32
       -
           let now = Ptime_clock.now () in

     

       33
       33
       -
           let rfc3339 = Ptime.to_rfc3339 ~space:false ~frac_s:0 now in

     

       34
       34
       -
           String.sub rfc3339 0 10  (* Extract YYYY-MM-DD *)

     

       35
       35
       -
         in

     

       36
       36
       -
         { doi; title = ""; authors = []; year = 0; bibtype = ""; publisher = "";

     

       37
       37
       -
           resolved_at; source_urls; status = Failed error; ignore = false }

     

       38
       38
       -
       

     

       39
       39
       -
       let merge_entries old_entry new_entry =

     

       40
       40
       -
         (* Combine source_urls, removing duplicates *)

     

       41
       41
       -
         let combined_urls =

     

       42
       42
       -
           List.sort_uniq String.compare (old_entry.source_urls @ new_entry.source_urls)

     

       43
       43
       -
         in

     

       44
       44
       -
         (* Use new_entry's data but with combined URLs and preserve ignore flag from old entry *)

     

       45
       45
       -
         { new_entry with source_urls = combined_urls; ignore = old_entry.ignore }

     

       46
       46
       -
       

     

       47
       47
       -
       let to_yaml_value entry =

     

       48
       48
       -
         let status_field = match entry.status with

     

       49
       49
       -
           | Resolved -> []

     

       50
       50
       -
           | Failed err -> [("error", `String err)]

     

       51
       51
       -
         in

     

       52
       52
       -
         let source_urls_field = match entry.source_urls with

     

       53
       53
       -
           | [] -> []

     

       54
       54
       -
           | urls -> [("source_urls", `A (List.map (fun url -> `String url) urls))]

     

       55
       55
       -
         in

     

       56
       56
       -
         let ignore_field = if entry.ignore then [("ignore", `Bool true)] else [] in

     

       57
       57
       -
         let fields = [

     

       58
       58
       -
           ("doi", `String entry.doi);

     

       59
       59
       -
           ("resolved_at", `String entry.resolved_at);

     

       60
       60
       -
         ] @ status_field @ source_urls_field @ ignore_field in

     

       61
       61
       -
         let fields = match entry.status with

     

       62
       62
       -
           | Resolved ->

     

       63
       63
       -
             fields @ [

     

       64
       64
       -
               ("title", `String entry.title);

     

       65
       65
       -
               ("authors", `A (List.map (fun a -> `String a) entry.authors));

     

       66
       66
       -
               ("year", `Float (float_of_int entry.year));

     

       67
       67
       -
               ("bibtype", `String entry.bibtype);

     

       68
       68
       -
               ("publisher", `String entry.publisher);

     

       69
       69
       -
             ]

     

       70
       70
       -
           | Failed _ -> fields

     

       71
       71
       -
         in

     

       72
       72
       -
         `O fields

     

       73
       73
       -
       

     

       74
       74
       -
       let of_yaml_value v =

     

       75
       75
       -
         try

     

       76
       76
       -
           let doi = J.find v ["doi"] |> J.get_string in

     

       77
       77
       -
           let resolved_at = J.find v ["resolved_at"] |> J.get_string in

     

       78
       78
       -
           (* Support both old source_url (single) and new source_urls (list) for backwards compatibility *)

     

       79
       79
       -
           let source_urls =

     

       80
       80
       -
             try

     

       81
       81
       -
               J.find v ["source_urls"] |> J.get_list J.get_string

     

       82
       82
       -
             with _ ->

     

       83
       83
       -
               try

     

       84
       84
       -
                 let single_url = J.find v ["source_url"] |> J.get_string in

     

       85
       85
       -
                 [single_url]

     

       86
       86
       -
               with _ -> []

     

       87
       87
       -
           in

     

       88
       88
       -
           let ignore = try J.find v ["ignore"] |> J.get_bool with _ -> false in

     

       89
       89
       -
           let error = try Some (J.find v ["error"] |> J.get_string) with _ -> None in

     

       90
       90
       -
           match error with

     

       91
       91
       -
           | Some err ->

     

       92
       92
       -
             { doi; title = ""; authors = []; year = 0; bibtype = ""; publisher = "";

     

       93
       93
       -
               resolved_at; source_urls; status = Failed err; ignore }

     

       94
       94
       -
           | None ->

     

       95
       95
       -
             let title = J.find v ["title"] |> J.get_string in

     

       96
       96
       -
             let authors = J.find v ["authors"] |> J.get_list J.get_string in

     

       97
       97
       -
             let year = J.find v ["year"] |> J.get_float |> int_of_float in

     

       98
       98
       -
             let bibtype = J.find v ["bibtype"] |> J.get_string in

     

       99
       99
       -
             let publisher = J.find v ["publisher"] |> J.get_string in

     

       100
       100
       -
             { doi; title; authors; year; bibtype; publisher; resolved_at; source_urls; status = Resolved; ignore }

     

       101
       101
       -
         with e ->

     

       102
       102
       -
           Printf.eprintf "Failed to parse DOI entry: %s\n%!" (Printexc.to_string e);

     

       103
       103
       -
           failwith "Invalid DOI entry in YAML"

     

       104
       104
       -
       

     

       105
       105
       -
       let load path =

     

       106
       106
       -
         if not (Sys.file_exists path) then

     

       107
       107
       -
           []

     

       108
       108
       -
         else

     

       109
       109
       -
           try

     

       110
       110
       -
             let yaml_str = In_channel.with_open_text path In_channel.input_all in

     

       111
       111
       -
             match Yaml.of_string yaml_str with

     

       112
       112
       -
             | Ok (`A entries) -> List.map of_yaml_value entries

     

       113
       113
       -
             | Ok _ -> []

     

       114
       114
       -
             | Error (`Msg e) ->

     

       115
       115
       -
               Printf.eprintf "Failed to parse %s: %s\n%!" path e;

     

       116
       116
       -
               []

     

       117
       117
       -
           with e ->

     

       118
       118
       -
             Printf.eprintf "Failed to load %s: %s\n%!" path (Printexc.to_string e);

     

       119
       119
       -
             []

     

       120
       120
       -
       

     

       121
       121
       -
       let save path entries =

     

       122
       122
       -
         let yaml_list = `A (List.map to_yaml_value entries) in

     

       123
       123
       -
         let yaml_str = Yaml.to_string_exn yaml_list in

     

       124
       124
       -
         Out_channel.with_open_text path (fun oc ->

     

       125
       125
       -
           Out_channel.output_string oc yaml_str

     

       126
       126
       -
         )

     

       127
       127
       -
       

     

       128
       128
       -
       let to_map entries =

     

       129
       129
       -
         let map = Hashtbl.create (List.length entries) in

     

       130
       130
       -
         List.iter (fun entry -> Hashtbl.add map entry.doi entry) entries;

     

       131
       131
       -
         map

     

       132
       132
       -
       

     

       133
       133
       -
       let find_by_doi entries doi =

     

       134
       134
       -
         List.find_opt (fun entry -> not entry.ignore && entry.doi = doi) entries

     

       135
       135
       -
       

     

       136
       136
       -
       let find_by_url entries url =

     

       137
       137
       -
         List.find_opt (fun entry ->

     

       138
       138
       -
           not entry.ignore && List.mem url entry.source_urls

     

       139
       139
       -
         ) entries

     

       140
       140
       -
       

     

       141
       141
       -
       let find_by_doi_including_ignored entries doi =

     

       142
       142
       -
         List.find_opt (fun entry -> entry.doi = doi) entries

     

       143
       143
       -
       

     

       144
       144
       -
       let find_by_url_including_ignored entries url =

     

       145
       145
       -
         List.find_opt (fun entry ->

     

       146
       146
       -
           List.mem url entry.source_urls

     

       147
       147
       -
         ) entries

-51

stack/bushel/lib/doi_entry.mli

···

       1
       1
       -
       (** DOI entries resolved from external sources via Zotero Translation Server *)

     

       2
       2
       -
       

     

       3
       3
       -
       type status =

     

       4
       4
       -
         | Resolved  (** Successfully resolved from Zotero *)

     

       5
       5
       -
         | Failed of string  (** Failed to resolve, with error message *)

     

       6
       6
       -
       

     

       7
       7
       -
       type t = {

     

       8
       8
       -
         doi: string;

     

       9
       9
       -
         title: string;

     

       10
       10
       -
         authors: string list;

     

       11
       11
       -
         year: int;

     

       12
       12
       -
         bibtype: string;  (** article, inproceedings, book, etc *)

     

       13
       13
       -
         publisher: string;  (** journal/conference/publisher name *)

     

       14
       14
       -
         resolved_at: string;  (** ISO date when resolved *)

     

       15
       15
       -
         source_urls: string list;  (** All URLs that resolve to this DOI (publisher links, doi.org URLs, etc) *)

     

       16
       16
       -
         status: status;

     

       17
       17
       -
         ignore: bool;  (** If true, skip this entry when looking up references *)

     

       18
       18
       -
       }

     

       19
       19
       -
       

     

       20
       20
       -
       type ts = t list

     

       21
       21
       -
       

     

       22
       22
       -
       (** Load DOI entries from YAML file *)

     

       23
       23
       -
       val load : string -> ts

     

       24
       24
       -
       

     

       25
       25
       -
       (** Save DOI entries to YAML file *)

     

       26
       26
       -
       val save : string -> ts -> unit

     

       27
       27
       -
       

     

       28
       28
       -
       (** Convert list to hashtable for fast lookup by DOI *)

     

       29
       29
       -
       val to_map : ts -> (string, t) Hashtbl.t

     

       30
       30
       -
       

     

       31
       31
       -
       (** Find entry by DOI (excludes ignored entries) *)

     

       32
       32
       -
       val find_by_doi : ts -> string -> t option

     

       33
       33
       -
       

     

       34
       34
       -
       (** Find entry by source URL (searches through all source_urls, excludes ignored entries) *)

     

       35
       35
       -
       val find_by_url : ts -> string -> t option

     

       36
       36
       -
       

     

       37
       37
       -
       (** Find entry by DOI including ignored entries (for resolution checks) *)

     

       38
       38
       -
       val find_by_doi_including_ignored : ts -> string -> t option

     

       39
       39
       -
       

     

       40
       40
       -
       (** Find entry by source URL including ignored entries (for resolution checks) *)

     

       41
       41
       -
       val find_by_url_including_ignored : ts -> string -> t option

     

       42
       42
       -
       

     

       43
       43
       -
       (** Create a new resolved entry *)

     

       44
       44
       -
       val create_resolved : doi:string -> title:string -> authors:string list ->

     

       45
       45
       -
         year:int -> bibtype:string -> publisher:string -> ?source_urls:string list -> unit -> t

     

       46
       46
       -
       

     

       47
       47
       -
       (** Create a new failed entry *)

     

       48
       48
       -
       val create_failed : doi:string -> error:string -> ?source_urls:string list -> unit -> t

     

       49
       49
       -
       

     

       50
       50
       -
       (** Merge two entries with the same DOI, combining their source_urls *)

     

       51
       51
       -
       val merge_entries : t -> t -> t

-19

stack/bushel/lib/dune

···

       1
       1
       -
       (library

     

       2
       2
       -
        (name bushel)

     

       3
       3
       -
        (public_name bushel)

     

       4
       4
       -
        (libraries

     

       5
       5
       -
         cmarkit

     

       6
       6
       -
         uri

     

       7
       7
       -
         jsont

     

       8
       8
       -
         jsont.bytesrw

     

       9
       9
       -
         ezjsonm

     

       10
       10
       -
         ptime

     

       11
       11
       -
         yaml.unix

     

       12
       12
       -
         jekyll-format

     

       13
       13
       -
         eio

     

       14
       14
       -
         requests

     

       15
       15
       -
         fmt

     

       16
       16
       -
         re

     

       17
       17
       -
         ptime.clock

     

       18
       18
       -
         ptime.clock.os

     

       19
       19
       -
         typesense-client))

-449

stack/bushel/lib/entry.ml

···

       1
       1
       -
       type entry =

     

       2
       2
       -
         [ `Paper of Paper.t

     

       3
       3
       -
         | `Project of Project.t

     

       4
       4
       -
         | `Idea of Idea.t

     

       5
       5
       -
         | `Video of Video.t

     

       6
       6
       -
         | `Note of Note.t

     

       7
       7
       -
         ]

     

       8
       8
       -
       

     

       9
       9
       -
       type slugs = (string, entry) Hashtbl.t

     

       10
       10
       -
       

     

       11
       11
       -
       type t =

     

       12
       12
       -
         { slugs : slugs

     

       13
       13
       -
         ; papers : Paper.ts

     

       14
       14
       -
         ; old_papers : Paper.ts

     

       15
       15
       -
         ; notes : Note.ts

     

       16
       16
       -
         ; projects : Project.ts

     

       17
       17
       -
         ; ideas : Idea.ts

     

       18
       18
       -
         ; videos : Video.ts

     

       19
       19
       -
         ; contacts : Contact.ts

     

       20
       20
       -
         ; images : Srcsetter.ts

     

       21
       21
       -
         ; doi_entries : Doi_entry.ts

     

       22
       22
       -
         ; data_dir : string

     

       23
       23
       -
         }

     

       24
       24
       -
       

     

       25
       25
       -
       let contacts { contacts; _ } = contacts

     

       26
       26
       -
       let videos { videos; _ } = videos

     

       27
       27
       -
       let ideas { ideas; _ } = ideas

     

       28
       28
       -
       let papers { papers; _ } = papers

     

       29
       29
       -
       let notes { notes; _ } = notes

     

       30
       30
       -
       let projects { projects; _ } = projects

     

       31
       31
       -
       let images { images; _ } = images

     

       32
       32
       -
       let doi_entries { doi_entries; _ } = doi_entries

     

       33
       33
       -
       let data_dir { data_dir; _ } = data_dir

     

       34
       34
       -
       

     

       35
       35
       -
       let v ~papers ~notes ~projects ~ideas ~videos ~contacts ~images ~data_dir =

     

       36
       36
       -
         let slugs : slugs = Hashtbl.create 42 in

     

       37
       37
       -
         let papers, old_papers = List.partition (fun p -> p.Paper.latest) papers in

     

       38
       38
       -
         List.iter (fun n -> Hashtbl.add slugs n.Note.slug (`Note n)) notes;

     

       39
       39
       -
         List.iter (fun p -> Hashtbl.add slugs p.Project.slug (`Project p)) projects;

     

       40
       40
       -
         List.iter (fun i -> Hashtbl.add slugs i.Idea.slug (`Idea i)) ideas;

     

       41
       41
       -
         List.iter (fun v -> Hashtbl.add slugs v.Video.slug (`Video v)) videos;

     

       42
       42
       -
         List.iter (fun p -> Hashtbl.add slugs p.Paper.slug (`Paper p)) papers;

     

       43
       43
       -
         (* Load DOI entries from doi.yml *)

     

       44
       44
       -
         let doi_yml_path = Filename.concat data_dir "doi.yml" in

     

       45
       45
       -
         let doi_entries = Doi_entry.load doi_yml_path in

     

       46
       46
       -
         { slugs; papers; old_papers; notes; projects; ideas; videos; images; contacts; doi_entries; data_dir }

     

       47
       47
       -
       ;;

     

       48
       48
       -
       

     

       49
       49
       -
       let lookup { slugs; _ } slug = Hashtbl.find_opt slugs slug

     

       50
       50
       -
       let lookup_exn { slugs; _ } slug = Hashtbl.find slugs slug

     

       51
       51
       -
       

     

       52
       52
       -
       let old_papers { old_papers; _ } = old_papers

     

       53
       53
       -
       

     

       54
       54
       -
       let sidebar = function

     

       55
       55
       -
         | `Note { Note.sidebar = Some s; _ } -> Some s

     

       56
       56
       -
         | _ -> None

     

       57
       57
       -
       ;;

     

       58
       58
       -
       

     

       59
       59
       -
       let to_type_string = function

     

       60
       60
       -
         | `Paper _ -> "paper"

     

       61
       61
       -
         | `Note _ -> "note"

     

       62
       62
       -
         | `Project _ -> "project"

     

       63
       63
       -
         | `Idea _ -> "idea"

     

       64
       64
       -
         | `Video _ -> "video"

     

       65
       65
       -
       ;;

     

       66
       66
       -
       

     

       67
       67
       -
       let synopsis = function

     

       68
       68
       -
         | `Note n -> Note.synopsis n

     

       69
       69
       -
         | _ -> None

     

       70
       70
       -
       ;;

     

       71
       71
       -
       

     

       72
       72
       -
       let slug = function

     

       73
       73
       -
         | `Paper p -> p.Paper.slug

     

       74
       74
       -
         | `Note n -> n.Note.slug

     

       75
       75
       -
         | `Project p -> p.Project.slug

     

       76
       76
       -
         | `Idea i -> i.Idea.slug

     

       77
       77
       -
         | `Video v -> v.Video.slug

     

       78
       78
       -
       ;;

     

       79
       79
       -
       

     

       80
       80
       -
       let title = function

     

       81
       81
       -
         | `Paper p -> Paper.title p

     

       82
       82
       -
         | `Note n -> Note.title n

     

       83
       83
       -
         | `Project p -> Project.title p

     

       84
       84
       -
         | `Idea i -> Idea.title i

     

       85
       85
       -
         | `Video v -> Video.title v

     

       86
       86
       -
       ;;

     

       87
       87
       -
       

     

       88
       88
       -
       let body = function

     

       89
       89
       -
         | `Paper _ -> ""

     

       90
       90
       -
         | `Note n -> Note.body n

     

       91
       91
       -
         | `Project p -> Project.body p

     

       92
       92
       -
         | `Idea i -> Idea.body i

     

       93
       93
       -
         | `Video _ -> ""

     

       94
       94
       -
       ;;

     

       95
       95
       -
       

     

       96
       96
       -
       let site_url = function

     

       97
       97
       -
         | `Paper p -> "/papers/" ^ p.Paper.slug

     

       98
       98
       -
         | `Note n -> "/notes/" ^ n.Note.slug

     

       99
       99
       -
         | `Project p -> "/projects/" ^ p.Project.slug

     

       100
       100
       -
         | `Idea i -> "/ideas/" ^ i.Idea.slug

     

       101
       101
       -
         | `Video v -> "/videos/" ^ v.Video.slug

     

       102
       102
       -
       ;;

     

       103
       103
       -
       

     

       104
       104
       -
       (** Extract external URLs from markdown content *)

     

       105
       105
       -
       let extract_external_links md =

     

       106
       106
       -
         let open Cmarkit in

     

       107
       107
       -
         let urls = ref [] in

     

       108
       108
       -
         

     

       109
       109
       -
         let is_external_url url =

     

       110
       110
       -
           (* XXX FIXME *)

     

       111
       111
       -
           let is_bushel_slug = String.starts_with ~prefix:":" in

     

       112
       112
       -
           let is_tag_slug = String.starts_with ~prefix:"##" in

     

       113
       113
       -
           if is_bushel_slug url || is_tag_slug url then false

     

       114
       114
       -
           else 

     

       115
       115
       -
             try

     

       116
       116
       -
               let uri = Uri.of_string url in

     

       117
       117
       -
               match Uri.scheme uri with

     

       118
       118
       -
               | Some s when s = "http" || s = "https" -> true

     

       119
       119
       -
               | Some _ -> true  (* Any other scheme is considered external *)

     

       120
       120
       -
               | None -> false   (* Local references or relative paths *)

     

       121
       121
       -
             with _ -> false

     

       122
       122
       -
         in

     

       123
       123
       -
         

     

       124
       124
       -
         let inline_mapper _ = function

     

       125
       125
       -
           | Inline.Link (lb, _) | Inline.Image (lb, _) ->

     

       126
       126
       -
               let ref = Inline.Link.reference lb in

     

       127
       127
       -
               (match ref with

     

       128
       128
       -
               | `Inline (ld, _) ->

     

       129
       129
       -
                   (match Link_definition.dest ld with

     

       130
       130
       -
                   | Some (url, _) when is_external_url url -> 

     

       131
       131
       -
                       urls := url :: !urls;

     

       132
       132
       -
                       Mapper.default

     

       133
       133
       -
                   | _ -> Mapper.default)

     

       134
       134
       -
               | `Ref (_, _, l) ->

     

       135
       135
       -
                   (* Get the referenced label definition and extract URL if it exists *)

     

       136
       136
       -
                   let defs = Doc.defs (Doc.of_string ~strict:false md) in

     

       137
       137
       -
                   (match Label.Map.find_opt (Label.key l) defs with

     

       138
       138
       -
                   | Some (Link_definition.Def (ld, _)) -> 

     

       139
       139
       -
                       (match Link_definition.dest ld with

     

       140
       140
       -
                       | Some (url, _) when is_external_url url ->

     

       141
       141
       -
                           urls := url :: !urls

     

       142
       142
       -
                       | _ -> ())

     

       143
       143
       -
                   | _ -> ());

     

       144
       144
       -
                   Mapper.default)

     

       145
       145
       -
           | Inline.Autolink (autolink, _) ->

     

       146
       146
       -
               let url = Inline.Autolink.link autolink |> fst in

     

       147
       147
       -
               if not (Inline.Autolink.is_email autolink) && is_external_url url then

     

       148
       148
       -
                 urls := url :: !urls;

     

       149
       149
       -
               Mapper.default

     

       150
       150
       -
           | _ -> Mapper.default

     

       151
       151
       -
         in

     

       152
       152
       -
         

     

       153
       153
       -
         let mapper = Mapper.make ~inline:inline_mapper () in

     

       154
       154
       -
         let doc = Doc.of_string ~strict:false md in

     

       155
       155
       -
         let _ = Mapper.map_doc mapper doc in

     

       156
       156
       -
         List.sort_uniq String.compare !urls

     

       157
       157
       -
       

     

       158
       158
       -
       let outgoing_links e = extract_external_links (body e)

     

       159
       159
       -
       

     

       160
       160
       -
       let lookup_site_url t slug =

     

       161
       161
       -
         match lookup t slug with

     

       162
       162
       -
         | Some ent -> site_url ent

     

       163
       163
       -
         | None -> ""

     

       164
       164
       -
       

     

       165
       165
       -
       let lookup_title t slug =

     

       166
       166
       -
         match lookup t slug with

     

       167
       167
       -
         | Some ent -> title ent

     

       168
       168
       -
         | None -> ""

     

       169
       169
       -
       

     

       170
       170
       -
       

     

       171
       171
       -
       let date (x : entry) =

     

       172
       172
       -
         match x with

     

       173
       173
       -
         | `Paper p -> Paper.date p

     

       174
       174
       -
         | `Note n -> Note.date n

     

       175
       175
       -
         | `Project p -> p.Project.start, 1, 1

     

       176
       176
       -
         | `Idea i -> i.Idea.year, i.Idea.month, 1

     

       177
       177
       -
         | `Video v -> Video.date v

     

       178
       178
       -
       ;;

     

       179
       179
       -
       

     

       180
       180
       -
       let datetime v = date v |> Ptime.of_date |> Option.get

     

       181
       181
       -
       

     

       182
       182
       -
       let year x =

     

       183
       183
       -
         match date x with

     

       184
       184
       -
         | y, _, _ -> y

     

       185
       185
       -
       ;;

     

       186
       186
       -
       

     

       187
       187
       -
       let is_index_entry = function

     

       188
       188
       -
         | `Note { Note.index_page; _ } -> index_page

     

       189
       189
       -
         | _ -> false

     

       190
       190
       -
       ;;

     

       191
       191
       -
       

     

       192
       192
       -
       let notes_for_slug { notes; _ } slug =

     

       193
       193
       -
         List.filter (fun n -> match Note.slug_ent n with Some s -> s = slug | None -> false) notes

     

       194
       194
       -
       let all_entries { slugs; _ } = Hashtbl.fold (fun _ v acc -> v :: acc) slugs []

     

       195
       195
       -
       

     

       196
       196
       -
       let all_papers { papers; old_papers; _ } =

     

       197
       197
       -
         List.map (fun x -> `Paper x) (papers @ old_papers)

     

       198
       198
       -
       ;;

     

       199
       199
       -
       

     

       200
       200
       -
       let compare a b =

     

       201
       201
       -
         let datetime v = Option.get (Ptime.of_date v) in

     

       202
       202
       -
         let da = datetime (date a) in

     

       203
       203
       -
         let db = datetime (date b) in

     

       204
       204
       -
         if da = db then compare (title a) (title b) else Ptime.compare da db

     

       205
       205
       -
       ;;

     

       206
       206
       -
       

     

       207
       207
       -
       let lookup_by_name {contacts;_} n =

     

       208
       208
       -
         match Contact.lookup_by_name contacts n with

     

       209
       209
       -
         | v -> Some v

     

       210
       210
       -
         | exception _ -> None

     

       211
       211
       -
       

     

       212
       212
       -
       (** Extract the first image URL from markdown text *)

     

       213
       213
       -
       let extract_first_image md =

     

       214
       214
       -
         let open Cmarkit in

     

       215
       215
       -
         (* Don't use bushel link resolver to avoid circular dependency *)

     

       216
       216
       -
         let doc = Doc.of_string md in

     

       217
       217
       -
         let found_image = ref None in

     

       218
       218
       -
       

     

       219
       219
       -
         let find_image_in_inline _mapper = function

     

       220
       220
       -
           | Inline.Image (img, _) ->

     

       221
       221
       -
             (match Inline.Link.reference img with

     

       222
       222
       -
              | `Inline (ld, _) ->

     

       223
       223
       -
                (match Link_definition.dest ld with

     

       224
       224
       -
                 | Some (url, _) when !found_image = None ->

     

       225
       225
       -
                   found_image := Some url;

     

       226
       226
       -
                   Mapper.default

     

       227
       227
       -
                 | _ -> Mapper.default)

     

       228
       228
       -
              | _ -> Mapper.default)

     

       229
       229
       -
           | _ -> Mapper.default

     

       230
       230
       -
         in

     

       231
       231
       -
       

     

       232
       232
       -
         let mapper = Mapper.make ~inline:find_image_in_inline () in

     

       233
       233
       -
         let _ = Mapper.map_doc mapper doc in

     

       234
       234
       -
         !found_image

     

       235
       235
       -
       ;;

     

       236
       236
       -
       

     

       237
       237
       -
       (** Extract the first video slug from markdown text by looking for bushel video links *)

     

       238
       238
       -
       let extract_first_video entries md =

     

       239
       239
       -
         let open Cmarkit in

     

       240
       240
       -
         let doc = Doc.of_string md in

     

       241
       241
       -
         let found_video = ref None in

     

       242
       242
       -
       

     

       243
       243
       -
         let find_video_in_inline _mapper = function

     

       244
       244
       -
           | Inline.Link (link, _) ->

     

       245
       245
       -
             (match Inline.Link.reference link with

     

       246
       246
       -
              | `Inline (ld, _) ->

     

       247
       247
       -
                (match Link_definition.dest ld with

     

       248
       248
       -
                 | Some (url, _) when !found_video = None && String.starts_with ~prefix:":" url ->

     

       249
       249
       -
                   (* Check if this is a video slug *)

     

       250
       250
       -
                   let slug = String.sub url 1 (String.length url - 1) in

     

       251
       251
       -
                   (match lookup entries slug with

     

       252
       252
       -
                    | Some (`Video v) ->

     

       253
       253
       -
                      found_video := Some (Video.uuid v);

     

       254
       254
       -
                      Mapper.default

     

       255
       255
       -
                    | _ -> Mapper.default)

     

       256
       256
       -
                 | _ -> Mapper.default)

     

       257
       257
       -
              | _ -> Mapper.default)

     

       258
       258
       -
           | _ -> Mapper.default

     

       259
       259
       -
         in

     

       260
       260
       -
       

     

       261
       261
       -
         let mapper = Mapper.make ~inline:find_video_in_inline () in

     

       262
       262
       -
         let _ = Mapper.map_doc mapper doc in

     

       263
       263
       -
         !found_video

     

       264
       264
       -
       ;;

     

       265
       265
       -
       

     

       266
       266
       -
       (** Look up an image in the srcsetter list by slug *)

     

       267
       267
       -
       let lookup_image { images; _ } slug =

     

       268
       268
       -
         List.find_opt (fun img -> Srcsetter.slug img = slug) images

     

       269
       269
       -
       

     

       270
       270
       -
       (** Get the smallest webp variant from a srcsetter image - prefers size just above 480px *)

     

       271
       271
       -
       let smallest_webp_variant img =

     

       272
       272
       -
         let variants = Srcsetter.variants img in

     

       273
       273
       -
         let webp_variants =

     

       274
       274
       -
           Srcsetter.MS.bindings variants

     

       275
       275
       -
           |> List.filter (fun (name, _) -> String.ends_with ~suffix:".webp" name)

     

       276
       276
       -
         in

     

       277
       277
       -
         match webp_variants with

     

       278
       278
       -
         | [] ->

     

       279
       279
       -
           (* No webp variants - use the name field which is always webp *)

     

       280
       280
       -
           "/images/" ^ Srcsetter.name img

     

       281
       281
       -
         | variants ->

     

       282
       282
       -
           (* Prefer variants with width > 480px, choosing the smallest one above 480 *)

     

       283
       283
       -
           let large_variants = List.filter (fun (_, (w, _)) -> w > 480) variants in

     

       284
       284
       -
           let candidates = if large_variants = [] then variants else large_variants in

     

       285
       285
       -
           (* Find the smallest variant from candidates *)

     

       286
       286
       -
           let smallest = List.fold_left (fun acc (name, (w, h)) ->

     

       287
       287
       -
             match acc with

     

       288
       288
       -
             | None -> Some (name, w, h)

     

       289
       289
       -
             | Some (_, min_w, _) when w < min_w -> Some (name, w, h)

     

       290
       290
       -
             | _ -> acc

     

       291
       291
       -
           ) None candidates in

     

       292
       292
       -
           match smallest with

     

       293
       293
       -
           | Some (name, _, _) -> "/images/" ^ name

     

       294
       294
       -
           | None -> "/images/" ^ Srcsetter.name img

     

       295
       295
       -
       

     

       296
       296
       -
       (** Get thumbnail slug for a contact *)

     

       297
       297
       -
       let contact_thumbnail_slug contact =

     

       298
       298
       -
         (* Contact images use just the handle as slug *)

     

       299
       299
       -
         Some (Contact.handle contact)

     

       300
       300
       -
       

     

       301
       301
       -
       (** Get thumbnail URL for a contact - resolved through srcsetter *)

     

       302
       302
       -
       let contact_thumbnail entries contact =

     

       303
       303
       -
         match contact_thumbnail_slug contact with

     

       304
       304
       -
         | None -> None

     

       305
       305
       -
         | Some thumb_slug ->

     

       306
       306
       -
           match lookup_image entries thumb_slug with

     

       307
       307
       -
           | Some img -> Some (smallest_webp_variant img)

     

       308
       308
       -
           | None -> None (* Image not in srcsetter - thumbnails are optional *)

     

       309
       309
       -
       

     

       310
       310
       -
       (** Get thumbnail slug for an entry with fallbacks *)

     

       311
       311
       -
       let rec thumbnail_slug entries = function

     

       312
       312
       -
         | `Paper p ->

     

       313
       313
       -
           (* Slug is just the paper slug, directory is in the origin path *)

     

       314
       314
       -
           Some (Paper.slug p)

     

       315
       315
       -
       

     

       316
       316
       -
         | `Video v ->

     

       317
       317
       -
           (* Videos use their UUID as the slug *)

     

       318
       318
       -
           Some (Video.uuid v)

     

       319
       319
       -
       

     

       320
       320
       -
         | `Project p ->

     

       321
       321
       -
           (* Project images use "project-{slug}" format *)

     

       322
       322
       -
           Some (Printf.sprintf "project-%s" p.Project.slug)

     

       323
       323
       -
       

     

       324
       324
       -
         | `Idea i ->

     

       325
       325
       -
           let is_active = match Idea.status i with

     

       326
       326
       -
             | Idea.Available | Idea.Discussion | Idea.Ongoing -> true

     

       327
       327
       -
             | Idea.Completed | Idea.Expired -> false

     

       328
       328
       -
           in

     

       329
       329
       -
           if is_active then

     

       330
       330
       -
             (* Use first supervisor's face image *)

     

       331
       331
       -
             let supervisors = Idea.supervisors i in

     

       332
       332
       -
             match supervisors with

     

       333
       333
       -
             | sup :: _ ->

     

       334
       334
       -
               let handle = if String.length sup > 0 && sup.[0] = '@'

     

       335
       335
       -
                 then String.sub sup 1 (String.length sup - 1)

     

       336
       336
       -
                 else sup

     

       337
       337
       -
               in

     

       338
       338
       -
               (match Contact.find_by_handle (contacts entries) handle with

     

       339
       339
       -
                | Some c ->

     

       340
       340
       -
                  (* Contact images use just the handle as slug *)

     

       341
       341
       -
                  Some (Contact.handle c)

     

       342
       342
       -
                | None ->

     

       343
       343
       -
                  (* Fallback to project thumbnail *)

     

       344
       344
       -
                  let project_slug = Idea.project i in

     

       345
       345
       -
                  (match lookup entries project_slug with

     

       346
       346
       -
                   | Some p -> thumbnail_slug entries p

     

       347
       347
       -
                   | None -> None))

     

       348
       348
       -
             | [] ->

     

       349
       349
       -
               (* No supervisors, use project thumbnail *)

     

       350
       350
       -
               let project_slug = Idea.project i in

     

       351
       351
       -
               (match lookup entries project_slug with

     

       352
       352
       -
                | Some p -> thumbnail_slug entries p

     

       353
       353
       -
                | None -> None)

     

       354
       354
       -
           else

     

       355
       355
       -
             (* Use project thumbnail for completed/expired ideas *)

     

       356
       356
       -
             let project_slug = Idea.project i in

     

       357
       357
       -
             (match lookup entries project_slug with

     

       358
       358
       -
              | Some p -> thumbnail_slug entries p

     

       359
       359
       -
              | None -> None)

     

       360
       360
       -
       

     

       361
       361
       -
         | `Note n ->

     

       362
       362
       -
           (* Use titleimage if set, otherwise extract first image from body, then try video, otherwise use slug_ent's thumbnail *)

     

       363
       363
       -
           (match Note.titleimage n with

     

       364
       364
       -
            | Some slug ->

     

       365
       365
       -
              (* Always treat titleimage as a bushel slug (without ':' prefix) *)

     

       366
       366
       -
              Some slug

     

       367
       367
       -
            | None ->

     

       368
       368
       -
              (* Extract first image from markdown body *)

     

       369
       369
       -
              match extract_first_image (Note.body n) with

     

       370
       370
       -
              | Some url when String.starts_with ~prefix:":" url ->

     

       371
       371
       -
                Some (String.sub url 1 (String.length url - 1))

     

       372
       372
       -
              | Some _ -> None

     

       373
       373
       -
              | None ->

     

       374
       374
       -
                (* Try extracting first video from markdown body *)

     

       375
       375
       -
                match extract_first_video entries (Note.body n) with

     

       376
       376
       -
                | Some video_uuid -> Some video_uuid

     

       377
       377
       -
                | None ->

     

       378
       378
       -
                  (* Fallback to slug_ent's thumbnail if present *)

     

       379
       379
       -
                  match Note.slug_ent n with

     

       380
       380
       -
                  | Some slug_ent ->

     

       381
       381
       -
                    (match lookup entries slug_ent with

     

       382
       382
       -
                     | Some entry -> thumbnail_slug entries entry

     

       383
       383
       -
                     | None -> None)

     

       384
       384
       -
                  | None -> None)

     

       385
       385
       -
       

     

       386
       386
       -
       (** Get thumbnail URL for an entry with fallbacks - resolved through srcsetter *)

     

       387
       387
       -
       let thumbnail entries entry =

     

       388
       388
       -
         match thumbnail_slug entries entry with

     

       389
       389
       -
         | None -> None

     

       390
       390
       -
         | Some thumb_slug ->

     

       391
       391
       -
           match lookup_image entries thumb_slug with

     

       392
       392
       -
           | Some img -> Some (smallest_webp_variant img)

     

       393
       393
       -
           | None ->

     

       394
       394
       -
             (* For projects, fallback to supervisor faces if project image doesn't exist *)

     

       395
       395
       -
             (match entry with

     

       396
       396
       -
              | `Project p ->

     

       397
       397
       -
                (* Find ideas for this project *)

     

       398
       398
       -
                let project_ideas = List.filter (fun idea ->

     

       399
       399
       -
                  Idea.project idea = ":" ^ p.Project.slug

     

       400
       400
       -
                ) (ideas entries) in

     

       401
       401
       -
                (* Collect all unique supervisors from these ideas *)

     

       402
       402
       -
                let all_supervisors =

     

       403
       403
       -
                  List.fold_left (fun acc idea ->

     

       404
       404
       -
                    List.fold_left (fun acc2 sup ->

     

       405
       405
       -
                      if List.mem sup acc2 then acc2 else sup :: acc2

     

       406
       406
       -
                    ) acc (Idea.supervisors idea)

     

       407
       407
       -
                  ) [] project_ideas

     

       408
       408
       -
                in

     

       409
       409
       -
                (* Split into avsm and others, preferring others first *)

     

       410
       410
       -
                let (others, avsm) = List.partition (fun sup ->

     

       411
       411
       -
                  let handle = if String.length sup > 0 && sup.[0] = '@'

     

       412
       412
       -
                    then String.sub sup 1 (String.length sup - 1)

     

       413
       413
       -
                    else sup

     

       414
       414
       -
                  in

     

       415
       415
       -
                  handle <> "avsm"

     

       416
       416
       -
                ) all_supervisors in

     

       417
       417
       -
                (* Try supervisors in order: others first, then avsm *)

     

       418
       418
       -
                let ordered_supervisors = others @ avsm in

     

       419
       419
       -
                (* Try each supervisor's face image *)

     

       420
       420
       -
                let rec try_supervisors = function

     

       421
       421
       -
                  | [] -> None

     

       422
       422
       -
                  | sup :: rest ->

     

       423
       423
       -
                    let handle = if String.length sup > 0 && sup.[0] = '@'

     

       424
       424
       -
                      then String.sub sup 1 (String.length sup - 1)

     

       425
       425
       -
                      else sup

     

       426
       426
       -
                    in

     

       427
       427
       -
                    (match Contact.find_by_handle (contacts entries) handle with

     

       428
       428
       -
                     | Some c ->

     

       429
       429
       -
                       (match lookup_image entries (Contact.handle c) with

     

       430
       430
       -
                        | Some img -> Some (smallest_webp_variant img)

     

       431
       431
       -
                        | None -> try_supervisors rest)

     

       432
       432
       -
                     | None -> try_supervisors rest)

     

       433
       433
       -
                in

     

       434
       434
       -
                try_supervisors ordered_supervisors

     

       435
       435
       -
              | _ -> None)

     

       436
       436
       -
       

     

       437
       437
       -
       (** Get thumbnail URL for a note with slug_ent *)

     

       438
       438
       -
       let thumbnail_note_with_ent entries note_item =

     

       439
       439
       -
         (* Use linked entry's thumbnail if slug_ent is set *)

     

       440
       440
       -
         match Note.slug_ent note_item with

     

       441
       441
       -
         | Some slug_ent ->

     

       442
       442
       -
           (match lookup entries (":" ^ slug_ent) with

     

       443
       443
       -
            | Some entry -> thumbnail entries entry

     

       444
       444
       -
            | None ->

     

       445
       445
       -
              (* Fallback to extracting first image from note body *)

     

       446
       446
       -
              extract_first_image (Note.body note_item))

     

       447
       447
       -
         | None ->

     

       448
       448
       -
           (* No slug_ent, extract from note body *)

     

       449
       449
       -
           extract_first_image (Note.body note_item)

-79

stack/bushel/lib/entry.mli

···

       1
       1
       -
       type entry =

     

       2
       2
       -
         [ `Idea of Idea.t

     

       3
       3
       -
         | `Note of Note.t

     

       4
       4
       -
         | `Paper of Paper.t

     

       5
       5
       -
         | `Project of Project.t

     

       6
       6
       -
         | `Video of Video.t

     

       7
       7
       -
         ]

     

       8
       8
       -
       

     

       9
       9
       -
       type slugs = (string, entry) Hashtbl.t

     

       10
       10
       -
       type t

     

       11
       11
       -
       

     

       12
       12
       -
       val contacts : t -> Contact.ts

     

       13
       13
       -
       val videos : t -> Video.ts

     

       14
       14
       -
       val ideas : t -> Idea.ts

     

       15
       15
       -
       val papers : t -> Paper.ts

     

       16
       16
       -
       val notes : t -> Note.ts

     

       17
       17
       -
       val projects : t -> Project.ts

     

       18
       18
       -
       val images : t -> Srcsetter.ts

     

       19
       19
       -
       val doi_entries : t -> Doi_entry.ts

     

       20
       20
       -
       val data_dir : t -> string

     

       21
       21
       -
       

     

       22
       22
       -
       val v

     

       23
       23
       -
         :  papers:Paper.t list

     

       24
       24
       -
         -> notes:Note.ts

     

       25
       25
       -
         -> projects:Project.ts

     

       26
       26
       -
         -> ideas:Idea.ts

     

       27
       27
       -
         -> videos:Video.ts

     

       28
       28
       -
         -> contacts:Contact.ts

     

       29
       29
       -
         -> images:Srcsetter.ts

     

       30
       30
       -
         -> data_dir:string

     

       31
       31
       -
         -> t

     

       32
       32
       -
       

     

       33
       33
       -
       val lookup : t -> string -> entry option

     

       34
       34
       -
       val lookup_exn : t -> string -> entry

     

       35
       35
       -
       val lookup_site_url : t -> string -> string

     

       36
       36
       -
       val lookup_title : t -> string -> string

     

       37
       37
       -
       val lookup_by_name : t -> string -> Contact.t option

     

       38
       38
       -
       val old_papers : t -> Paper.ts

     

       39
       39
       -
       val sidebar : [> `Note of Note.t ] -> string option

     

       40
       40
       -
       val to_type_string : entry -> string

     

       41
       41
       -
       val slug : entry -> string

     

       42
       42
       -
       val title : entry -> string

     

       43
       43
       -
       val body : entry -> string

     

       44
       44
       -
       val extract_external_links : string -> string list

     

       45
       45
       -
       val outgoing_links : entry -> string list

     

       46
       46
       -
       

     

       47
       47
       -
       (* FIXME move to view *)

     

       48
       48
       -
       val site_url : entry -> string

     

       49
       49
       -
       val date : entry -> Ptime.date

     

       50
       50
       -
       val datetime : entry -> Ptime.t

     

       51
       51
       -
       val year : entry -> int

     

       52
       52
       -
       val synopsis : entry -> string option

     

       53
       53
       -
       

     

       54
       54
       -
       val is_index_entry : entry -> bool

     

       55
       55
       -
       val notes_for_slug : t -> string -> Note.t list

     

       56
       56
       -
       val all_entries : t -> entry list

     

       57
       57
       -
       val all_papers : t -> entry list

     

       58
       58
       -
       val compare : entry -> entry -> int

     

       59
       59
       -
       

     

       60
       60
       -
       (** Look up an image in the srcsetter list by slug *)

     

       61
       61
       -
       val lookup_image : t -> string -> Srcsetter.t option

     

       62
       62
       -
       

     

       63
       63
       -
       (** Get the smallest webp variant from a srcsetter image *)

     

       64
       64
       -
       val smallest_webp_variant : Srcsetter.t -> string

     

       65
       65
       -
       

     

       66
       66
       -
       (** Get thumbnail slug for a contact *)

     

       67
       67
       -
       val contact_thumbnail_slug : Contact.t -> string option

     

       68
       68
       -
       

     

       69
       69
       -
       (** Get thumbnail URL for a contact - resolved through srcsetter *)

     

       70
       70
       -
       val contact_thumbnail : t -> Contact.t -> string option

     

       71
       71
       -
       

     

       72
       72
       -
       (** Get thumbnail slug for an entry with fallbacks *)

     

       73
       73
       -
       val thumbnail_slug : t -> entry -> string option

     

       74
       74
       -
       

     

       75
       75
       -
       (** Get thumbnail URL for an entry with fallbacks - resolved through srcsetter *)

     

       76
       76
       -
       val thumbnail : t -> entry -> string option

     

       77
       77
       -
       

     

       78
       78
       -
       (** Get thumbnail URL for a note with slug_ent *)

     

       79
       79
       -
       val thumbnail_note_with_ent : t -> Note.t -> string option

-223

stack/bushel/lib/idea.ml

···

       1
       1
       -
       type level =

     

       2
       2
       -
         | Any

     

       3
       3
       -
         | PartII

     

       4
       4
       -
         | MPhil

     

       5
       5
       -
         | PhD

     

       6
       6
       -
         | Postdoc

     

       7
       7
       -
       

     

       8
       8
       -
       let level_of_yaml = function

     

       9
       9
       -
         | `String ("Any" | "any") -> Ok Any

     

       10
       10
       -
         | `String ("PartII" | "partii") -> Ok PartII

     

       11
       11
       -
         | `String ("MPhil" | "mphil") -> Ok MPhil

     

       12
       12
       -
         | `String ("PhD" | "phd") -> Ok PhD

     

       13
       13
       -
         | `String ("postdoc" | "Postdoc") -> Ok Postdoc

     

       14
       14
       -
         | _ -> Error (`Msg "level_of_yaml")

     

       15
       15
       -
       ;;

     

       16
       16
       -
       

     

       17
       17
       -
       let level_to_string = function

     

       18
       18
       -
         | Any -> "Any"

     

       19
       19
       -
         | PartII -> "PartII"

     

       20
       20
       -
         | MPhil -> "MPhil"

     

       21
       21
       -
         | PhD -> "PhD"

     

       22
       22
       -
         | Postdoc -> "postdoctoral"

     

       23
       23
       -
       ;;

     

       24
       24
       -
       

     

       25
       25
       -
       let level_to_tag = function

     

       26
       26
       -
         | Any -> "idea-beginner"

     

       27
       27
       -
         | PartII -> "idea-medium"

     

       28
       28
       -
         | MPhil -> "idea-hard"

     

       29
       29
       -
         | PhD -> "idea-phd"

     

       30
       30
       -
         | Postdoc -> "idea-postdoc"

     

       31
       31
       -
       ;;

     

       32
       32
       -
       

     

       33
       33
       -
       let level_to_yaml s = `String (level_to_string s)

     

       34
       34
       -
       

     

       35
       35
       -
       type status =

     

       36
       36
       -
         | Available

     

       37
       37
       -
         | Discussion

     

       38
       38
       -
         | Ongoing

     

       39
       39
       -
         | Completed

     

       40
       40
       -
         | Expired

     

       41
       41
       -
       

     

       42
       42
       -
       let status_of_yaml = function

     

       43
       43
       -
         | `String ("Available" | "available") -> Ok Available

     

       44
       44
       -
         | `String ("Discussion" | "discussion") -> Ok Discussion

     

       45
       45
       -
         | `String ("Ongoing" | "ongoing") -> Ok Ongoing

     

       46
       46
       -
         | `String ("Completed" | "completed") -> Ok Completed

     

       47
       47
       -
         | `String ("Expired" | "expired") -> Ok Expired

     

       48
       48
       -
         | _ -> Error (`Msg "status_of_yaml")

     

       49
       49
       -
       ;;

     

       50
       50
       -
       

     

       51
       51
       -
       let status_to_string = function

     

       52
       52
       -
         | Available -> "Available"

     

       53
       53
       -
         | Discussion -> "Discussion"

     

       54
       54
       -
         | Ongoing -> "Ongoing"

     

       55
       55
       -
         | Completed -> "Completed"

     

       56
       56
       -
         | Expired -> "Expired"

     

       57
       57
       -
       ;;

     

       58
       58
       -
       

     

       59
       59
       -
       let status_to_tag = function

     

       60
       60
       -
         | Available -> "idea-available"

     

       61
       61
       -
         | Discussion -> "idea-discuss"

     

       62
       62
       -
         | Ongoing -> "idea-ongoing"

     

       63
       63
       -
         | Completed -> "idea-done"

     

       64
       64
       -
         | Expired -> "idea-expired"

     

       65
       65
       -
       ;;

     

       66
       66
       -
       

     

       67
       67
       -
       let status_to_yaml s = `String (status_to_string s)

     

       68
       68
       -
       

     

       69
       69
       -
       type t =

     

       70
       70
       -
         { slug : string

     

       71
       71
       -
         ; title : string

     

       72
       72
       -
         ; level : level

     

       73
       73
       -
         ; project : string

     

       74
       74
       -
         ; status : status

     

       75
       75
       -
         ; month: int

     

       76
       76
       -
         ; year : int

     

       77
       77
       -
         ; supervisors : string list

     

       78
       78
       -
         ; students : string list

     

       79
       79
       -
         ; reading : string

     

       80
       80
       -
         ; body : string

     

       81
       81
       -
         ; url : string option

     

       82
       82
       -
         ; tags : string list

     

       83
       83
       -
         }

     

       84
       84
       -
       

     

       85
       85
       -
       type ts = t list

     

       86
       86
       -
       

     

       87
       87
       -
       let title i = i.title

     

       88
       88
       -
       let supervisors i = i.supervisors

     

       89
       89
       -
       let students i = i.students

     

       90
       90
       -
       let reading i = i.reading

     

       91
       91
       -
       let status i = i.status

     

       92
       92
       -
       let level i = i.level

     

       93
       93
       -
       let year i = i.year

     

       94
       94
       -
       let body i = i.body

     

       95
       95
       -
       let project i = i.project

     

       96
       96
       -
       

     

       97
       97
       -
       let compare a b =

     

       98
       98
       -
         match compare a.status b.status with

     

       99
       99
       -
         | 0 ->

     

       100
       100
       -
           (match a.status with

     

       101
       101
       -
            | Completed -> compare b.year a.year

     

       102
       102
       -
            | _ ->

     

       103
       103
       -
              (match compare a.level b.level with

     

       104
       104
       -
               | 0 -> begin 

     

       105
       105
       -
                 match compare b.year a.year with

     

       106
       106
       -
                 | 0 -> compare b.month a.month

     

       107
       107
       -
                 | n -> n

     

       108
       108
       -
               end

     

       109
       109
       -
               | n -> n))

     

       110
       110
       -
         | n -> n

     

       111
       111
       -
       ;;

     

       112
       112
       -
       

     

       113
       113
       -
       let of_md fname =

     

       114
       114
       -
         match Jekyll_post.of_string ~fname:(Filename.basename fname) (Util.read_file fname) with

     

       115
       115
       -
         | Error _ -> failwith "TODO"

     

       116
       116
       -
         | Ok jp ->

     

       117
       117
       -
           let fields = jp.Jekyll_post.fields in

     

       118
       118
       -
           let y = Jekyll_format.fields_to_yaml fields in

     

       119
       119
       -
           let year, month, _ = jp.Jekyll_post.date |> Ptime.to_date in

     

       120
       120
       -
           let body = jp.Jekyll_post.body in

     

       121
       121
       -
           let string f = Yaml.Util.(find_exn f y |> Option.get |> to_string |> Result.get_ok) in

     

       122
       122
       -
           let string' f d =

     

       123
       123
       -
             try Yaml.Util.(find_exn f y |> Option.get |> to_string |> Result.get_ok) with

     

       124
       124
       -
             | _ -> d

     

       125
       125
       -
           in

     

       126
       126
       -
           let to_list = function

     

       127
       127
       -
             | `A l -> Ok l

     

       128
       128
       -
             | _ -> Error (`Msg "to_list")

     

       129
       129
       -
           in

     

       130
       130
       -
           let strings f =

     

       131
       131
       -
             try

     

       132
       132
       -
               Yaml.Util.(

     

       133
       133
       -
                 find_exn f y

     

       134
       134
       -
                 |> Option.get

     

       135
       135
       -
                 |> to_list

     

       136
       136
       -
                 |> Result.get_ok

     

       137
       137
       -
                 |> List.map (fun x -> to_string x |> Result.get_ok))

     

       138
       138
       -
             with

     

       139
       139
       -
             | _exn -> []

     

       140
       140
       -
           in

     

       141
       141
       -
           let level =

     

       142
       142
       -
             Yaml.Util.(find_exn "level" y |> Option.get |> level_of_yaml |> Result.get_ok)

     

       143
       143
       -
           in

     

       144
       144
       -
           let status =

     

       145
       145
       -
             Yaml.Util.(find_exn "status" y |> Option.get |> status_of_yaml |> Result.get_ok)

     

       146
       146
       -
           in

     

       147
       147
       -
           let slug = jp.Jekyll_post.slug in

     

       148
       148
       -
           { slug

     

       149
       149
       -
           ; title = string "title"

     

       150
       150
       -
           ; level

     

       151
       151
       -
           ; project = string "project"

     

       152
       152
       -
           ; status

     

       153
       153
       -
           ; supervisors = strings "supervisors"

     

       154
       154
       -
           ; students = strings "students"

     

       155
       155
       -
           ; tags = strings "tags"

     

       156
       156
       -
           ; reading = string' "reading" ""

     

       157
       157
       -
           ; month

     

       158
       158
       -
           ; year

     

       159
       159
       -
           ; body

     

       160
       160
       -
           ; url = None (* TODO *)

     

       161
       161
       -
           }

     

       162
       162
       -
       ;;

     

       163
       163
       -
       

     

       164
       164
       -
       let lookup ideas slug = List.find_opt (fun i -> i.slug = slug) ideas

     

       165
       165
       -
       

     

       166
       166
       -
       (* TODO:claude *)

     

       167
       167
       -
       let typesense_schema =

     

       168
       168
       -
         let open Ezjsonm in

     

       169
       169
       -
         dict [

     

       170
       170
       -
           ("name", string "ideas");

     

       171
       171
       -
           ("fields", list (fun d -> dict d) [

     

       172
       172
       -
             [("name", string "id"); ("type", string "string")];

     

       173
       173
       -
             [("name", string "title"); ("type", string "string")];

     

       174
       174
       -
             [("name", string "description"); ("type", string "string")];

     

       175
       175
       -
             [("name", string "year"); ("type", string "int32")];

     

       176
       176
       -
             [("name", string "date"); ("type", string "string")];

     

       177
       177
       -
             [("name", string "date_timestamp"); ("type", string "int64")];

     

       178
       178
       -
             [("name", string "tags"); ("type", string "string[]"); ("facet", bool true)];

     

       179
       179
       -
             [("name", string "level"); ("type", string "string"); ("facet", bool true)];

     

       180
       180
       -
             [("name", string "status"); ("type", string "string"); ("facet", bool true)];

     

       181
       181
       -
             [("name", string "project"); ("type", string "string"); ("facet", bool true)];

     

       182
       182
       -
             [("name", string "supervisors"); ("type", string "string[]"); ("optional", bool true)];

     

       183
       183
       -
             [("name", string "body"); ("type", string "string"); ("optional", bool true)];

     

       184
       184
       -
             [("name", string "students"); ("type", string "string[]"); ("optional", bool true)];

     

       185
       185
       -
             [("name", string "reading"); ("type", string "string"); ("optional", bool true)];

     

       186
       186
       -
             [("name", string "url"); ("type", string "string"); ("optional", bool true)];

     

       187
       187
       -
           ]);

     

       188
       188
       -
           ("default_sorting_field", string "date_timestamp");

     

       189
       189
       -
         ]

     

       190
       190
       -
       

     

       191
       191
       -
       (** TODO:claude Pretty-print an idea with ANSI formatting *)

     

       192
       192
       -
       let pp ppf i =

     

       193
       193
       -
         let open Fmt in

     

       194
       194
       -
         pf ppf "@[<v>";

     

       195
       195
       -
         pf ppf "%a: %a@," (styled `Bold string) "Type" (styled `Cyan string) "Idea";

     

       196
       196
       -
         pf ppf "%a: %a@," (styled `Bold string) "Slug" string i.slug;

     

       197
       197
       -
         pf ppf "%a: %a@," (styled `Bold string) "Title" string (title i);

     

       198
       198
       -
         pf ppf "%a: %a@," (styled `Bold string) "Level" string (level_to_string (level i));

     

       199
       199
       -
         pf ppf "%a: %a@," (styled `Bold string) "Status" string (status_to_string (status i));

     

       200
       200
       -
         pf ppf "%a: %a@," (styled `Bold string) "Project" string (project i);

     

       201
       201
       -
         pf ppf "%a: %04d-%02d@," (styled `Bold string) "Date" (year i) i.month;

     

       202
       202
       -
         let sups = supervisors i in

     

       203
       203
       -
         if sups <> [] then

     

       204
       204
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Supervisors" (list ~sep:comma string) sups;

     

       205
       205
       -
         let studs = students i in

     

       206
       206
       -
         if studs <> [] then

     

       207
       207
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Students" (list ~sep:comma string) studs;

     

       208
       208
       -
         (match i.url with

     

       209
       209
       -
          | Some url -> pf ppf "%a: %a@," (styled `Bold string) "URL" string url

     

       210
       210
       -
          | None -> ());

     

       211
       211
       -
         let t = i.tags in

     

       212
       212
       -
         if t <> [] then

     

       213
       213
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Tags" (list ~sep:comma string) t;

     

       214
       214
       -
         let r = reading i in

     

       215
       215
       -
         if r <> "" then begin

     

       216
       216
       -
           pf ppf "@,";

     

       217
       217
       -
           pf ppf "%a:@," (styled `Bold string) "Reading";

     

       218
       218
       -
           pf ppf "%a@," string r;

     

       219
       219
       -
         end;

     

       220
       220
       -
         pf ppf "@,";

     

       221
       221
       -
         pf ppf "%a:@," (styled `Bold string) "Body";

     

       222
       222
       -
         pf ppf "%a@," string (body i);

     

       223
       223
       -
         pf ppf "@]"

-55

stack/bushel/lib/idea.mli

···

       1
       1
       -
       type level =

     

       2
       2
       -
         | Any

     

       3
       3
       -
         | PartII

     

       4
       4
       -
         | MPhil

     

       5
       5
       -
         | PhD

     

       6
       6
       -
         | Postdoc

     

       7
       7
       -
       

     

       8
       8
       -
       type status =

     

       9
       9
       -
         | Available

     

       10
       10
       -
         | Discussion

     

       11
       11
       -
         | Ongoing

     

       12
       12
       -
         | Completed

     

       13
       13
       -
         | Expired

     

       14
       14
       -
       

     

       15
       15
       -
       val level_of_yaml : Ezjsonm.value -> (level, [> `Msg of string ]) result

     

       16
       16
       -
       val level_to_string : level -> string

     

       17
       17
       -
       val level_to_tag : level -> string

     

       18
       18
       -
       val level_to_yaml : level -> Ezjsonm.value

     

       19
       19
       -
       val status_of_yaml : Ezjsonm.value -> (status, [> `Msg of string ]) result

     

       20
       20
       -
       val status_to_string : status -> string

     

       21
       21
       -
       val status_to_tag : status -> string

     

       22
       22
       -
       val status_to_yaml : status -> Ezjsonm.value

     

       23
       23
       -
       

     

       24
       24
       -
       type t =

     

       25
       25
       -
         { slug : string

     

       26
       26
       -
         ; title : string

     

       27
       27
       -
         ; level : level

     

       28
       28
       -
         ; project : string

     

       29
       29
       -
         ; status : status

     

       30
       30
       -
         ; month : int

     

       31
       31
       -
         ; year : int

     

       32
       32
       -
         ; supervisors : string list

     

       33
       33
       -
         ; students : string list

     

       34
       34
       -
         ; reading : string

     

       35
       35
       -
         ; body : string

     

       36
       36
       -
         ; url : string option

     

       37
       37
       -
         ; tags : string list

     

       38
       38
       -
         }

     

       39
       39
       -
       

     

       40
       40
       -
       type ts = t list

     

       41
       41
       -
       

     

       42
       42
       -
       val title : t -> string

     

       43
       43
       -
       val supervisors : t -> string list

     

       44
       44
       -
       val students : t -> string list

     

       45
       45
       -
       val reading : t -> string

     

       46
       46
       -
       val status : t -> status

     

       47
       47
       -
       val level : t -> level

     

       48
       48
       -
       val year : t -> int

     

       49
       49
       -
       val body : t -> string

     

       50
       50
       -
       val project : t -> string

     

       51
       51
       -
       val compare : t -> t -> int

     

       52
       52
       -
       val lookup : t list -> string -> t option

     

       53
       53
       -
       val of_md : string -> t

     

       54
       54
       -
       val typesense_schema : Ezjsonm.value

     

       55
       55
       -
       val pp : Format.formatter -> t -> unit

-296

stack/bushel/lib/link.ml

···

       1
       1
       -
       type karakeep_data = {

     

       2
       2
       -
         remote_url : string;

     

       3
       3
       -
         id : string;

     

       4
       4
       -
         tags : string list;

     

       5
       5
       -
         metadata : (string * string) list;

     

       6
       6
       -
       }

     

       7
       7
       -
       

     

       8
       8
       -
       type bushel_data = {

     

       9
       9
       -
         slugs : string list;

     

       10
       10
       -
         tags : string list;

     

       11
       11
       -
       }

     

       12
       12
       -
       

     

       13
       13
       -
       type t = {

     

       14
       14
       -
         url : string;

     

       15
       15
       -
         date : Ptime.date;

     

       16
       16
       -
         description : string;

     

       17
       17
       -
         karakeep : karakeep_data option;

     

       18
       18
       -
         bushel : bushel_data option;

     

       19
       19
       -
       }

     

       20
       20
       -
       

     

       21
       21
       -
       type ts = t list

     

       22
       22
       -
       

     

       23
       23
       -
       let url { url; _ } = url

     

       24
       24
       -
       let date { date; _ } = date

     

       25
       25
       -
       let description { description; _ } = description

     

       26
       26
       -
       let datetime v = Option.get @@ Ptime.of_date @@ date v

     

       27
       27
       -
       let compare a b = Ptime.compare (datetime b) (datetime a)

     

       28
       28
       -
       

     

       29
       29
       -
       (* Convert YAML to Link.t *)

     

       30
       30
       -
       let t_of_yaml = function

     

       31
       31
       -
         | `O fields ->

     

       32
       32
       -
           let url =

     

       33
       33
       -
             match List.assoc_opt "url" fields with

     

       34
       34
       -
             | Some (`String v) -> v

     

       35
       35
       -
             | _ -> failwith "link: missing or invalid url"

     

       36
       36
       -
           in

     

       37
       37
       -
           let date = 

     

       38
       38
       -
             match List.assoc_opt "date" fields with

     

       39
       39
       -
             | Some (`String v) ->  begin

     

       40
       40
       -
                 try

     

       41
       41
       -
                   match Scanf.sscanf v "%04d-%02d-%02d" (fun y m d -> (y, m, d)) with

     

       42
       42
       -
                   | (y, m, d) -> (y, m, d)

     

       43
       43
       -
                 with _ ->

     

       44
       44
       -
                   (* Fall back to RFC3339 parsing for backward compatibility *)

     

       45
       45
       -
                   v |> Ptime.of_rfc3339 |> Result.get_ok |> fun (a, _, _) -> Ptime.to_date a

     

       46
       46
       -
             end

     

       47
       47
       -
             | _ -> failwith "link: missing or invalid date"

     

       48
       48
       -
           in

     

       49
       49
       -
           let description =

     

       50
       50
       -
             match List.assoc_opt "description" fields with

     

       51
       51
       -
             | Some (`String v) -> v

     

       52
       52
       -
             | _ -> ""

     

       53
       53
       -
           in

     

       54
       54
       -
           let karakeep =

     

       55
       55
       -
             match List.assoc_opt "karakeep" fields with

     

       56
       56
       -
             | Some (`O k_fields) ->

     

       57
       57
       -
                 let remote_url = 

     

       58
       58
       -
                   match List.assoc_opt "remote_url" k_fields with

     

       59
       59
       -
                   | Some (`String v) -> v

     

       60
       60
       -
                   | _ -> failwith "link: invalid karakeep.remote_url"

     

       61
       61
       -
                 in

     

       62
       62
       -
                 let id = 

     

       63
       63
       -
                   match List.assoc_opt "id" k_fields with

     

       64
       64
       -
                   | Some (`String v) -> v

     

       65
       65
       -
                   | _ -> failwith "link: invalid karakeep.id"

     

       66
       66
       -
                 in

     

       67
       67
       -
                 let tags =

     

       68
       68
       -
                   match List.assoc_opt "tags" k_fields with

     

       69
       69
       -
                   | Some (`A tag_list) ->

     

       70
       70
       -
                       List.fold_left (fun acc tag ->

     

       71
       71
       -
                         match tag with

     

       72
       72
       -
                         | `String t -> t :: acc

     

       73
       73
       -
                         | _ -> acc

     

       74
       74
       -
                       ) [] tag_list

     

       75
       75
       -
                       |> List.rev

     

       76
       76
       -
                   | _ -> []

     

       77
       77
       -
                 in

     

       78
       78
       -
                 let metadata =

     

       79
       79
       -
                   match List.assoc_opt "metadata" k_fields with

     

       80
       80
       -
                   | Some (`O meta_fields) -> 

     

       81
       81
       -
                       List.fold_left (fun acc (k, v) ->

     

       82
       82
       -
                         match v with

     

       83
       83
       -
                         | `String value -> (k, value) :: acc

     

       84
       84
       -
                         | _ -> acc

     

       85
       85
       -
                       ) [] meta_fields

     

       86
       86
       -
                   | _ -> []

     

       87
       87
       -
                 in

     

       88
       88
       -
                 Some { remote_url; id; tags; metadata }

     

       89
       89
       -
             | _ -> None

     

       90
       90
       -
           in

     

       91
       91
       -
           let bushel =

     

       92
       92
       -
             match List.assoc_opt "bushel" fields with

     

       93
       93
       -
             | Some (`O b_fields) ->

     

       94
       94
       -
                 let slugs =

     

       95
       95
       -
                   match List.assoc_opt "slugs" b_fields with

     

       96
       96
       -
                   | Some (`A slug_list) ->

     

       97
       97
       -
                       List.fold_left (fun acc slug ->

     

       98
       98
       -
                         match slug with

     

       99
       99
       -
                         | `String s -> s :: acc

     

       100
       100
       -
                         | _ -> acc

     

       101
       101
       -
                       ) [] slug_list

     

       102
       102
       -
                       |> List.rev

     

       103
       103
       -
                   | _ -> []

     

       104
       104
       -
                 in

     

       105
       105
       -
                 let tags =

     

       106
       106
       -
                   match List.assoc_opt "tags" b_fields with

     

       107
       107
       -
                   | Some (`A tag_list) ->

     

       108
       108
       -
                       List.fold_left (fun acc tag ->

     

       109
       109
       -
                         match tag with

     

       110
       110
       -
                         | `String t -> t :: acc

     

       111
       111
       -
                         | _ -> acc

     

       112
       112
       -
                       ) [] tag_list

     

       113
       113
       -
                       |> List.rev

     

       114
       114
       -
                   | _ -> []

     

       115
       115
       -
                 in

     

       116
       116
       -
                 Some { slugs; tags }

     

       117
       117
       -
             | _ -> None

     

       118
       118
       -
           in

     

       119
       119
       -
           { url; date; description; karakeep; bushel }

     

       120
       120
       -
         | _ -> failwith "invalid yaml"

     

       121
       121
       -
       

     

       122
       122
       -
       (* Read file contents *)

     

       123
       123
       -
       let read_file file = In_channel.(with_open_bin file input_all)

     

       124
       124
       -
       

     

       125
       125
       -
       (* Load links from a YAML file *)

     

       126
       126
       -
       let of_md fname =

     

       127
       127
       -
         match Yaml.of_string_exn (read_file fname) with

     

       128
       128
       -
         | `A links -> 

     

       129
       129
       -
             List.map t_of_yaml links

     

       130
       130
       -
         | `O _ as single_link -> 

     

       131
       131
       -
             [t_of_yaml single_link]

     

       132
       132
       -
         | _ -> failwith "link_of_md: expected array or object"

     

       133
       133
       -
       

     

       134
       134
       -
       (* Convert Link.t to YAML *)

     

       135
       135
       -
       let to_yaml t =

     

       136
       136
       -
         let (year, month, day) = t.date in

     

       137
       137
       -
         let date_str = Printf.sprintf "%04d-%02d-%02d" year month day in

     

       138
       138
       -
         

     

       139
       139
       -
         (* Create base fields *)

     

       140
       140
       -
         let base_fields = [

     

       141
       141
       -
           ("url", `String t.url);

     

       142
       142
       -
           ("date", `String date_str);

     

       143
       143
       -
         ] @ 

     

       144
       144
       -
         (if t.description = "" then [] else [("description", `String t.description)])

     

       145
       145
       -
         in

     

       146
       146
       -
         

     

       147
       147
       -
         (* Add karakeep data if present *)

     

       148
       148
       -
         let karakeep_fields =

     

       149
       149
       -
           match t.karakeep with

     

       150
       150
       -
           | Some { remote_url; id; tags; metadata } -> 

     

       151
       151
       -
               let karakeep_obj = [

     

       152
       152
       -
                 ("remote_url", `String remote_url);

     

       153
       153
       -
                 ("id", `String id);

     

       154
       154
       -
               ] in

     

       155
       155
       -
               let karakeep_obj = 

     

       156
       156
       -
                 if tags = [] then karakeep_obj

     

       157
       157
       -
                 else ("tags", `A (List.map (fun t -> `String t) tags)) :: karakeep_obj

     

       158
       158
       -
               in

     

       159
       159
       -
               let karakeep_obj =

     

       160
       160
       -
                 if metadata = [] then karakeep_obj

     

       161
       161
       -
                 else ("metadata", `O (List.map (fun (k, v) -> (k, `String v)) metadata)) :: karakeep_obj

     

       162
       162
       -
               in

     

       163
       163
       -
               [("karakeep", `O karakeep_obj)]

     

       164
       164
       -
           | None -> []

     

       165
       165
       -
         in

     

       166
       166
       -
         

     

       167
       167
       -
         (* Add bushel data if present *)

     

       168
       168
       -
         let bushel_fields =

     

       169
       169
       -
           match t.bushel with

     

       170
       170
       -
           | Some { slugs; tags } -> 

     

       171
       171
       -
               let bushel_obj = [] in

     

       172
       172
       -
               let bushel_obj = 

     

       173
       173
       -
                 if slugs = [] then bushel_obj

     

       174
       174
       -
                 else ("slugs", `A (List.map (fun s -> `String s) slugs)) :: bushel_obj

     

       175
       175
       -
               in

     

       176
       176
       -
               let bushel_obj =

     

       177
       177
       -
                 if tags = [] then bushel_obj

     

       178
       178
       -
                 else ("tags", `A (List.map (fun t -> `String t) tags)) :: bushel_obj

     

       179
       179
       -
               in

     

       180
       180
       -
               if bushel_obj = [] then [] else [("bushel", `O bushel_obj)]

     

       181
       181
       -
           | None -> []

     

       182
       182
       -
         in

     

       183
       183
       -
         

     

       184
       184
       -
         `O (base_fields @ karakeep_fields @ bushel_fields)

     

       185
       185
       -
       

     

       186
       186
       -
       (* Write a link to a file in the output directory *)

     

       187
       187
       -
       let to_file output_dir t =

     

       188
       188
       -
         let filename = 

     

       189
       189
       -
           let (y, m, d) = t.date in

     

       190
       190
       -
           let hash = Digest.string t.url |> Digest.to_hex in

     

       191
       191
       -
           let short_hash = String.sub hash 0 8 in

     

       192
       192
       -
           Printf.sprintf "%04d-%02d-%02d-%s.md" y m d short_hash

     

       193
       193
       -
         in

     

       194
       194
       -
         let file_path = Fpath.v (Filename.concat output_dir filename) in

     

       195
       195
       -
         let yaml = to_yaml t in

     

       196
       196
       -
         let yaml_str = Yaml.to_string_exn yaml in

     

       197
       197
       -
         let content = "---\n" ^ yaml_str ^ "---\n" in

     

       198
       198
       -
         Bos.OS.File.write file_path content

     

       199
       199
       -
       

     

       200
       200
       -
       (* Load links from a YAML file *)

     

       201
       201
       -
       let load_links_file path =

     

       202
       202
       -
         try

     

       203
       203
       -
           let yaml_str = In_channel.(with_open_bin path input_all) in

     

       204
       204
       -
           match Yaml.of_string_exn yaml_str with

     

       205
       205
       -
           | `A links -> List.map t_of_yaml links

     

       206
       206
       -
           | _ -> []

     

       207
       207
       -
         with _ -> []

     

       208
       208
       -
       

     

       209
       209
       -
       (* Save links to a YAML file *)

     

       210
       210
       -
       let save_links_file path links =

     

       211
       211
       -
         try

     

       212
       212
       -
           let yaml = `A (List.map to_yaml links) in

     

       213
       213
       -
           let yaml_str = Yaml.to_string_exn ~len:4200000 yaml in

     

       214
       214
       -
           let oc = open_out path in

     

       215
       215
       -
           output_string oc yaml_str;

     

       216
       216
       -
           close_out oc

     

       217
       217
       -
         with e ->

     

       218
       218
       -
           Printf.eprintf "Error saving links file: %s\n%!" (Printexc.to_string e);

     

       219
       219
       -
           Printf.eprintf "Attempting to save with smaller length limit...\n%!";

     

       220
       220
       -
           let yaml = `A (List.map to_yaml links) in

     

       221
       221
       -
           let yaml_str = Yaml.to_string_exn ~len:800000 yaml in

     

       222
       222
       -
           let oc = open_out path in

     

       223
       223
       -
           output_string oc yaml_str;

     

       224
       224
       -
           close_out oc

     

       225
       225
       -
       

     

       226
       226
       -
       (* Merge two lists of links, combining metadata from duplicates *)

     

       227
       227
       -
       let merge_links ?(prefer_new_date=false) existing new_links =

     

       228
       228
       -
         let links_by_url = Hashtbl.create (List.length existing) in

     

       229
       229
       -
         

     

       230
       230
       -
         (* Add existing links to hashtable *)

     

       231
       231
       -
         List.iter (fun link -> 

     

       232
       232
       -
           Hashtbl.replace links_by_url link.url link

     

       233
       233
       -
         ) existing;

     

       234
       234
       -
         

     

       235
       235
       -
         (* Merge new links with existing ones *)

     

       236
       236
       -
         List.iter (fun new_link ->

     

       237
       237
       -
           match Hashtbl.find_opt links_by_url new_link.url with

     

       238
       238
       -
           | None -> 

     

       239
       239
       -
               (* New link not in existing links *)

     

       240
       240
       -
               Hashtbl.add links_by_url new_link.url new_link

     

       241
       241
       -
           | Some old_link ->

     

       242
       242
       -
               (* Merge link data, prefer newer data for fields *)

     

       243
       243
       -
               let title = 

     

       244
       244
       -
                 if new_link.description <> "" then new_link.description 

     

       245
       245
       -
                 else old_link.description 

     

       246
       246
       -
               in

     

       247
       247
       -
               

     

       248
       248
       -
               (* Combine karakeep data (prefer new over old) *)

     

       249
       249
       -
               let karakeep = 

     

       250
       250
       -
                 match new_link.karakeep, old_link.karakeep with

     

       251
       251
       -
                 | Some new_k, Some old_k when new_k.remote_url = old_k.remote_url ->

     

       252
       252
       -
                     (* Same remote, merge the data *)

     

       253
       253
       -
                     let merged_metadata =

     

       254
       254
       -
                       let meta_tbl = Hashtbl.create (List.length old_k.metadata) in

     

       255
       255
       -
                       List.iter (fun (k, v) -> Hashtbl.replace meta_tbl k v) old_k.metadata;

     

       256
       256
       -
                       List.iter (fun (k, v) -> Hashtbl.replace meta_tbl k v) new_k.metadata;

     

       257
       257
       -
                       Hashtbl.fold (fun k v acc -> (k, v) :: acc) meta_tbl []

     

       258
       258
       -
                     in

     

       259
       259
       -
                     let merged_tags = List.sort_uniq String.compare (old_k.tags @ new_k.tags) in

     

       260
       260
       -
                     Some { new_k with metadata = merged_metadata; tags = merged_tags }

     

       261
       261
       -
                 | Some new_k, _ -> Some new_k

     

       262
       262
       -
                 | None, old_k -> old_k

     

       263
       263
       -
               in

     

       264
       264
       -
               

     

       265
       265
       -
               (* Combine bushel data *)

     

       266
       266
       -
               let bushel = 

     

       267
       267
       -
                 match new_link.bushel, old_link.bushel with

     

       268
       268
       -
                 | Some new_b, Some old_b ->

     

       269
       269
       -
                     (* Merge slugs and tags *)

     

       270
       270
       -
                     let merged_slugs = List.sort_uniq String.compare (old_b.slugs @ new_b.slugs) in

     

       271
       271
       -
                     let merged_tags = List.sort_uniq String.compare (old_b.tags @ new_b.tags) in

     

       272
       272
       -
                     Some { slugs = merged_slugs; tags = merged_tags }

     

       273
       273
       -
                 | Some new_b, _ -> Some new_b

     

       274
       274
       -
                 | None, old_b -> old_b

     

       275
       275
       -
               in

     

       276
       276
       -
               

     

       277
       277
       -
               (* Combined link - prefer new date when requested (for bushel entries) *)

     

       278
       278
       -
               let date = 

     

       279
       279
       -
                 if prefer_new_date then new_link.date

     

       280
       280
       -
                 else if compare new_link old_link > 0 then new_link.date 

     

       281
       281
       -
                 else old_link.date

     

       282
       282
       -
               in

     

       283
       283
       -
               let merged_link = {

     

       284
       284
       -
                 url = new_link.url;

     

       285
       285
       -
                 date;

     

       286
       286
       -
                 description = title;

     

       287
       287
       -
                 karakeep;

     

       288
       288
       -
                 bushel

     

       289
       289
       -
               } in

     

       290
       290
       -
               Hashtbl.replace links_by_url new_link.url merged_link

     

       291
       291
       -
         ) new_links;

     

       292
       292
       -
         

     

       293
       293
       -
         (* Convert hashtable back to list and sort by date *)

     

       294
       294
       -
         Hashtbl.to_seq_values links_by_url 

     

       295
       295
       -
         |> List.of_seq

     

       296
       296
       -
         |> List.sort compare

-34

stack/bushel/lib/link.mli

···

       1
       1
       -
       type karakeep_data = {

     

       2
       2
       -
         remote_url : string;

     

       3
       3
       -
         id : string;

     

       4
       4
       -
         tags : string list;

     

       5
       5
       -
         metadata : (string * string) list;

     

       6
       6
       -
       }

     

       7
       7
       -
       

     

       8
       8
       -
       type bushel_data = {

     

       9
       9
       -
         slugs : string list;

     

       10
       10
       -
         tags : string list;

     

       11
       11
       -
       }

     

       12
       12
       -
       

     

       13
       13
       -
       type t = {

     

       14
       14
       -
         url : string;

     

       15
       15
       -
         date : Ptime.date;

     

       16
       16
       -
         description : string;

     

       17
       17
       -
         karakeep : karakeep_data option;

     

       18
       18
       -
         bushel : bushel_data option;

     

       19
       19
       -
       }

     

       20
       20
       -
       

     

       21
       21
       -
       type ts = t list

     

       22
       22
       -
       

     

       23
       23
       -
       val compare : t -> t -> int

     

       24
       24
       -
       val url : t -> string

     

       25
       25
       -
       val date : t -> Ptime.date

     

       26
       26
       -
       val datetime : t -> Ptime.t

     

       27
       27
       -
       val description : t -> string

     

       28
       28
       -
       val of_md : string -> ts

     

       29
       29
       -
       val to_yaml : t -> Yaml.value

     

       30
       30
       -
       val t_of_yaml : Yaml.value -> t

     

       31
       31
       -
       val to_file : string -> t -> (unit, [> `Msg of string]) result

     

       32
       32
       -
       val load_links_file : string -> ts

     

       33
       33
       -
       val save_links_file : string -> ts -> unit

     

       34
       34
       -
       val merge_links : ?prefer_new_date:bool -> ts -> ts -> ts

-317

stack/bushel/lib/link_graph.ml

···

       1
       1
       -
       module StringSet = Set.Make(String)

     

       2
       2
       -
       

     

       3
       3
       -
       type entry_type = [ `Paper | `Project | `Note | `Idea | `Video | `Contact ]

     

       4
       4
       -
       

     

       5
       5
       -
       type internal_link = {

     

       6
       6
       -
         source: string;

     

       7
       7
       -
         target: string;

     

       8
       8
       -
         target_type: entry_type;

     

       9
       9
       -
       }

     

       10
       10
       -
       

     

       11
       11
       -
       type external_link = {

     

       12
       12
       -
         source: string;

     

       13
       13
       -
         domain: string;

     

       14
       14
       -
         url: string;

     

       15
       15
       -
       }

     

       16
       16
       -
       

     

       17
       17
       -
       type link_graph = {

     

       18
       18
       -
         (* All links *)

     

       19
       19
       -
         mutable internal_links: internal_link list;

     

       20
       20
       -
         mutable external_links: external_link list;

     

       21
       21
       -
       

     

       22
       22
       -
         (* Indices for efficient queries *)

     

       23
       23
       -
         outbound: (string, StringSet.t) Hashtbl.t;

     

       24
       24
       -
         backlinks: (string, StringSet.t) Hashtbl.t;

     

       25
       25
       -
         external_by_entry: (string, StringSet.t) Hashtbl.t;

     

       26
       26
       -
         external_by_domain: (string, StringSet.t) Hashtbl.t; (* domain -> source slugs *)

     

       27
       27
       -
       }

     

       28
       28
       -
       

     

       29
       29
       -
       let empty_graph () = {

     

       30
       30
       -
         internal_links = [];

     

       31
       31
       -
         external_links = [];

     

       32
       32
       -
         outbound = Hashtbl.create 256;

     

       33
       33
       -
         backlinks = Hashtbl.create 256;

     

       34
       34
       -
         external_by_entry = Hashtbl.create 256;

     

       35
       35
       -
         external_by_domain = Hashtbl.create 64;

     

       36
       36
       -
       }

     

       37
       37
       -
       

     

       38
       38
       -
       (* Global storage for the link graph *)

     

       39
       39
       -
       let current_graph : link_graph option ref = ref None

     

       40
       40
       -
       

     

       41
       41
       -
       let set_graph graph = current_graph := Some graph

     

       42
       42
       -
       let get_graph () = !current_graph

     

       43
       43
       -
       

     

       44
       44
       -
       let entry_type_to_string = function

     

       45
       45
       -
         | `Paper -> "paper"

     

       46
       46
       -
         | `Project -> "project"

     

       47
       47
       -
         | `Note -> "note"

     

       48
       48
       -
         | `Idea -> "idea"

     

       49
       49
       -
         | `Video -> "video"

     

       50
       50
       -
         | `Contact -> "contact"

     

       51
       51
       -
       

     

       52
       52
       -
       (* Query functions *)

     

       53
       53
       -
       

     

       54
       54
       -
       let get_outbound graph slug =

     

       55
       55
       -
         try StringSet.elements (Hashtbl.find graph.outbound slug)

     

       56
       56
       -
         with Not_found -> []

     

       57
       57
       -
       

     

       58
       58
       -
       let get_backlinks graph slug =

     

       59
       59
       -
         try StringSet.elements (Hashtbl.find graph.backlinks slug)

     

       60
       60
       -
         with Not_found -> []

     

       61
       61
       -
       

     

       62
       62
       -
       let get_external_links graph slug =

     

       63
       63
       -
         try StringSet.elements (Hashtbl.find graph.external_by_entry slug)

     

       64
       64
       -
         with Not_found -> []

     

       65
       65
       -
       

     

       66
       66
       -
       let get_entries_linking_to_domain graph domain =

     

       67
       67
       -
         try StringSet.elements (Hashtbl.find graph.external_by_domain domain)

     

       68
       68
       -
         with Not_found -> []

     

       69
       69
       -
       

     

       70
       70
       -
       (* Query functions that use the global graph *)

     

       71
       71
       -
       

     

       72
       72
       -
       let get_backlinks_for_slug slug =

     

       73
       73
       -
         match !current_graph with

     

       74
       74
       -
         | None -> []

     

       75
       75
       -
         | Some graph -> get_backlinks graph slug

     

       76
       76
       -
       

     

       77
       77
       -
       let get_outbound_for_slug slug =

     

       78
       78
       -
         match !current_graph with

     

       79
       79
       -
         | None -> []

     

       80
       80
       -
         | Some graph -> get_outbound graph slug

     

       81
       81
       -
       

     

       82
       82
       -
       let get_external_links_for_slug slug =

     

       83
       83
       -
         match !current_graph with

     

       84
       84
       -
         | None -> []

     

       85
       85
       -
         | Some graph -> get_external_links graph slug

     

       86
       86
       -
       

     

       87
       87
       -
       (* Pretty printing *)

     

       88
       88
       -
       

     

       89
       89
       -
       let pp_internal_link ppf (link : internal_link) =

     

       90
       90
       -
         Fmt.pf ppf "%s -> %s (%s)"

     

       91
       91
       -
           link.source

     

       92
       92
       -
           link.target

     

       93
       93
       -
           (entry_type_to_string link.target_type)

     

       94
       94
       -
       

     

       95
       95
       -
       let pp_external_link ppf (link : external_link) =

     

       96
       96
       -
         Fmt.pf ppf "%s -> %s (%s)"

     

       97
       97
       -
           link.source

     

       98
       98
       -
           link.domain

     

       99
       99
       -
           link.url

     

       100
       100
       -
       

     

       101
       101
       -
       let pp_graph ppf graph =

     

       102
       102
       -
         Fmt.pf ppf "@[<v>Internal links: %d@,External links: %d@,Entries with outbound: %d@,Entries with backlinks: %d@]"

     

       103
       103
       -
           (List.length graph.internal_links)

     

       104
       104
       -
           (List.length graph.external_links)

     

       105
       105
       -
           (Hashtbl.length graph.outbound)

     

       106
       106
       -
           (Hashtbl.length graph.backlinks)

     

       107
       107
       -
       

     

       108
       108
       -
       let entry_type_of_entry = function

     

       109
       109
       -
         | `Paper _ -> `Paper

     

       110
       110
       -
         | `Project _ -> `Project

     

       111
       111
       -
         | `Note _ -> `Note

     

       112
       112
       -
         | `Idea _ -> `Idea

     

       113
       113
       -
         | `Video _ -> `Video

     

       114
       114
       -
         | `Contact _ -> `Contact

     

       115
       115
       -
       

     

       116
       116
       -
       let extract_domain url =

     

       117
       117
       -
         try

     

       118
       118
       -
           let uri = Uri.of_string url in

     

       119
       119
       -
           match Uri.host uri with

     

       120
       120
       -
           | Some host -> host

     

       121
       121
       -
           | None -> "unknown"

     

       122
       122
       -
         with _ -> "unknown"

     

       123
       123
       -
       

     

       124
       124
       -
       let add_to_set_hashtbl tbl key value =

     

       125
       125
       -
         let current =

     

       126
       126
       -
           try Hashtbl.find tbl key

     

       127
       127
       -
           with Not_found -> StringSet.empty

     

       128
       128
       -
         in

     

       129
       129
       -
         Hashtbl.replace tbl key (StringSet.add value current)

     

       130
       130
       -
       

     

       131
       131
       -
       let build_link_graph entries =

     

       132
       132
       -
         let graph = empty_graph () in

     

       133
       133
       -
       

     

       134
       134
       -
         (* Helper to add internal link *)

     

       135
       135
       -
         let add_internal_link source target target_type =

     

       136
       136
       -
           let link = { source; target; target_type } in

     

       137
       137
       -
           graph.internal_links <- link :: graph.internal_links;

     

       138
       138
       -
           add_to_set_hashtbl graph.outbound source target;

     

       139
       139
       -
           add_to_set_hashtbl graph.backlinks target source

     

       140
       140
       -
         in

     

       141
       141
       -
       

     

       142
       142
       -
         (* Helper to add external link *)

     

       143
       143
       -
         let add_external_link source url =

     

       144
       144
       -
           let domain = extract_domain url in

     

       145
       145
       -
           let link = { source; domain; url } in

     

       146
       146
       -
           graph.external_links <- link :: graph.external_links;

     

       147
       147
       -
           add_to_set_hashtbl graph.external_by_entry source url;

     

       148
       148
       -
           add_to_set_hashtbl graph.external_by_domain domain source

     

       149
       149
       -
         in

     

       150
       150
       -
       

     

       151
       151
       -
         (* Process each entry *)

     

       152
       152
       -
         let process_entry entry =

     

       153
       153
       -
           let source_slug = Entry.slug entry in

     

       154
       154
       -
       

     

       155
       155
       -
           (* Get all links from this entry's markdown content *)

     

       156
       156
       -
           let md_content = Entry.body entry in

     

       157
       157
       -
           let all_links = Md.extract_all_links md_content in

     

       158
       158
       -
       

     

       159
       159
       -
           List.iter (fun link ->

     

       160
       160
       -
             if Md.is_bushel_slug link then

     

       161
       161
       -
               (* Internal bushel link *)

     

       162
       162
       -
               let target_slug = Md.strip_handle link in

     

       163
       163
       -
               match Entry.lookup entries target_slug with

     

       164
       164
       -
               | Some target_entry ->

     

       165
       165
       -
                 let target_type = entry_type_of_entry target_entry in

     

       166
       166
       -
                 add_internal_link source_slug target_slug target_type

     

       167
       167
       -
               | None -> ()

     

       168
       168
       -
             else if Md.is_contact_slug link then

     

       169
       169
       -
               (* Contact link *)

     

       170
       170
       -
               let handle = Md.strip_handle link in

     

       171
       171
       -
               match Contact.find_by_handle (Entry.contacts entries) handle with

     

       172
       172
       -
               | Some c ->

     

       173
       173
       -
                 let target_slug = Contact.handle c in

     

       174
       174
       -
                 add_internal_link source_slug target_slug `Contact

     

       175
       175
       -
               | None -> ()

     

       176
       176
       -
             else if Md.is_tag_slug link then

     

       177
       177
       -
               (* Skip tag links *)

     

       178
       178
       -
               ()

     

       179
       179
       -
             else if Md.is_type_filter_slug link then

     

       180
       180
       -
               (* Skip type filter links *)

     

       181
       181
       -
               ()

     

       182
       182
       -
             else if String.starts_with ~prefix:"http://" link ||

     

       183
       183
       -
                     String.starts_with ~prefix:"https://" link then

     

       184
       184
       -
               (* External link *)

     

       185
       185
       -
               add_external_link source_slug link

     

       186
       186
       -
             else

     

       187
       187
       -
               (* Skip other links (relative paths, etc) *)

     

       188
       188
       -
               ()

     

       189
       189
       -
           ) all_links

     

       190
       190
       -
         in

     

       191
       191
       -
       

     

       192
       192
       -
         (* Process all entries *)

     

       193
       193
       -
         List.iter process_entry (Entry.all_entries entries);

     

       194
       194
       -
       

     

       195
       195
       -
         (* Process slug_ent references from notes *)

     

       196
       196
       -
         let process_note_slug_ent note =

     

       197
       197
       -
           match Note.slug_ent note with

     

       198
       198
       -
           | Some target_slug ->

     

       199
       199
       -
             let source_slug = Note.slug note in

     

       200
       200
       -
             (* Look up the target entry by slug *)

     

       201
       201
       -
             (match Entry.lookup entries target_slug with

     

       202
       202
       -
              | Some target_entry ->

     

       203
       203
       -
                let target_type = entry_type_of_entry target_entry in

     

       204
       204
       -
                add_internal_link source_slug target_slug target_type

     

       205
       205
       -
              | None -> ())

     

       206
       206
       -
           | None -> ()

     

       207
       207
       -
         in

     

       208
       208
       -
         List.iter process_note_slug_ent (Entry.notes entries);

     

       209
       209
       -
       

     

       210
       210
       -
         (* Process projects: field from papers *)

     

       211
       211
       -
         let process_paper_projects paper =

     

       212
       212
       -
           let source_slug = Paper.slug paper in

     

       213
       213
       -
           let project_slugs = Paper.project_slugs paper in

     

       214
       214
       -
           List.iter (fun project_slug ->

     

       215
       215
       -
             (* Verify the project exists *)

     

       216
       216
       -
             match Entry.lookup entries project_slug with

     

       217
       217
       -
             | Some (`Project _) ->

     

       218
       218
       -
               add_internal_link source_slug project_slug `Project

     

       219
       219
       -
             | _ -> ()

     

       220
       220
       -
           ) project_slugs

     

       221
       221
       -
         in

     

       222
       222
       -
         List.iter process_paper_projects (Entry.papers entries);

     

       223
       223
       -
       

     

       224
       224
       -
         (* Deduplicate links *)

     

       225
       225
       -
         let module LinkSet = Set.Make(struct

     

       226
       226
       -
           type t = internal_link

     

       227
       227
       -
           let compare (a : internal_link) (b : internal_link) =

     

       228
       228
       -
             match String.compare a.source b.source with

     

       229
       229
       -
             | 0 -> String.compare a.target b.target

     

       230
       230
       -
             | n -> n

     

       231
       231
       -
         end) in

     

       232
       232
       -
       

     

       233
       233
       -
         let module ExtLinkSet = Set.Make(struct

     

       234
       234
       -
           type t = external_link

     

       235
       235
       -
           let compare (a : external_link) (b : external_link) =

     

       236
       236
       -
             match String.compare a.source b.source with

     

       237
       237
       -
             | 0 -> String.compare a.url b.url

     

       238
       238
       -
             | n -> n

     

       239
       239
       -
         end) in

     

       240
       240
       -
       

     

       241
       241
       -
         graph.internal_links <- LinkSet.elements (LinkSet.of_list graph.internal_links);

     

       242
       242
       -
         graph.external_links <- ExtLinkSet.elements (ExtLinkSet.of_list graph.external_links);

     

       243
       243
       -
       

     

       244
       244
       -
         graph

     

       245
       245
       -
       

     

       246
       246
       -
       (* Export for visualization *)

     

       247
       247
       -
       

     

       248
       248
       -
       let to_json graph entries =

     

       249
       249
       -
         (* Build nodes from entries *)

     

       250
       250
       -
         let entry_nodes = List.map (fun entry ->

     

       251
       251
       -
           let slug = Entry.slug entry in

     

       252
       252
       -
           let title = Entry.title entry in

     

       253
       253
       -
           let entry_type = entry_type_of_entry entry in

     

       254
       254
       -
           `O [

     

       255
       255
       -
             ("id", `String slug);

     

       256
       256
       -
             ("title", `String title);

     

       257
       257
       -
             ("type", `String (entry_type_to_string entry_type));

     

       258
       258
       -
             ("group", `String "entry");

     

       259
       259
       -
           ]

     

       260
       260
       -
         ) (Entry.all_entries entries) in

     

       261
       261
       -
       

     

       262
       262
       -
         (* Build nodes from contacts *)

     

       263
       263
       -
         let contact_nodes = List.map (fun contact ->

     

       264
       264
       -
           let handle = Contact.handle contact in

     

       265
       265
       -
           let name = Contact.name contact in

     

       266
       266
       -
           `O [

     

       267
       267
       -
             ("id", `String handle);

     

       268
       268
       -
             ("title", `String name);

     

       269
       269
       -
             ("type", `String "contact");

     

       270
       270
       -
             ("group", `String "entry");

     

       271
       271
       -
           ]

     

       272
       272
       -
         ) (Entry.contacts entries) in

     

       273
       273
       -
       

     

       274
       274
       -
         (* Build domain nodes from external links *)

     

       275
       275
       -
         let domain_map = Hashtbl.create 64 in

     

       276
       276
       -
         List.iter (fun link ->

     

       277
       277
       -
           if not (Hashtbl.mem domain_map link.domain) then

     

       278
       278
       -
             Hashtbl.add domain_map link.domain ()

     

       279
       279
       -
         ) graph.external_links;

     

       280
       280
       -
       

     

       281
       281
       -
         let domain_nodes = Hashtbl.fold (fun domain () acc ->

     

       282
       282
       -
           (`O [

     

       283
       283
       -
             ("id", `String ("domain:" ^ domain));

     

       284
       284
       -
             ("title", `String domain);

     

       285
       285
       -
             ("type", `String "domain");

     

       286
       286
       -
             ("group", `String "domain");

     

       287
       287
       -
           ]) :: acc

     

       288
       288
       -
         ) domain_map [] in

     

       289
       289
       -
       

     

       290
       290
       -
         let all_nodes = entry_nodes @ contact_nodes @ domain_nodes in

     

       291
       291
       -
       

     

       292
       292
       -
         (* Build internal links *)

     

       293
       293
       -
         let internal_links_json = List.map (fun (link : internal_link) ->

     

       294
       294
       -
           `O [

     

       295
       295
       -
             ("source", `String link.source);

     

       296
       296
       -
             ("target", `String link.target);

     

       297
       297
       -
             ("type", `String "internal");

     

       298
       298
       -
           ]

     

       299
       299
       -
         ) graph.internal_links in

     

       300
       300
       -
       

     

       301
       301
       -
         (* Build external links (entry -> domain) *)

     

       302
       302
       -
         let external_links_json = List.map (fun (link : external_link) ->

     

       303
       303
       -
           `O [

     

       304
       304
       -
             ("source", `String link.source);

     

       305
       305
       -
             ("target", `String ("domain:" ^ link.domain));

     

       306
       306
       -
             ("type", `String "external");

     

       307
       307
       -
           ]

     

       308
       308
       -
         ) graph.external_links in

     

       309
       309
       -
       

     

       310
       310
       -
         let all_links = internal_links_json @ external_links_json in

     

       311
       311
       -
       

     

       312
       312
       -
         let json = `O [

     

       313
       313
       -
           ("nodes", `A all_nodes);

     

       314
       314
       -
           ("links", `A all_links);

     

       315
       315
       -
         ] in

     

       316
       316
       -
       

     

       317
       317
       -
         Ezjsonm.to_string json

-781

stack/bushel/lib/md.ml

···

       1
       1
       -
       (** Bushel mappers for our Markdown extensions and utilities

     

       2
       2
       -
       

     

       3
       3
       -
           This module provides mappers to convert Bushel markdown extensions to different

     

       4
       4
       -
           output formats. There are two main mappers:

     

       5
       5
       -
       

     

       6
       6
       -
           1. {!make_bushel_inline_mapper} - Full sidenote mode for the main website

     

       7
       7
       -
              - Converts Bushel links to interactive sidenotes

     

       8
       8
       -
              - Includes entry previews, contact info, footnotes

     

       9
       9
       -
              - Used for the main site HTML rendering

     

       10
       10
       -
       

     

       11
       11
       -
           2. {!make_bushel_link_only_mapper} - Plain HTML mode for feeds and simple output

     

       12
       12
       -
              - Converts Bushel links to regular HTML <a> tags

     

       13
       13
       -
              - Automatically cleans up link text that contains Bushel slugs

     

       14
       14
       -
              - Used for Atom feeds, RSS, search indexing

     

       15
       15
       -
              - Images need .webp extension added (handled by calling code)

     

       16
       16
       -
       

     

       17
       17
       -
           For plain text output (search, LLM), use {!markdown_to_plaintext}.

     

       18
       18
       -
       *)

     

       19
       19
       -
       

     

       20
       20
       -
       (* Sidenote data types - reuse existing Bushel types *)

     

       21
       21
       -
       type sidenote_data =

     

       22
       22
       -
         | Contact_note of Contact.t * string (* contact data + trigger text *)

     

       23
       23
       -
         | Paper_note of Paper.t * string

     

       24
       24
       -
         | Idea_note of Idea.t * string

     

       25
       25
       -
         | Note_note of Note.t * string

     

       26
       26
       -
         | Project_note of Project.t * string

     

       27
       27
       -
         | Video_note of Video.t * string

     

       28
       28
       -
         | Footnote_note of string * Cmarkit.Block.t * string

     

       29
       29
       -
           (* slug, block content, trigger text *)

     

       30
       30
       -
       

     

       31
       31
       -
       type Cmarkit.Inline.t += Side_note of sidenote_data

     

       32
       32
       -
       

     

       33
       33
       -
       let authorlink = Cmarkit.Meta.key ()

     

       34
       34
       -
       

     

       35
       35
       -
       let make_authorlink label =

     

       36
       36
       -
         let meta = Cmarkit.Meta.tag authorlink (Cmarkit.Label.meta label) in

     

       37
       37
       -
         Cmarkit.Label.with_meta meta label

     

       38
       38
       -
       ;;

     

       39
       39
       -
       

     

       40
       40
       -
       let sluglink = Cmarkit.Meta.key ()

     

       41
       41
       -
       

     

       42
       42
       -
       let make_sluglink label =

     

       43
       43
       -
         let meta = Cmarkit.Meta.tag sluglink (Cmarkit.Label.meta label) in

     

       44
       44
       -
         Cmarkit.Label.with_meta meta label

     

       45
       45
       -
       ;;

     

       46
       46
       -
       

     

       47
       47
       -
       let with_bushel_links = function

     

       48
       48
       -
         | `Def _ as ctx -> Cmarkit.Label.default_resolver ctx

     

       49
       49
       -
         | `Ref (_, _, (Some _ as def)) -> def

     

       50
       50
       -
         | `Ref (_, ref, None) ->

     

       51
       51
       -
           let txt = Cmarkit.Label.key ref in

     

       52
       52
       -
           (match txt.[0] with

     

       53
       53
       -
            | '@' -> Some (make_authorlink ref)

     

       54
       54
       -
            | ':' -> Some (make_sluglink ref)

     

       55
       55
       -
            | '#' -> if txt.[1] = '#' then Some (make_sluglink ref) else None

     

       56
       56
       -
            | _ -> None)

     

       57
       57
       -
       ;;

     

       58
       58
       -
       

     

       59
       59
       -
       let strip_handle s =

     

       60
       60
       -
         if s.[0] = '@' || s.[0] = ':'

     

       61
       61
       -
         then String.sub s 1 (String.length s - 1)

     

       62
       62
       -
         else if s.[0] = '#' && s.[1] = '#'

     

       63
       63
       -
         then String.sub s 2 (String.length s - 2)

     

       64
       64
       -
         else s

     

       65
       65
       -
       ;;

     

       66
       66
       -
       

     

       67
       67
       -
       (* FIXME use Tags *)

     

       68
       68
       -
       let is_bushel_slug = String.starts_with ~prefix:":"

     

       69
       69
       -
       let is_tag_slug link =

     

       70
       70
       -
         String.starts_with ~prefix:"##" link &&

     

       71
       71
       -
         not (String.starts_with ~prefix:"###" link)

     

       72
       72
       -
       

     

       73
       73
       -
       let is_type_filter_slug = String.starts_with ~prefix:"###"

     

       74
       74
       -
       let is_contact_slug = String.starts_with ~prefix:"@"

     

       75
       75
       -
       

     

       76
       76
       -
       let text_of_inline lb =

     

       77
       77
       -
         let open Cmarkit in

     

       78
       78
       -
         Inline.to_plain_text ~break_on_soft:false lb

     

       79
       79
       -
         |> fun r -> String.concat "\n" (List.map (String.concat "") r)

     

       80
       80
       -
       ;;

     

       81
       81
       -
       

     

       82
       82
       -
       let link_target_is_bushel ?slugs lb =

     

       83
       83
       -
         let open Cmarkit in

     

       84
       84
       -
         let ref = Inline.Link.reference lb in

     

       85
       85
       -
         match ref with

     

       86
       86
       -
         | `Inline (ld, _) ->

     

       87
       87
       -
           let dest = Link_definition.dest ld in

     

       88
       88
       -
           (match dest with

     

       89
       89
       -
            | Some (url, _) when is_bushel_slug url ->

     

       90
       90
       -
              (match slugs with

     

       91
       91
       -
               | Some s -> Hashtbl.replace s url ()

     

       92
       92
       -
               | _ -> ());

     

       93
       93
       -
              Some (url, Inline.Link.text lb |> text_of_inline)

     

       94
       94
       -
            | Some (url, _) when is_tag_slug url ->

     

       95
       95
       -
              (* Return the tag URL unchanged - will be handled by renderer *)

     

       96
       96
       -
              Some (url, Inline.Link.text lb |> text_of_inline)

     

       97
       97
       -
            | Some (url, _) when is_contact_slug url ->

     

       98
       98
       -
              Some (url, Inline.Link.text lb |> text_of_inline)

     

       99
       99
       -
            | _ -> None)

     

       100
       100
       -
         | _ -> None

     

       101
       101
       -
       ;;

     

       102
       102
       -
       

     

       103
       103
       -
       let image_target_is_bushel lb =

     

       104
       104
       -
         let open Cmarkit in

     

       105
       105
       -
         let ref = Inline.Link.reference lb in

     

       106
       106
       -
         match ref with

     

       107
       107
       -
         | `Inline (ld, _) ->

     

       108
       108
       -
           let dest = Link_definition.dest ld in

     

       109
       109
       -
           (match dest with

     

       110
       110
       -
            | Some (url, _) when is_bushel_slug url ->

     

       111
       111
       -
              let alt = Link_definition.title ld in

     

       112
       112
       -
              let dir =

     

       113
       113
       -
                Inline.Link.text lb

     

       114
       114
       -
                |> Inline.to_plain_text ~break_on_soft:false

     

       115
       115
       -
                |> fun r -> String.concat "\n" (List.map (String.concat "") r)

     

       116
       116
       -
              in

     

       117
       117
       -
              Some (url, alt, dir)

     

       118
       118
       -
            | _ -> None)

     

       119
       119
       -
         | _ -> None

     

       120
       120
       -
       ;;

     

       121
       121
       -
       

     

       122
       122
       -
       let rewrite_bushel_link_reference entries slug title meta =

     

       123
       123
       -
         let open Cmarkit in

     

       124
       124
       -
         let s = strip_handle slug in

     

       125
       125
       -
         (* Check if it's a tag, contact, or entry *)

     

       126
       126
       -
         if is_tag_slug slug then

     

       127
       127
       -
           (* Tag link - keep the ## prefix in dest for renderer to detect *)

     

       128
       128
       -
           let txt = Inline.Text (title, meta) in

     

       129
       129
       -
           let ld = Link_definition.make ~dest:(slug, meta) () in

     

       130
       130
       -
           let ll = `Inline (ld, meta) in

     

       131
       131
       -
           let ld = Inline.Link.make txt ll in

     

       132
       132
       -
           Mapper.ret (Inline.Link (ld, meta))

     

       133
       133
       -
         else if is_contact_slug slug then

     

       134
       134
       -
           (* Contact sidenote *)

     

       135
       135
       -
           match Contact.find_by_handle (Entry.contacts entries) s with

     

       136
       136
       -
           | Some c ->

     

       137
       137
       -
               let sidenote = Side_note (Contact_note (c, title)) in

     

       138
       138
       -
               Mapper.ret sidenote

     

       139
       139
       -
           | None ->

     

       140
       140
       -
               (* Contact not found, fallback to regular link *)

     

       141
       141
       -
               let txt = Inline.Text (title, meta) in

     

       142
       142
       -
               let ld = Link_definition.make ~dest:("", meta) () in

     

       143
       143
       -
               let ll = `Inline (ld, meta) in

     

       144
       144
       -
               let ld = Inline.Link.make txt ll in

     

       145
       145
       -
               Mapper.ret (Inline.Link (ld, meta))

     

       146
       146
       -
         else

     

       147
       147
       -
           (* Check entry type and generate appropriate sidenote *)

     

       148
       148
       -
           match Entry.lookup entries s with

     

       149
       149
       -
           | Some (`Paper p) ->

     

       150
       150
       -
               let sidenote = Side_note (Paper_note (p, title)) in

     

       151
       151
       -
               Mapper.ret sidenote

     

       152
       152
       -
           | Some (`Idea i) ->

     

       153
       153
       -
               let sidenote = Side_note (Idea_note (i, title)) in

     

       154
       154
       -
               Mapper.ret sidenote

     

       155
       155
       -
           | Some (`Note n) ->

     

       156
       156
       -
               let sidenote = Side_note (Note_note (n, title)) in

     

       157
       157
       -
               Mapper.ret sidenote

     

       158
       158
       -
           | Some (`Project p) ->

     

       159
       159
       -
               let sidenote = Side_note (Project_note (p, title)) in

     

       160
       160
       -
               Mapper.ret sidenote

     

       161
       161
       -
           | Some (`Video v) ->

     

       162
       162
       -
               let sidenote = Side_note (Video_note (v, title)) in

     

       163
       163
       -
               Mapper.ret sidenote

     

       164
       164
       -
           | None ->

     

       165
       165
       -
               (* Entry not found, use regular link *)

     

       166
       166
       -
               let dest = Entry.lookup_site_url entries s in

     

       167
       167
       -
               let txt = Inline.Text (title, meta) in

     

       168
       168
       -
               let ld = Link_definition.make ~dest:(dest, meta) () in

     

       169
       169
       -
               let ll = `Inline (ld, meta) in

     

       170
       170
       -
               let ld = Inline.Link.make txt ll in

     

       171
       171
       -
               Mapper.ret (Inline.Link (ld, meta))

     

       172
       172
       -
       ;;

     

       173
       173
       -
       

     

       174
       174
       -
       let rewrite_bushel_image_reference entries url title dir meta =

     

       175
       175
       -
         let open Cmarkit in

     

       176
       176
       -
         let dest =

     

       177
       177
       -
           match Entry.lookup entries (strip_handle url) with

     

       178
       178
       -
           | Some ent -> Entry.site_url ent (* This is a video *)

     

       179
       179
       -
           | None -> Printf.sprintf "/images/%s" (strip_handle url)

     

       180
       180
       -
         in

     

       181
       181
       -
         let txt = Inline.Text (dir, meta) in

     

       182
       182
       -
         let ld = Link_definition.make ?title ~dest:(dest, meta) () in

     

       183
       183
       -
         let ll = `Inline (ld, meta) in

     

       184
       184
       -
         let ld = Inline.Link.make txt ll in

     

       185
       185
       -
         let ent_il = Inline.Image (ld, meta) in

     

       186
       186
       -
         Mapper.ret ent_il

     

       187
       187
       -
       ;;

     

       188
       188
       -
       

     

       189
       189
       -
       type Cmarkit.Inline.t += Obsidian_link of string

     

       190
       190
       -
       

     

       191
       191
       -
       let rewrite_label_reference_to_obsidian lb meta =

     

       192
       192
       -
         let open Cmarkit in

     

       193
       193
       -
         match Inline.Link.referenced_label lb with

     

       194
       194
       -
         | None -> Mapper.default

     

       195
       195
       -
         | Some l ->

     

       196
       196
       -
           let m = Label.meta l in

     

       197
       197
       -
           (match Meta.find authorlink m with

     

       198
       198
       -
            | Some () ->

     

       199
       199
       -
              let slug = Label.key l in

     

       200
       200
       -
              let target = Printf.sprintf "[[%s]]" slug in

     

       201
       201
       -
              let txt = Obsidian_link target in

     

       202
       202
       -
              Mapper.ret txt

     

       203
       203
       -
            | None ->

     

       204
       204
       -
              (match Meta.find sluglink m with

     

       205
       205
       -
               | None -> Mapper.default

     

       206
       206
       -
               | Some () ->

     

       207
       207
       -
                 let slug = Label.key l in

     

       208
       208
       -
                 if is_bushel_slug slug

     

       209
       209
       -
                 then (

     

       210
       210
       -
                   let target = Printf.sprintf "[[%s]]" (strip_handle slug) in

     

       211
       211
       -
                   let txt = Obsidian_link target in

     

       212
       212
       -
                   Mapper.ret txt)

     

       213
       213
       -
                 else if is_tag_slug slug

     

       214
       214
       -
                 then (

     

       215
       215
       -
                   let target = Printf.sprintf "#%s" (strip_handle slug) in

     

       216
       216
       -
                   let txt = Inline.Text (target, meta) in

     

       217
       217
       -
                   Mapper.ret txt)

     

       218
       218
       -
                 else Mapper.default))

     

       219
       219
       -
       ;;

     

       220
       220
       -
       

     

       221
       221
       -
       let make_bushel_link_only_mapper _defs entries =

     

       222
       222
       -
         let open Cmarkit in

     

       223
       223
       -
         fun _m ->

     

       224
       224
       -
           function

     

       225
       225
       -
           | Inline.Link (lb, meta) ->

     

       226
       226
       -
             (* Convert Bushel link references to regular links (not sidenotes) *)

     

       227
       227
       -
             (match link_target_is_bushel lb with

     

       228
       228
       -
              | Some (url, title) ->

     

       229
       229
       -
                let s = strip_handle url in

     

       230
       230
       -
                let dest = Entry.lookup_site_url entries s in

     

       231
       231
       -
                (* If title is itself a Bushel slug, use the entry title instead *)

     

       232
       232
       -
                let link_text =

     

       233
       233
       -
                  if is_bushel_slug title then

     

       234
       234
       -
                    match Entry.lookup entries (strip_handle title) with

     

       235
       235
       -
                    | Some ent -> Entry.title ent

     

       236
       236
       -
                    | None -> title

     

       237
       237
       -
                  else title

     

       238
       238
       -
                in

     

       239
       239
       -
                let txt = Inline.Text (link_text, meta) in

     

       240
       240
       -
                let ld = Link_definition.make ~dest:(dest, meta) () in

     

       241
       241
       -
                let ll = `Inline (ld, meta) in

     

       242
       242
       -
                let ld = Inline.Link.make txt ll in

     

       243
       243
       -
                Mapper.ret (Inline.Link (ld, meta))

     

       244
       244
       -
              | None ->

     

       245
       245
       -
                (match Inline.Link.referenced_label lb with

     

       246
       246
       -
                 | Some l ->

     

       247
       247
       -
                   let m = Label.meta l in

     

       248
       248
       -
                   (* Check for authorlink (contact) first *)

     

       249
       249
       -
                   (match Meta.find authorlink m with

     

       250
       250
       -
                    | Some () ->

     

       251
       251
       -
                      let slug = Label.key l in

     

       252
       252
       -
                      let s = strip_handle slug in

     

       253
       253
       -
                      (match Contact.find_by_handle (Entry.contacts entries) s with

     

       254
       254
       -
                       | Some c ->

     

       255
       255
       -
                         let name = Contact.name c in

     

       256
       256
       -
                         (match Contact.best_url c with

     

       257
       257
       -
                          | Some dest ->

     

       258
       258
       -
                            let txt = Inline.Text (name, meta) in

     

       259
       259
       -
                            let ld = Link_definition.make ~dest:(dest, meta) () in

     

       260
       260
       -
                            let ll = `Inline (ld, meta) in

     

       261
       261
       -
                            let ld = Inline.Link.make txt ll in

     

       262
       262
       -
                            Mapper.ret (Inline.Link (ld, meta))

     

       263
       263
       -
                          | None ->

     

       264
       264
       -
                            (* No URL for contact, just use name as text *)

     

       265
       265
       -
                            let txt = Inline.Text (name, meta) in

     

       266
       266
       -
                            Mapper.ret txt)

     

       267
       267
       -
                       | None ->

     

       268
       268
       -
                         (* Contact not found, use title as fallback text *)

     

       269
       269
       -
                         let title = Inline.Link.text lb |> text_of_inline in

     

       270
       270
       -
                         let txt = Inline.Text (title, meta) in

     

       271
       271
       -
                         Mapper.ret txt)

     

       272
       272
       -
                    | None ->

     

       273
       273
       -
                      (* Check for sluglink *)

     

       274
       274
       -
                      (match Meta.find sluglink m with

     

       275
       275
       -
                       | Some () ->

     

       276
       276
       -
                         let slug = Label.key l in

     

       277
       277
       -
                         if is_bushel_slug slug || is_tag_slug slug || is_contact_slug slug

     

       278
       278
       -
                         then (

     

       279
       279
       -
                           let s = strip_handle slug in

     

       280
       280
       -
                           let dest = Entry.lookup_site_url entries s in

     

       281
       281
       -
                           let title = Inline.Link.text lb |> text_of_inline in

     

       282
       282
       -
                           (* If link text is itself a Bushel slug, use the entry title instead *)

     

       283
       283
       -
                           let link_text =

     

       284
       284
       -
                             let trimmed = String.trim title in

     

       285
       285
       -
                             if is_bushel_slug trimmed then

     

       286
       286
       -
                               match Entry.lookup entries (strip_handle trimmed) with

     

       287
       287
       -
                               | Some ent -> Entry.title ent

     

       288
       288
       -
                               | None -> title

     

       289
       289
       -
                             else title

     

       290
       290
       -
                           in

     

       291
       291
       -
                           let txt = Inline.Text (link_text, meta) in

     

       292
       292
       -
                           let ld = Link_definition.make ~dest:(dest, meta) () in

     

       293
       293
       -
                           let ll = `Inline (ld, meta) in

     

       294
       294
       -
                           let ld = Inline.Link.make txt ll in

     

       295
       295
       -
                           Mapper.ret (Inline.Link (ld, meta)))

     

       296
       296
       -
                         else Mapper.default

     

       297
       297
       -
                       | None -> Mapper.default))

     

       298
       298
       -
                 | None -> Mapper.default))

     

       299
       299
       -
           | _ -> Mapper.default

     

       300
       300
       -
       ;;

     

       301
       301
       -
       

     

       302
       302
       -
       let rewrite_footnote_reference ?footnote_map entries defs lb _meta =

     

       303
       303
       -
         let open Cmarkit in

     

       304
       304
       -
         match Inline.Link.referenced_label lb with

     

       305
       305
       -
         | None -> Mapper.default

     

       306
       306
       -
         | Some l ->

     

       307
       307
       -
           (match Inline.Link.reference_definition defs lb with

     

       308
       308
       -
            | Some (Block.Footnote.Def (fn, _)) ->

     

       309
       309
       -
              let label_key = Label.key l in

     

       310
       310
       -
              let slug, trigger_text =

     

       311
       311
       -
                match footnote_map with

     

       312
       312
       -
                | Some fm ->

     

       313
       313
       -
                  (match Hashtbl.find_opt fm label_key with

     

       314
       314
       -
                   | Some (slug, text) -> (slug, text)

     

       315
       315
       -
                   | None ->

     

       316
       316
       -
                     let num = Hashtbl.length fm + 1 in

     

       317
       317
       -
                     let slug = Printf.sprintf "fn-%d" num in

     

       318
       318
       -
                     let text = Printf.sprintf "[%d]" num in

     

       319
       319
       -
                     Hashtbl.add fm label_key (slug, text);

     

       320
       320
       -
                     (slug, text))

     

       321
       321
       -
                | None ->

     

       322
       322
       -
                  (* No map provided, use label key as slug *)

     

       323
       323
       -
                  let slug = Printf.sprintf "fn-%s" (String.sub label_key 1 (String.length label_key - 1)) in

     

       324
       324
       -
                  let text = "[?]" in

     

       325
       325
       -
                  (slug, text)

     

       326
       326
       -
              in

     

       327
       327
       -
              (* Process the block to convert Bushel link references to regular links (not sidenotes) *)

     

       328
       328
       -
              let block = Block.Footnote.block fn in

     

       329
       329
       -
              let link_mapper = Mapper.make ~inline:(make_bushel_link_only_mapper defs entries) () in

     

       330
       330
       -
              let processed_block =

     

       331
       331
       -
                match Mapper.map_block link_mapper block with

     

       332
       332
       -
                | Some b -> b

     

       333
       333
       -
                | None -> block

     

       334
       334
       -
              in

     

       335
       335
       -
              let sidenote = Side_note (Footnote_note (slug, processed_block, trigger_text)) in

     

       336
       336
       -
              Mapper.ret sidenote

     

       337
       337
       -
            | _ -> Mapper.default)

     

       338
       338
       -
       

     

       339
       339
       -
       let rewrite_label_reference ?slugs entries lb meta =

     

       340
       340
       -
         let open Cmarkit in

     

       341
       341
       -
         match Inline.Link.referenced_label lb with

     

       342
       342
       -
         | None -> Mapper.default

     

       343
       343
       -
         | Some l ->

     

       344
       344
       -
           let m = Label.meta l in

     

       345
       345
       -
           (match Meta.find authorlink m with

     

       346
       346
       -
            | Some () ->

     

       347
       347
       -
              let slug = Label.key l in

     

       348
       348
       -
              (match Contact.find_by_handle (Entry.contacts entries) (strip_handle slug) with

     

       349
       349
       -
               | Some c ->

     

       350
       350
       -
                   let trigger_text = Contact.name c in

     

       351
       351
       -
                   let sidenote = Side_note (Contact_note (c, trigger_text)) in

     

       352
       352
       -
                   Mapper.ret sidenote

     

       353
       353
       -
               | None ->

     

       354
       354
       -
                   (* Contact not found, fallback to text *)

     

       355
       355
       -
                   let txt = Inline.Text ("Unknown Person", meta) in

     

       356
       356
       -
                   Mapper.ret txt)

     

       357
       357
       -
            | None ->

     

       358
       358
       -
              (match Meta.find sluglink m with

     

       359
       359
       -
               | None -> Mapper.default

     

       360
       360
       -
               | Some () ->

     

       361
       361
       -
                 let slug = Label.key l in

     

       362
       362
       -
                 if is_bushel_slug slug

     

       363
       363
       -
                 then (

     

       364
       364
       -
                   (match slugs with

     

       365
       365
       -
                    | Some s -> Hashtbl.replace s slug ()

     

       366
       366
       -
                    | _ -> ());

     

       367
       367
       -
                   let s = strip_handle slug in

     

       368
       368
       -
                   (* Check entry type and generate appropriate sidenote *)

     

       369
       369
       -
                   match Entry.lookup entries s with

     

       370
       370
       -
                   | Some (`Paper p) ->

     

       371
       371
       -
                       let trigger_text = Entry.lookup_title entries s in

     

       372
       372
       -
                       let sidenote = Side_note (Paper_note (p, trigger_text)) in

     

       373
       373
       -
                       Mapper.ret sidenote

     

       374
       374
       -
                   | Some (`Idea i) ->

     

       375
       375
       -
                       let trigger_text = Entry.lookup_title entries s in

     

       376
       376
       -
                       let sidenote = Side_note (Idea_note (i, trigger_text)) in

     

       377
       377
       -
                       Mapper.ret sidenote

     

       378
       378
       -
                   | Some (`Note n) ->

     

       379
       379
       -
                       let trigger_text = Entry.lookup_title entries s in

     

       380
       380
       -
                       let sidenote = Side_note (Note_note (n, trigger_text)) in

     

       381
       381
       -
                       Mapper.ret sidenote

     

       382
       382
       -
                   | Some (`Project p) ->

     

       383
       383
       -
                       let trigger_text = Entry.lookup_title entries s in

     

       384
       384
       -
                       let sidenote = Side_note (Project_note (p, trigger_text)) in

     

       385
       385
       -
                       Mapper.ret sidenote

     

       386
       386
       -
                   | Some (`Video v) ->

     

       387
       387
       -
                       let trigger_text = Entry.lookup_title entries s in

     

       388
       388
       -
                       let sidenote = Side_note (Video_note (v, trigger_text)) in

     

       389
       389
       -
                       Mapper.ret sidenote

     

       390
       390
       -
                   | None ->

     

       391
       391
       -
                       (* Entry not found, use regular link *)

     

       392
       392
       -
                       let target = Entry.lookup_title entries s in

     

       393
       393
       -
                       let dest = Entry.lookup_site_url entries s in

     

       394
       394
       -
                       let txt = Inline.Text (target, meta) in

     

       395
       395
       -
                       let ld = Link_definition.make ~dest:(dest, meta) () in

     

       396
       396
       -
                       let ll = `Inline (ld, meta) in

     

       397
       397
       -
                       let ld = Inline.Link.make txt ll in

     

       398
       398
       -
                       Mapper.ret (Inline.Link (ld, meta)))

     

       399
       399
       -
                 else if is_tag_slug slug

     

       400
       400
       -
                 then (

     

       401
       401
       -
                   let sh = strip_handle slug in

     

       402
       402
       -
                   (* Use # as dest to prevent navigation, JavaScript will intercept *)

     

       403
       403
       -
                   let target, dest = sh, "#" in

     

       404
       404
       -
                   let txt = Inline.Text (target, meta) in

     

       405
       405
       -
                   let ld = Link_definition.make ~dest:(dest, meta) () in

     

       406
       406
       -
                   let ll = `Inline (ld, meta) in

     

       407
       407
       -
                   let ld = Inline.Link.make txt ll in

     

       408
       408
       -
                   let ent_il = Inline.Link (ld, meta) in

     

       409
       409
       -
                   Mapper.ret ent_il)

     

       410
       410
       -
                 else Mapper.default))

     

       411
       411
       -
       ;;

     

       412
       412
       -
       

     

       413
       413
       -
       let bushel_inline_mapper_to_obsidian entries _m =

     

       414
       414
       -
         let open Cmarkit in

     

       415
       415
       -
         function

     

       416
       416
       -
         | Inline.Link (lb, meta) ->

     

       417
       417
       -
           (match link_target_is_bushel lb with

     

       418
       418
       -
            | None -> rewrite_label_reference_to_obsidian lb meta

     

       419
       419
       -
            | Some (url, title) -> rewrite_bushel_link_reference entries url title meta)

     

       420
       420
       -
         | Inline.Image (lb, meta) ->

     

       421
       421
       -
           (match image_target_is_bushel lb with

     

       422
       422
       -
            | None -> rewrite_label_reference_to_obsidian lb meta

     

       423
       423
       -
            | Some (url, alt, dir) -> rewrite_bushel_image_reference entries url alt dir meta)

     

       424
       424
       -
         | _ -> Mapper.default

     

       425
       425
       -
       ;;

     

       426
       426
       -
       

     

       427
       427
       -
       let make_bushel_inline_mapper ?slugs ?footnote_map defs entries =

     

       428
       428
       -
         let open Cmarkit in

     

       429
       429
       -
         fun _m ->

     

       430
       430
       -
           function

     

       431
       431
       -
           | Inline.Link (lb, meta) ->

     

       432
       432
       -
             (* First check if this is a footnote reference *)

     

       433
       433
       -
             (match Inline.Link.referenced_label lb with

     

       434
       434
       -
              | Some l when String.starts_with ~prefix:"^" (Label.key l) ->

     

       435
       435
       -
                (* This is a footnote reference *)

     

       436
       436
       -
                rewrite_footnote_reference ?footnote_map entries defs lb meta

     

       437
       437
       -
              | _ ->

     

       438
       438
       -
                (* Not a footnote, handle as bushel link *)

     

       439
       439
       -
                (match link_target_is_bushel ?slugs lb with

     

       440
       440
       -
                 | None -> rewrite_label_reference ?slugs entries lb meta

     

       441
       441
       -
                 | Some (url, title) -> rewrite_bushel_link_reference entries url title meta))

     

       442
       442
       -
           | Inline.Image (lb, meta) ->

     

       443
       443
       -
             (match image_target_is_bushel lb with

     

       444
       444
       -
              | None -> rewrite_label_reference entries lb meta

     

       445
       445
       -
              | Some (url, alt, dir) -> rewrite_bushel_image_reference entries url alt dir meta)

     

       446
       446
       -
           | _ -> Mapper.default

     

       447
       447
       -
       ;;

     

       448
       448
       -
       

     

       449
       449
       -
       let scan_for_slugs entries md =

     

       450
       450
       -
         let open Cmarkit in

     

       451
       451
       -
         let slugs = Hashtbl.create 7 in

     

       452
       452
       -
         let doc = Doc.of_string ~strict:false ~resolver:with_bushel_links md in

     

       453
       453
       -
         let defs = Doc.defs doc in

     

       454
       454
       -
         let _ =

     

       455
       455
       -
           Mapper.map_doc (Mapper.make ~inline:(make_bushel_inline_mapper ~slugs defs entries) ()) doc

     

       456
       456
       -
         in

     

       457
       457
       -
         Hashtbl.fold (fun k () a -> k :: a) slugs []

     

       458
       458
       -
       ;;

     

       459
       459
       -
       

     

       460
       460
       -
       (** Validation mapper that collects broken references *)

     

       461
       461
       -
       let make_validation_mapper entries broken_slugs broken_contacts =

     

       462
       462
       -
         let open Cmarkit in

     

       463
       463
       -
         fun _m ->

     

       464
       464
       -
           function

     

       465
       465
       -
           | Inline.Link (lb, _meta) ->

     

       466
       466
       -
             (* Check inline bushel links *)

     

       467
       467
       -
             (match link_target_is_bushel lb with

     

       468
       468
       -
              | Some (url, _title) ->

     

       469
       469
       -
                let s = strip_handle url in

     

       470
       470
       -
                if is_contact_slug url then

     

       471
       471
       -
                  (* Validate contact handle *)

     

       472
       472
       -
                  (match Contact.find_by_handle (Entry.contacts entries) s with

     

       473
       473
       -
                   | None -> Hashtbl.replace broken_contacts url ()

     

       474
       474
       -
                   | Some _ -> ())

     

       475
       475
       -
                else if is_bushel_slug url then

     

       476
       476
       -
                  (* Validate entry slug *)

     

       477
       477
       -
                  (match Entry.lookup entries s with

     

       478
       478
       -
                   | None -> Hashtbl.replace broken_slugs url ()

     

       479
       479
       -
                   | Some _ -> ())

     

       480
       480
       -
                else ();

     

       481
       481
       -
                Mapper.default

     

       482
       482
       -
              | None ->

     

       483
       483
       -
                (* Check referenced label links *)

     

       484
       484
       -
                (match Inline.Link.referenced_label lb with

     

       485
       485
       -
                 | Some l ->

     

       486
       486
       -
                   let m = Label.meta l in

     

       487
       487
       -
                   (* Check for contact reference *)

     

       488
       488
       -
                   (match Meta.find authorlink m with

     

       489
       489
       -
                    | Some () ->

     

       490
       490
       -
                      let slug = Label.key l in

     

       491
       491
       -
                      let handle = strip_handle slug in

     

       492
       492
       -
                      (match Contact.find_by_handle (Entry.contacts entries) handle with

     

       493
       493
       -
                       | None -> Hashtbl.replace broken_contacts slug ()

     

       494
       494
       -
                       | Some _ -> ());

     

       495
       495
       -
                      Mapper.default

     

       496
       496
       -
                    | None ->

     

       497
       497
       -
                      (* Check for entry slug reference *)

     

       498
       498
       -
                      (match Meta.find sluglink m with

     

       499
       499
       -
                       | None -> Mapper.default

     

       500
       500
       -
                       | Some () ->

     

       501
       501
       -
                         let slug = Label.key l in

     

       502
       502
       -
                         if is_bushel_slug slug then (

     

       503
       503
       -
                           let s = strip_handle slug in

     

       504
       504
       -
                           match Entry.lookup entries s with

     

       505
       505
       -
                            | None -> Hashtbl.replace broken_slugs slug ()

     

       506
       506
       -
                            | Some _ -> ()

     

       507
       507
       -
                         );

     

       508
       508
       -
                         Mapper.default))

     

       509
       509
       -
                 | None -> Mapper.default))

     

       510
       510
       -
           | _ -> Mapper.default

     

       511
       511
       -
       ;;

     

       512
       512
       -
       

     

       513
       513
       -
       (** Validate all bushel references in markdown and return broken ones *)

     

       514
       514
       -
       let validate_references entries md =

     

       515
       515
       -
         let open Cmarkit in

     

       516
       516
       -
         let broken_slugs = Hashtbl.create 7 in

     

       517
       517
       -
         let broken_contacts = Hashtbl.create 7 in

     

       518
       518
       -
         let doc = Doc.of_string ~strict:false ~resolver:with_bushel_links md in

     

       519
       519
       -
         let mapper = Mapper.make ~inline:(make_validation_mapper entries broken_slugs broken_contacts) () in

     

       520
       520
       -
         let _ = Mapper.map_doc mapper doc in

     

       521
       521
       -
         let slugs = Hashtbl.fold (fun k () a -> k :: a) broken_slugs [] in

     

       522
       522
       -
         let contacts = Hashtbl.fold (fun k () a -> k :: a) broken_contacts [] in

     

       523
       523
       -
         (slugs, contacts)

     

       524
       524
       -
       ;;

     

       525
       525
       -
       

     

       526
       526
       -
       (** Extract the first image URL from markdown text *)

     

       527
       527
       -
       let extract_first_image md =

     

       528
       528
       -
         let open Cmarkit in

     

       529
       529
       -
         (* Don't use bushel link resolver to avoid circular dependency with Entry *)

     

       530
       530
       -
         let doc = Doc.of_string md in

     

       531
       531
       -
         let found_image = ref None in

     

       532
       532
       -
       

     

       533
       533
       -
         let find_image_in_inline _mapper = function

     

       534
       534
       -
           | Inline.Image (img, _) ->

     

       535
       535
       -
             (match Inline.Link.reference img with

     

       536
       536
       -
              | `Inline (ld, _) ->

     

       537
       537
       -
                (match Link_definition.dest ld with

     

       538
       538
       -
                 | Some (url, _) when !found_image = None ->

     

       539
       539
       -
                   found_image := Some url;

     

       540
       540
       -
                   Mapper.default

     

       541
       541
       -
                 | _ -> Mapper.default)

     

       542
       542
       -
              | _ -> Mapper.default)

     

       543
       543
       -
           | _ -> Mapper.default

     

       544
       544
       -
         in

     

       545
       545
       -
       

     

       546
       546
       -
         let mapper = Mapper.make ~inline:find_image_in_inline () in

     

       547
       547
       -
         let _ = Mapper.map_doc mapper doc in

     

       548
       548
       -
         !found_image

     

       549
       549
       -
       ;;

     

       550
       550
       -
       

     

       551
       551
       -
       (** Convert markdown text to plain text, resolving bushel links to just their text *)

     

       552
       552
       -
       let markdown_to_plaintext _entries text =

     

       553
       553
       -
         let open Cmarkit in

     

       554
       554
       -
         (* Parse markdown with bushel link resolver *)

     

       555
       555
       -
         let doc = Doc.of_string ~resolver:with_bushel_links text in

     

       556
       556
       -
       

     

       557
       557
       -
         (* Convert document blocks to plain text *)

     

       558
       558
       -
         let rec block_to_text = function

     

       559
       559
       -
           | Block.Blank_line _ -> ""

     

       560
       560
       -
           | Block.Thematic_break _ -> "\n---\n"

     

       561
       561
       -
           | Block.Paragraph (p, _) ->

     

       562
       562
       -
             let inline = Block.Paragraph.inline p in

     

       563
       563
       -
             Inline.to_plain_text ~break_on_soft:false inline

     

       564
       564
       -
             |> List.map (String.concat "") |> String.concat "\n"

     

       565
       565
       -
           | Block.Heading (h, _) ->

     

       566
       566
       -
             let inline = Block.Heading.inline h in

     

       567
       567
       -
             Inline.to_plain_text ~break_on_soft:false inline

     

       568
       568
       -
             |> List.map (String.concat "") |> String.concat "\n"

     

       569
       569
       -
           | Block.Block_quote (bq, _) ->

     

       570
       570
       -
             let blocks = Block.Block_quote.block bq in

     

       571
       571
       -
             block_to_text blocks

     

       572
       572
       -
           | Block.List (l, _) ->

     

       573
       573
       -
             let items = Block.List'.items l in

     

       574
       574
       -
             List.map (fun (item, _) ->

     

       575
       575
       -
               let blocks = Block.List_item.block item in

     

       576
       576
       -
               block_to_text blocks

     

       577
       577
       -
             ) items |> String.concat "\n"

     

       578
       578
       -
           | Block.Code_block (cb, _) ->

     

       579
       579
       -
             let code = Block.Code_block.code cb in

     

       580
       580
       -
             String.concat "\n" (List.map Block_line.to_string code)

     

       581
       581
       -
           | Block.Html_block _ -> ""  (* Skip HTML blocks for search *)

     

       582
       582
       -
           | Block.Link_reference_definition _ -> ""

     

       583
       583
       -
           | Block.Ext_footnote_definition _ -> ""

     

       584
       584
       -
           | Block.Blocks (blocks, _) ->

     

       585
       585
       -
             List.map block_to_text blocks |> String.concat "\n"

     

       586
       586
       -
           | _ -> ""

     

       587
       587
       -
         in

     

       588
       588
       -
         let blocks = Doc.block doc in

     

       589
       589
       -
         block_to_text blocks

     

       590
       590
       -
       ;;

     

       591
       591
       -
       

     

       592
       592
       -
       (** Extract all links from markdown text, including from images *)

     

       593
       593
       -
       let extract_all_links text =

     

       594
       594
       -
         let open Cmarkit in

     

       595
       595
       -
         let doc = Doc.of_string ~resolver:with_bushel_links text in

     

       596
       596
       -
         let links = ref [] in

     

       597
       597
       -
       

     

       598
       598
       -
         let find_links_in_inline _mapper = function

     

       599
       599
       -
           | Inline.Link (lb, _) | Inline.Image (lb, _) ->

     

       600
       600
       -
             (* Check for inline link/image destination *)

     

       601
       601
       -
             (match Inline.Link.reference lb with

     

       602
       602
       -
              | `Inline (ld, _) ->

     

       603
       603
       -
                (match Link_definition.dest ld with

     

       604
       604
       -
                 | Some (url, _) ->

     

       605
       605
       -
                   links := url :: !links;

     

       606
       606
       -
                   Mapper.default

     

       607
       607
       -
                 | None -> Mapper.default)

     

       608
       608
       -
              | `Ref _ ->

     

       609
       609
       -
                (* For reference-style links/images, check if it has a referenced label *)

     

       610
       610
       -
                (match Inline.Link.referenced_label lb with

     

       611
       611
       -
                 | Some l ->

     

       612
       612
       -
                   let key = Label.key l in

     

       613
       613
       -
                   (* Check if it's a bushel-style link *)

     

       614
       614
       -
                   if String.length key > 0 && (key.[0] = ':' || key.[0] = '@' ||

     

       615
       615
       -
                      (String.length key > 1 && key.[0] = '#' && key.[1] = '#')) then

     

       616
       616
       -
                     links := key :: !links;

     

       617
       617
       -
                   Mapper.default

     

       618
       618
       -
                 | None -> Mapper.default))

     

       619
       619
       -
           | _ -> Mapper.default

     

       620
       620
       -
         in

     

       621
       621
       -
       

     

       622
       622
       -
         let mapper = Mapper.make ~inline:find_links_in_inline () in

     

       623
       623
       -
         let _ = Mapper.map_doc mapper doc in

     

       624
       624
       -
       

     

       625
       625
       -
         (* Deduplicate *)

     

       626
       626
       -
         let module StringSet = Set.Make(String) in

     

       627
       627
       -
         StringSet.elements (StringSet.of_list !links)

     

       628
       628
       -
       ;;

     

       629
       629
       -
       

     

       630
       630
       -
       (* Reference source type for CiTO annotations *)

     

       631
       631
       -
       type reference_source =

     

       632
       632
       -
         | Paper  (* CitesAsSourceDocument *)

     

       633
       633
       -
         | Note   (* CitesAsRelated *)

     

       634
       634
       -
         | External  (* Cites *)

     

       635
       635
       -
       

     

       636
       636
       -
       (* Extract references (papers/notes with DOIs) from a note *)

     

       637
       637
       -
       let note_references entries default_author note =

     

       638
       638
       -
         let refs = ref [] in

     

       639
       639
       -
       

     

       640
       640
       -
         (* Helper to format author name: extract last name from full name *)

     

       641
       641
       -
         let format_author_last name =

     

       642
       642
       -
           let parts = String.split_on_char ' ' name in

     

       643
       643
       -
           List.nth parts (List.length parts - 1)

     

       644
       644
       -
         in

     

       645
       645
       -
       

     

       646
       646
       -
         (* Helper to format a citation *)

     

       647
       647
       -
         let format_citation ~authors ~year ~title ~publisher =

     

       648
       648
       -
           let author_str = match authors with

     

       649
       649
       -
             | [] -> ""

     

       650
       650
       -
             | [author] -> format_author_last author ^ " "

     

       651
       651
       -
             | author :: _ -> (format_author_last author) ^ " et al "

     

       652
       652
       -
           in

     

       653
       653
       -
           let pub_str = match publisher with

     

       654
       654
       -
             | None | Some "" -> ""

     

       655
       655
       -
             | Some p -> p ^ ". "

     

       656
       656
       -
           in

     

       657
       657
       -
           Printf.sprintf "%s(%d). %s. %s" author_str year title pub_str

     

       658
       658
       -
         in

     

       659
       659
       -
       

     

       660
       660
       -
         (* Check slug_ent if it exists *)

     

       661
       661
       -
         (match Note.slug_ent note with

     

       662
       662
       -
          | Some slug ->

     

       663
       663
       -
            (match Entry.lookup entries slug with

     

       664
       664
       -
             | Some (`Paper p) ->

     

       665
       665
       -
               (match Paper.doi p with

     

       666
       666
       -
                | Some doi ->

     

       667
       667
       -
                  let authors = Paper.authors p in

     

       668
       668
       -
                  let year = Paper.year p in

     

       669
       669
       -
                  let title = Paper.title p in

     

       670
       670
       -
                  let publisher = Some (Paper.publisher p) in

     

       671
       671
       -
                  let citation = format_citation ~authors ~year ~title ~publisher in

     

       672
       672
       -
                  refs := (doi, citation, Paper) :: !refs

     

       673
       673
       -
                | None -> ())

     

       674
       674
       -
             | Some (`Note n) ->

     

       675
       675
       -
               (match Note.doi n with

     

       676
       676
       -
                | Some doi ->

     

       677
       677
       -
                  let authors = match Note.author n with

     

       678
       678
       -
                    | Some a -> [a]

     

       679
       679
       -
                    | None -> [Contact.name default_author]

     

       680
       680
       -
                  in

     

       681
       681
       -
                  let (year, _, _) = Note.date n in

     

       682
       682
       -
                  let title = Note.title n in

     

       683
       683
       -
                  let publisher = None in

     

       684
       684
       -
                  let citation = format_citation ~authors ~year ~title ~publisher in

     

       685
       685
       -
                  refs := (doi, citation, Note) :: !refs

     

       686
       686
       -
                | None -> ())

     

       687
       687
       -
             | _ -> ())

     

       688
       688
       -
          | None -> ());

     

       689
       689
       -
       

     

       690
       690
       -
         (* Scan body for bushel references *)

     

       691
       691
       -
         let slugs = scan_for_slugs entries (Note.body note) in

     

       692
       692
       -
         List.iter (fun slug ->

     

       693
       693
       -
           (* Strip leading : or @ from slug before lookup *)

     

       694
       694
       -
           let normalized_slug = strip_handle slug in

     

       695
       695
       -
           match Entry.lookup entries normalized_slug with

     

       696
       696
       -
           | Some (`Paper p) ->

     

       697
       697
       -
             (match Paper.doi p with

     

       698
       698
       -
              | Some doi ->

     

       699
       699
       -
                let authors = Paper.authors p in

     

       700
       700
       -
                let year = Paper.year p in

     

       701
       701
       -
                let title = Paper.title p in

     

       702
       702
       -
                let publisher = Some (Paper.publisher p) in

     

       703
       703
       -
                let citation = format_citation ~authors ~year ~title ~publisher in

     

       704
       704
       -
                (* Check if doi already exists in refs *)

     

       705
       705
       -
                if not (List.exists (fun (d, _, _) -> d = doi) !refs) then

     

       706
       706
       -
                  refs := (doi, citation, Paper) :: !refs

     

       707
       707
       -
              | None -> ())

     

       708
       708
       -
           | Some (`Note n) ->

     

       709
       709
       -
             (match Note.doi n with

     

       710
       710
       -
              | Some doi ->

     

       711
       711
       -
                let authors = match Note.author n with

     

       712
       712
       -
                  | Some a -> [a]

     

       713
       713
       -
                  | None -> [Contact.name default_author]

     

       714
       714
       -
                in

     

       715
       715
       -
                let (year, _, _) = Note.date n in

     

       716
       716
       -
                let title = Note.title n in

     

       717
       717
       -
                let publisher = None in

     

       718
       718
       -
                let citation = format_citation ~authors ~year ~title ~publisher in

     

       719
       719
       -
                (* Check if doi already exists in refs *)

     

       720
       720
       -
                if not (List.exists (fun (d, _, _) -> d = doi) !refs) then

     

       721
       721
       -
                  refs := (doi, citation, Note) :: !refs

     

       722
       722
       -
              | None -> ())

     

       723
       723
       -
           | _ -> ()

     

       724
       724
       -
         ) slugs;

     

       725
       725
       -
       

     

       726
       726
       -
         (* Scan body for external DOI URLs and resolve from cache *)

     

       727
       727
       -
         let body = Note.body note in

     

       728
       728
       -
         let doi_url_pattern = Re.Perl.compile_pat "https?://(?:dx\\.)?doi\\.org/([^)\\s\"'>]+)" in

     

       729
       729
       -
         let matches = Re.all doi_url_pattern body in

     

       730
       730
       -
         let doi_entries = Entry.doi_entries entries in

     

       731
       731
       -
         List.iter (fun group ->

     

       732
       732
       -
           try

     

       733
       733
       -
             let encoded_doi = Re.Group.get group 1 in

     

       734
       734
       -
             (* URL decode the DOI *)

     

       735
       735
       -
             let doi = Uri.pct_decode encoded_doi in

     

       736
       736
       -
             (* Check if doi already exists in refs *)

     

       737
       737
       -
             if not (List.exists (fun (d, _, _) -> d = doi) !refs) then

     

       738
       738
       -
               (* Look up in DOI cache *)

     

       739
       739
       -
               match Doi_entry.find_by_doi doi_entries doi with

     

       740
       740
       -
               | Some doi_entry when doi_entry.status = Resolved ->

     

       741
       741
       -
                 let citation = format_citation

     

       742
       742
       -
                   ~authors:doi_entry.authors

     

       743
       743
       -
                   ~year:doi_entry.year

     

       744
       744
       -
                   ~title:doi_entry.title

     

       745
       745
       -
                   ~publisher:(Some doi_entry.publisher)

     

       746
       746
       -
                 in

     

       747
       747
       -
                 refs := (doi, citation, External) :: !refs

     

       748
       748
       -
               | _ ->

     

       749
       749
       -
                 (* Not found in cache, add minimal citation with just the DOI *)

     

       750
       750
       -
                 refs := (doi, doi, External) :: !refs

     

       751
       751
       -
           with _ -> ()

     

       752
       752
       -
         ) matches;

     

       753
       753
       -
       

     

       754
       754
       -
         (* Scan body for publisher URLs (Elsevier, ScienceDirect, IEEE, Nature, ACM, Sage, UPenn, Springer, Taylor & Francis, OUP) and resolve from cache *)

     

       755
       755
       -
         let publisher_pattern = Re.Perl.compile_pat "https?://(?:(?:www\\.)?(?:linkinghub\\.elsevier\\.com|(?:www\\.)?sciencedirect\\.com/science/article|ieeexplore\\.ieee\\.org|academic\\.oup\\.com|nature\\.com|journals\\.sagepub\\.com|garfield\\.library\\.upenn\\.edu|link\\.springer\\.com)/[^)\\s\"'>]+|(?:dl\\.acm\\.org|(?:www\\.)?tandfonline\\.com)/doi(?:/pdf)?/10\\.[^)\\s\"'>]+)" in

     

       756
       756
       -
         let publisher_matches = Re.all publisher_pattern body in

     

       757
       757
       -
         List.iter (fun group ->

     

       758
       758
       -
           try

     

       759
       759
       -
             let url = Re.Group.get group 0 in

     

       760
       760
       -
             (* Look up in DOI cache by source URL *)

     

       761
       761
       -
             match Doi_entry.find_by_url doi_entries url with

     

       762
       762
       -
             | Some doi_entry when doi_entry.status = Resolved ->

     

       763
       763
       -
               let doi = doi_entry.doi in

     

       764
       764
       -
               (* Check if this DOI already exists in refs *)

     

       765
       765
       -
               if not (List.exists (fun (d, _, _) -> d = doi) !refs) then

     

       766
       766
       -
                 let citation = format_citation

     

       767
       767
       -
                   ~authors:doi_entry.authors

     

       768
       768
       -
                   ~year:doi_entry.year

     

       769
       769
       -
                   ~title:doi_entry.title

     

       770
       770
       -
                   ~publisher:(Some doi_entry.publisher)

     

       771
       771
       -
                 in

     

       772
       772
       -
                 refs := (doi, citation, External) :: !refs

     

       773
       773
       -
             | _ ->

     

       774
       774
       -
               (* Not found in cache, skip it *)

     

       775
       775
       -
               ()

     

       776
       776
       -
           with _ -> ()

     

       777
       777
       -
         ) publisher_matches;

     

       778
       778
       -
       

     

       779
       779
       -
         List.rev !refs

     

       780
       780
       -
       ;;

     

       781
       781
       -

-73

stack/bushel/lib/md.mli

···

       1
       1
       -
       val make_bushel_inline_mapper

     

       2
       2
       -
         :  ?slugs:(string, unit) Hashtbl.t

     

       3
       3
       -
         -> ?footnote_map:(string, string * string) Hashtbl.t

     

       4
       4
       -
         -> Cmarkit.Label.defs

     

       5
       5
       -
         -> Entry.t

     

       6
       6
       -
         -> 'a

     

       7
       7
       -
         -> Cmarkit.Inline.t

     

       8
       8
       -
         -> Cmarkit.Inline.t Cmarkit.Mapper.result

     

       9
       9
       -
       

     

       10
       10
       -
       val make_bushel_link_only_mapper

     

       11
       11
       -
         :  Cmarkit.Label.defs

     

       12
       12
       -
         -> Entry.t

     

       13
       13
       -
         -> 'a

     

       14
       14
       -
         -> Cmarkit.Inline.t

     

       15
       15
       -
         -> Cmarkit.Inline.t Cmarkit.Mapper.result

     

       16
       16
       -
       

     

       17
       17
       -
       type Cmarkit.Inline.t += Obsidian_link of string

     

       18
       18
       -
       

     

       19
       19
       -
       type sidenote_data =

     

       20
       20
       -
         | Contact_note of Contact.t * string

     

       21
       21
       -
         | Paper_note of Paper.t * string

     

       22
       22
       -
         | Idea_note of Idea.t * string

     

       23
       23
       -
         | Note_note of Note.t * string

     

       24
       24
       -
         | Project_note of Project.t * string

     

       25
       25
       -
         | Video_note of Video.t * string

     

       26
       26
       -
         | Footnote_note of string * Cmarkit.Block.t * string

     

       27
       27
       -
       

     

       28
       28
       -
       type Cmarkit.Inline.t += Side_note of sidenote_data

     

       29
       29
       -
       

     

       30
       30
       -
       val bushel_inline_mapper_to_obsidian

     

       31
       31
       -
         :  Entry.t

     

       32
       32
       -
         -> 'a

     

       33
       33
       -
         -> Cmarkit.Inline.t

     

       34
       34
       -
         -> Cmarkit.Inline.t Cmarkit.Mapper.result

     

       35
       35
       -
       

     

       36
       36
       -
       val with_bushel_links

     

       37
       37
       -
         :  [< `Def of Cmarkit.Label.t option * Cmarkit.Label.t

     

       38
       38
       -
            | `Ref of 'a * Cmarkit.Label.t * Cmarkit.Label.t option

     

       39
       39
       -
            ]

     

       40
       40
       -
         -> Cmarkit.Label.t option

     

       41
       41
       -
       

     

       42
       42
       -
       val scan_for_slugs : Entry.t -> string -> string list

     

       43
       43
       -
       

     

       44
       44
       -
       (** Validate all bushel references in markdown and return broken ones.

     

       45
       45
       -
           Returns (broken_slugs, broken_contacts) where each list contains

     

       46
       46
       -
           the full reference string (e.g., ":missing-slug", "@unknown-handle") *)

     

       47
       47
       -
       val validate_references : Entry.t -> string -> string list * string list

     

       48
       48
       -
       

     

       49
       49
       -
       (** Extract the first image URL from markdown text *)

     

       50
       50
       -
       val extract_first_image : string -> string option

     

       51
       51
       -
       

     

       52
       52
       -
       (** Convert markdown text to plain text, resolving bushel links to just their text *)

     

       53
       53
       -
       val markdown_to_plaintext : 'a -> string -> string

     

       54
       54
       -
       

     

       55
       55
       -
       val is_bushel_slug : string -> bool

     

       56
       56
       -
       val is_tag_slug : string -> bool

     

       57
       57
       -
       val is_type_filter_slug : string -> bool

     

       58
       58
       -
       val is_contact_slug : string -> bool

     

       59
       59
       -
       val strip_handle : string -> string

     

       60
       60
       -
       

     

       61
       61
       -
       (** Extract all links from markdown text, including from images (internal and external) *)

     

       62
       62
       -
       val extract_all_links : string -> string list

     

       63
       63
       -
       

     

       64
       64
       -
       (** Type indicating the source of a reference for CiTO annotation *)

     

       65
       65
       -
       type reference_source =

     

       66
       66
       -
         | Paper  (** CitesAsSourceDocument *)

     

       67
       67
       -
         | Note   (** CitesAsRelated *)

     

       68
       68
       -
         | External  (** Cites *)

     

       69
       69
       -
       

     

       70
       70
       -
       (** Extract references (papers/notes with DOIs) from a note.

     

       71
       71
       -
           Returns a list of (DOI, citation_string, reference_source) tuples.

     

       72
       72
       -
           Citation format: "Last, First (Year). Title. Publisher. https://doi.org/the/doi" *)

     

       73
       73
       -
       val note_references : Entry.t -> Contact.t -> Note.t -> (string * string * reference_source) list

-230

stack/bushel/lib/note.ml

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { title : string

     

       3
       3
       -
         ; date : Ptime.date

     

       4
       4
       -
         ; slug : string

     

       5
       5
       -
         ; body : string

     

       6
       6
       -
         ; tags : string list

     

       7
       7
       -
         ; draft : bool

     

       8
       8
       -
         ; updated : Ptime.date option

     

       9
       9
       -
         ; sidebar : string option

     

       10
       10
       -
         ; index_page : bool

     

       11
       11
       -
         ; perma : bool               (* Permanent article that will receive a DOI *)

     

       12
       12
       -
         ; doi : string option        (* DOI identifier for permanent articles *)

     

       13
       13
       -
         ; synopsis: string option

     

       14
       14
       -
         ; titleimage: string option

     

       15
       15
       -
         ; via : (string * string) option

     

       16
       16
       -
         ; slug_ent : string option  (* Optional reference to another entry *)

     

       17
       17
       -
         ; source : string option     (* Optional source for news-style notes *)

     

       18
       18
       -
         ; url : string option        (* Optional external URL for news-style notes *)

     

       19
       19
       -
         ; author : string option     (* Optional author for news-style notes *)

     

       20
       20
       -
         ; category : string option   (* Optional category for news-style notes *)

     

       21
       21
       -
         }

     

       22
       22
       -
       

     

       23
       23
       -
       type ts = t list

     

       24
       24
       -
       

     

       25
       25
       -
       let link { body; via; slug; _ } =

     

       26
       26
       -
         match body, via with

     

       27
       27
       -
         | "", Some (l, u) -> `Ext (l, u)

     

       28
       28
       -
         | "", None -> failwith (slug ^ ": note external without via, via-url")

     

       29
       29
       -
         | _, _ -> `Local slug

     

       30
       30
       -
       ;;

     

       31
       31
       -
       

     

       32
       32
       -
       let origdate { date; _ } = Option.get @@ Ptime.of_date date

     

       33
       33
       -
       

     

       34
       34
       -
       let date { date; updated; _ } =

     

       35
       35
       -
         match updated with

     

       36
       36
       -
         | None -> date

     

       37
       37
       -
         | Some v -> v

     

       38
       38
       -
       ;;

     

       39
       39
       -
       

     

       40
       40
       -
       let datetime v = Option.get @@ Ptime.of_date @@ date v

     

       41
       41
       -
       let compare a b = Ptime.compare (datetime b) (datetime a)

     

       42
       42
       -
       let slug { slug; _ } = slug

     

       43
       43
       -
       let body { body; _ } = body

     

       44
       44
       -
       let title { title; _ } = title

     

       45
       45
       -
       let tags { tags; _ } = tags

     

       46
       46
       -
       let sidebar { sidebar; _ } = sidebar

     

       47
       47
       -
       let synopsis { synopsis; _ } = synopsis

     

       48
       48
       -
       let draft { draft; _ } = draft

     

       49
       49
       -
       let perma { perma; _ } = perma

     

       50
       50
       -
       let doi { doi; _ } = doi

     

       51
       51
       -
       let titleimage { titleimage; _ } = titleimage

     

       52
       52
       -
       let slug_ent { slug_ent; _ } = slug_ent

     

       53
       53
       -
       let source { source; _ } = source

     

       54
       54
       -
       let url { url; _ } = url

     

       55
       55
       -
       let author { author; _ } = author

     

       56
       56
       -
       let category { category; _ } = category

     

       57
       57
       -
       let lookup slug notes = List.find (fun n -> n.slug = slug) notes

     

       58
       58
       -
       let read_file file = In_channel.(with_open_bin file input_all)

     

       59
       59
       -
       let words { body; _ } = Util.count_words body

     

       60
       60
       -
       

     

       61
       61
       -
       

     

       62
       62
       -
       let of_md fname =

     

       63
       63
       -
         (* TODO fix Jekyll_post to basename the fname all the time *)

     

       64
       64
       -
         match Jekyll_post.of_string ~fname:(Filename.basename fname) (read_file fname) with

     

       65
       65
       -
         | Error (`Msg m) -> failwith ("note_of_md: " ^ m)

     

       66
       66
       -
         | Ok jp ->

     

       67
       67
       -
           let fields = jp.Jekyll_post.fields in

     

       68
       68
       -
           let { Jekyll_post.title; date; slug; body; _ } = jp in

     

       69
       69
       -
           let date, _ = Ptime.to_date_time date in

     

       70
       70
       -
           let index_page =

     

       71
       71
       -
             match Jekyll_format.find "index_page" fields with

     

       72
       72
       -
             | Some (`Bool v) -> v

     

       73
       73
       -
             | _ -> false

     

       74
       74
       -
           in

     

       75
       75
       -
           let perma =

     

       76
       76
       -
             match Jekyll_format.find "perma" fields with

     

       77
       77
       -
             | Some (`Bool v) -> v

     

       78
       78
       -
             | _ -> false

     

       79
       79
       -
           in

     

       80
       80
       -
           let updated =

     

       81
       81
       -
             match Jekyll_format.find "updated" fields with

     

       82
       82
       -
             | Some (`String v) -> Some (Jekyll_format.parse_date_exn v |> Ptime.to_date)

     

       83
       83
       -
             | _ -> None

     

       84
       84
       -
           in

     

       85
       85
       -
           let draft =

     

       86
       86
       -
             match Jekyll_format.find "draft" fields with

     

       87
       87
       -
             | Some (`Bool v) -> v

     

       88
       88
       -
             | _ -> false

     

       89
       89
       -
           in

     

       90
       90
       -
           let titleimage =

     

       91
       91
       -
             match Jekyll_format.find "titleimage" fields with

     

       92
       92
       -
             | Some (`String v) -> Some v

     

       93
       93
       -
             | _ -> None

     

       94
       94
       -
           in

     

       95
       95
       -
           let synopsis =

     

       96
       96
       -
             match Jekyll_format.find "synopsis" fields with

     

       97
       97
       -
             | Some (`String v) -> Some v

     

       98
       98
       -
             | _ -> None

     

       99
       99
       -
           in

     

       100
       100
       -
           let sidebar =

     

       101
       101
       -
             try Some (read_file ("data/sidebar/" ^ Filename.basename fname)) with

     

       102
       102
       -
             | _ -> None

     

       103
       103
       -
           in

     

       104
       104
       -
           let tags =

     

       105
       105
       -
             match Jekyll_format.find "tags" fields with

     

       106
       106
       -
             | Some (`A l) ->

     

       107
       107
       -
               List.filter_map

     

       108
       108
       -
                 (function

     

       109
       109
       -
                   | `String s -> Some s

     

       110
       110
       -
                   | _ -> None)

     

       111
       111
       -
                 l

     

       112
       112
       -
             | _ -> []

     

       113
       113
       -
           in

     

       114
       114
       -
           let via =

     

       115
       115
       -
             match Jekyll_format.find "via" fields, Jekyll_format.find "via-url" fields with

     

       116
       116
       -
             | Some (`String a), Some (`String b) -> Some (a, b)

     

       117
       117
       -
             | None, Some (`String b) -> Some ("", b)

     

       118
       118
       -
             | _ -> None

     

       119
       119
       -
           in

     

       120
       120
       -
           let slug_ent =

     

       121
       121
       -
             match Jekyll_format.find "slug_ent" fields with

     

       122
       122
       -
             | Some (`String v) -> Some v

     

       123
       123
       -
             | _ -> None

     

       124
       124
       -
           in

     

       125
       125
       -
           let source =

     

       126
       126
       -
             match Jekyll_format.find "source" fields with

     

       127
       127
       -
             | Some (`String v) -> Some v

     

       128
       128
       -
             | _ -> None

     

       129
       129
       -
           in

     

       130
       130
       -
           let url =

     

       131
       131
       -
             match Jekyll_format.find "url" fields with

     

       132
       132
       -
             | Some (`String v) -> Some v

     

       133
       133
       -
             | _ -> None

     

       134
       134
       -
           in

     

       135
       135
       -
           let author =

     

       136
       136
       -
             match Jekyll_format.find "author" fields with

     

       137
       137
       -
             | Some (`String v) -> Some v

     

       138
       138
       -
             | _ -> None

     

       139
       139
       -
           in

     

       140
       140
       -
           let category =

     

       141
       141
       -
             match Jekyll_format.find "category" fields with

     

       142
       142
       -
             | Some (`String v) -> Some v

     

       143
       143
       -
             | _ -> None

     

       144
       144
       -
           in

     

       145
       145
       -
           let doi =

     

       146
       146
       -
             match Jekyll_format.find "doi" fields with

     

       147
       147
       -
             | Some (`String v) -> Some v

     

       148
       148
       -
             | _ -> None

     

       149
       149
       -
           in

     

       150
       150
       -
           { title; draft; date; slug; synopsis; titleimage; index_page; perma; doi; body; via; updated; tags; sidebar; slug_ent; source; url; author; category }

     

       151
       151
       -
       

     

       152
       152
       -
       (* TODO:claude *)

     

       153
       153
       -
       let typesense_schema =

     

       154
       154
       -
         let open Ezjsonm in

     

       155
       155
       -
         dict [

     

       156
       156
       -
           ("name", string "notes");

     

       157
       157
       -
           ("fields", list (fun d -> dict d) [

     

       158
       158
       -
             [("name", string "id"); ("type", string "string")];

     

       159
       159
       -
             [("name", string "title"); ("type", string "string")];

     

       160
       160
       -
             [("name", string "content"); ("type", string "string")];

     

       161
       161
       -
             [("name", string "date"); ("type", string "string")];

     

       162
       162
       -
             [("name", string "date_timestamp"); ("type", string "int64")];

     

       163
       163
       -
             [("name", string "tags"); ("type", string "string[]"); ("facet", bool true)];

     

       164
       164
       -
             [("name", string "body"); ("type", string "string"); ("optional", bool true)];

     

       165
       165
       -
             [("name", string "draft"); ("type", string "bool")];

     

       166
       166
       -
             [("name", string "synopsis"); ("type", string "string[]"); ("optional", bool true)];

     

       167
       167
       -
             [("name", string "thumbnail_url"); ("type", string "string"); ("optional", bool true)];

     

       168
       168
       -
             [("name", string "type"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       169
       169
       -
             [("name", string "status"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       170
       170
       -
             [("name", string "related_papers"); ("type", string "string[]"); ("optional", bool true)];

     

       171
       171
       -
             [("name", string "related_projects"); ("type", string "string[]"); ("optional", bool true)];

     

       172
       172
       -
             [("name", string "related_contacts"); ("type", string "string[]"); ("optional", bool true)];

     

       173
       173
       -
             [("name", string "attachments"); ("type", string "string[]"); ("optional", bool true)];

     

       174
       174
       -
             [("name", string "source"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       175
       175
       -
             [("name", string "url"); ("type", string "string"); ("optional", bool true)];

     

       176
       176
       -
             [("name", string "author"); ("type", string "string"); ("optional", bool true)];

     

       177
       177
       -
             [("name", string "category"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       178
       178
       -
             [("name", string "slug_ent"); ("type", string "string"); ("optional", bool true)];

     

       179
       179
       -
             [("name", string "words"); ("type", string "int32"); ("optional", bool true)];

     

       180
       180
       -
           ]);

     

       181
       181
       -
           ("default_sorting_field", string "date_timestamp");

     

       182
       182
       -
         ]

     

       183
       183
       -
       

     

       184
       184
       -
       (** TODO:claude Pretty-print a note with ANSI formatting *)

     

       185
       185
       -
       let pp ppf n =

     

       186
       186
       -
         let open Fmt in

     

       187
       187
       -
         pf ppf "@[<v>";

     

       188
       188
       -
         pf ppf "%a: %a@," (styled `Bold string) "Type" (styled `Cyan string) "Note";

     

       189
       189
       -
         pf ppf "%a: %a@," (styled `Bold string) "Slug" string (slug n);

     

       190
       190
       -
         pf ppf "%a: %a@," (styled `Bold string) "Title" string (title n);

     

       191
       191
       -
         let (year, month, day) = date n in

     

       192
       192
       -
         pf ppf "%a: %04d-%02d-%02d@," (styled `Bold string) "Date" year month day;

     

       193
       193
       -
         (match n.updated with

     

       194
       194
       -
          | Some (y, m, d) -> pf ppf "%a: %04d-%02d-%02d@," (styled `Bold string) "Updated" y m d

     

       195
       195
       -
          | None -> ());

     

       196
       196
       -
         pf ppf "%a: %b@," (styled `Bold string) "Draft" (draft n);

     

       197
       197
       -
         pf ppf "%a: %b@," (styled `Bold string) "Index Page" n.index_page;

     

       198
       198
       -
         pf ppf "%a: %b@," (styled `Bold string) "Perma" (perma n);

     

       199
       199
       -
         (match doi n with

     

       200
       200
       -
          | Some d -> pf ppf "%a: %a@," (styled `Bold string) "DOI" string d

     

       201
       201
       -
          | None -> ());

     

       202
       202
       -
         (match synopsis n with

     

       203
       203
       -
          | Some syn -> pf ppf "%a: %a@," (styled `Bold string) "Synopsis" string syn

     

       204
       204
       -
          | None -> ());

     

       205
       205
       -
         (match titleimage n with

     

       206
       206
       -
          | Some img -> pf ppf "%a: %a@," (styled `Bold string) "Title Image" string img

     

       207
       207
       -
          | None -> ());

     

       208
       208
       -
         (match n.via with

     

       209
       209
       -
          | Some (label, url) ->

     

       210
       210
       -
            if label <> "" then

     

       211
       211
       -
              pf ppf "%a: %a (%a)@," (styled `Bold string) "Via" string label string url

     

       212
       212
       -
            else

     

       213
       213
       -
              pf ppf "%a: %a@," (styled `Bold string) "Via" string url

     

       214
       214
       -
          | None -> ());

     

       215
       215
       -
         let t = tags n in

     

       216
       216
       -
         if t <> [] then

     

       217
       217
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Tags" (list ~sep:comma string) t;

     

       218
       218
       -
         (match sidebar n with

     

       219
       219
       -
          | Some sb ->

     

       220
       220
       -
            pf ppf "@,";

     

       221
       221
       -
            pf ppf "%a:@," (styled `Bold string) "Sidebar";

     

       222
       222
       -
            pf ppf "%a@," string sb

     

       223
       223
       -
          | None -> ());

     

       224
       224
       -
         let bd = body n in

     

       225
       225
       -
         if bd <> "" then begin

     

       226
       226
       -
           pf ppf "@,";

     

       227
       227
       -
           pf ppf "%a:@," (styled `Bold string) "Body";

     

       228
       228
       -
           pf ppf "%a@," string bd;

     

       229
       229
       -
         end;

     

       230
       230
       -
         pf ppf "@]"

-49

stack/bushel/lib/note.mli

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { title : string

     

       3
       3
       -
         ; date : Ptime.date

     

       4
       4
       -
         ; slug : string

     

       5
       5
       -
         ; body : string

     

       6
       6
       -
         ; tags : string list

     

       7
       7
       -
         ; draft : bool

     

       8
       8
       -
         ; updated : Ptime.date option

     

       9
       9
       -
         ; sidebar : string option

     

       10
       10
       -
         ; index_page : bool

     

       11
       11
       -
         ; perma : bool

     

       12
       12
       -
         ; doi : string option

     

       13
       13
       -
         ; synopsis: string option

     

       14
       14
       -
         ; titleimage: string option

     

       15
       15
       -
         ; via : (string * string) option

     

       16
       16
       -
         ; slug_ent : string option

     

       17
       17
       -
         ; source : string option

     

       18
       18
       -
         ; url : string option

     

       19
       19
       -
         ; author : string option

     

       20
       20
       -
         ; category : string option

     

       21
       21
       -
         }

     

       22
       22
       -
       

     

       23
       23
       -
       type ts = t list

     

       24
       24
       -
       

     

       25
       25
       -
       val link : t -> [> `Ext of string * string | `Local of string ]

     

       26
       26
       -
       val origdate : t -> Ptime.t

     

       27
       27
       -
       val date : t -> Ptime.date

     

       28
       28
       -
       val datetime : t -> Ptime.t

     

       29
       29
       -
       val compare : t -> t -> int

     

       30
       30
       -
       val slug : t -> string

     

       31
       31
       -
       val body : t -> string

     

       32
       32
       -
       val title : t -> string

     

       33
       33
       -
       val draft : t -> bool

     

       34
       34
       -
       val perma : t -> bool

     

       35
       35
       -
       val doi : t -> string option

     

       36
       36
       -
       val synopsis : t -> string option

     

       37
       37
       -
       val titleimage : t -> string option

     

       38
       38
       -
       val slug_ent : t -> string option

     

       39
       39
       -
       val source : t -> string option

     

       40
       40
       -
       val url : t -> string option

     

       41
       41
       -
       val author : t -> string option

     

       42
       42
       -
       val category : t -> string option

     

       43
       43
       -
       val tags : t -> string list

     

       44
       44
       -
       val sidebar : t -> string option

     

       45
       45
       -
       val lookup : string -> t list -> t

     

       46
       46
       -
       val words : t -> int

     

       47
       47
       -
       val of_md : string -> t

     

       48
       48
       -
       val typesense_schema : Ezjsonm.value

     

       49
       49
       -
       val pp : Format.formatter -> t -> unit

-373

stack/bushel/lib/paper.ml

···

       1
       1
       -
       module J = Ezjsonm

     

       2
       2
       -
       

     

       3
       3
       -
       type paper = Ezjsonm.value

     

       4
       4
       -
       

     

       5
       5
       -
       type t =

     

       6
       6
       -
         { slug : string

     

       7
       7
       -
         ; ver : string

     

       8
       8
       -
         ; paper : paper

     

       9
       9
       -
         ; abstract : string

     

       10
       10
       -
         ; latest : bool

     

       11
       11
       -
         }

     

       12
       12
       -
       

     

       13
       13
       -
       type ts = t list

     

       14
       14
       -
       

     

       15
       15
       -
       let key y k = J.find y [ k ]

     

       16
       16
       -
       

     

       17
       17
       -
       let slugs ts =

     

       18
       18
       -
         List.fold_left (fun acc t -> if List.mem t.slug acc then acc else t.slug :: acc) [] ts

     

       19
       19
       -
       ;;

     

       20
       20
       -
       

     

       21
       21
       -
       let slug { slug; _ } = slug

     

       22
       22
       -
       let title { paper; _ } : string = key paper "title" |> J.get_string

     

       23
       23
       -
       let authors { paper; _ } : string list = key paper "author" |> J.get_list J.get_string

     

       24
       24
       -
       

     

       25
       25
       -
       let project_slugs { paper; _ } : string list =

     

       26
       26
       -
         try key paper "projects" |> J.get_list J.get_string with

     

       27
       27
       -
         | _ -> []

     

       28
       28
       -
       ;;

     

       29
       29
       -
       

     

       30
       30
       -
       let slides { paper; _ } : string list =

     

       31
       31
       -
         try key paper "slides" |> J.get_list J.get_string with

     

       32
       32
       -
         | _ -> []

     

       33
       33
       -
       ;;

     

       34
       34
       -
       

     

       35
       35
       -
       let bibtype { paper; _ } : string = key paper "bibtype" |> J.get_string

     

       36
       36
       -
       

     

       37
       37
       -
       let journal { paper; _ } =

     

       38
       38
       -
         try key paper "journal" |> J.get_string with

     

       39
       39
       -
         | Not_found ->

     

       40
       40
       -
           failwith

     

       41
       41
       -
             (Printf.sprintf "no journal found for %s\n%!" (Ezjsonm.value_to_string paper))

     

       42
       42
       -
       ;;

     

       43
       43
       -
       

     

       44
       44
       -
       (** TODO:claude Helper to extract raw JSON *)

     

       45
       45
       -
       let raw_json { paper; _ } = paper

     

       46
       46
       -
       

     

       47
       47
       -
       let doi { paper; _ } =

     

       48
       48
       -
         try Some (key paper "doi" |> J.get_string) with

     

       49
       49
       -
         | _ -> None

     

       50
       50
       -
       ;;

     

       51
       51
       -
       

     

       52
       52
       -
       let volume { paper; _ } =

     

       53
       53
       -
         try Some (key paper "volume" |> J.get_string) with

     

       54
       54
       -
         | _ -> None

     

       55
       55
       -
       ;;

     

       56
       56
       -
       

     

       57
       57
       -
       let video { paper; _ } =

     

       58
       58
       -
         try Some (key paper "video" |> J.get_string) with

     

       59
       59
       -
         | _ -> None

     

       60
       60
       -
       ;;

     

       61
       61
       -
       

     

       62
       62
       -
       let issue { paper; _ } =

     

       63
       63
       -
         try Some (key paper "number" |> J.get_string) with

     

       64
       64
       -
         | _ -> None

     

       65
       65
       -
       ;;

     

       66
       66
       -
       

     

       67
       67
       -
       let url { paper; _ } =

     

       68
       68
       -
         try Some (key paper "url" |> J.get_string) with

     

       69
       69
       -
         | _ -> None

     

       70
       70
       -
       ;;

     

       71
       71
       -
       

     

       72
       72
       -
       let pages { paper; _ } = try key paper "pages" |> J.get_string with _ -> ""

     

       73
       73
       -
       let abstract { abstract; _ } = abstract

     

       74
       74
       -
       

     

       75
       75
       -
       let institution { paper; _ } =

     

       76
       76
       -
         try key paper "institution" |> J.get_string with

     

       77
       77
       -
         | Not_found ->

     

       78
       78
       -
           failwith

     

       79
       79
       -
             (Printf.sprintf "no institution found for %s\n%!" (Ezjsonm.value_to_string paper))

     

       80
       80
       -
       ;;

     

       81
       81
       -
       

     

       82
       82
       -
       let number { paper; _ } =

     

       83
       83
       -
         try Some (key paper "number" |> J.get_string) with

     

       84
       84
       -
         | Not_found -> None

     

       85
       85
       -
       ;;

     

       86
       86
       -
       

     

       87
       87
       -
       let editor { paper; _ } = key paper "editor" |> J.get_string

     

       88
       88
       -
       let isbn { paper; _ } = key paper "isbn" |> J.get_string

     

       89
       89
       -
       let bib { paper; _ } = key paper "bib" |> J.get_string

     

       90
       90
       -
       let year { paper; _ } = key paper "year" |> J.get_string |> int_of_string

     

       91
       91
       -
       

     

       92
       92
       -
       let publisher { paper; _ } =

     

       93
       93
       -
         try key paper "publisher" |> J.get_string with

     

       94
       94
       -
         | Not_found -> ""

     

       95
       95
       -
       ;;

     

       96
       96
       -
       

     

       97
       97
       -
       let booktitle { paper; _ } =

     

       98
       98
       -
         let r = key paper "booktitle" |> J.get_string |> Bytes.of_string in

     

       99
       99
       -
         Bytes.set r 0 (Char.lowercase_ascii (Bytes.get r 0));

     

       100
       100
       -
         String.of_bytes r

     

       101
       101
       -
       ;;

     

       102
       102
       -
       

     

       103
       103
       -
       let date { paper; _ } =

     

       104
       104
       -
         let m =

     

       105
       105
       -
           try

     

       106
       106
       -
             match String.lowercase_ascii (key paper "month" |> J.get_string) with

     

       107
       107
       -
             | "jan" -> 1

     

       108
       108
       -
             | "feb" -> 2

     

       109
       109
       -
             | "mar" -> 3

     

       110
       110
       -
             | "apr" -> 4

     

       111
       111
       -
             | "may" -> 5

     

       112
       112
       -
             | "jun" -> 6

     

       113
       113
       -
             | "jul" -> 7

     

       114
       114
       -
             | "aug" -> 8

     

       115
       115
       -
             | "sep" -> 9

     

       116
       116
       -
             | "oct" -> 10

     

       117
       117
       -
             | "nov" -> 11

     

       118
       118
       -
             | "dec" -> 12

     

       119
       119
       -
             | _ -> 1

     

       120
       120
       -
           with

     

       121
       121
       -
           | Not_found -> 1

     

       122
       122
       -
         in

     

       123
       123
       -
         let y =

     

       124
       124
       -
           try key paper "year" |> J.get_string |> int_of_string with

     

       125
       125
       -
           | Not_found ->

     

       126
       126
       -
             failwith (Printf.sprintf "no year found for %s" (Ezjsonm.value_to_string paper))

     

       127
       127
       -
         in

     

       128
       128
       -
         y, m, 1

     

       129
       129
       -
       ;;

     

       130
       130
       -
       

     

       131
       131
       -
       let datetime p = Option.get @@ Ptime.of_date @@ date p

     

       132
       132
       -
       

     

       133
       133
       -
       let compare p2 p1 =

     

       134
       134
       -
         let d1 =

     

       135
       135
       -
           Ptime.of_date

     

       136
       136
       -
             (try date p1 with

     

       137
       137
       -
              | _ -> 1977, 1, 1)

     

       138
       138
       -
           |> Option.get

     

       139
       139
       -
         in

     

       140
       140
       -
         let d2 =

     

       141
       141
       -
           Ptime.of_date

     

       142
       142
       -
             (try date p2 with

     

       143
       143
       -
              | _ -> 1977, 1, 1)

     

       144
       144
       -
           |> Option.get

     

       145
       145
       -
         in

     

       146
       146
       -
         Ptime.compare d1 d2

     

       147
       147
       -
       ;;

     

       148
       148
       -
       

     

       149
       149
       -
       let get_papers ~slug ts =

     

       150
       150
       -
         List.filter (fun p -> p.slug = slug && p.latest <> true) ts |> List.sort compare

     

       151
       151
       -
       ;;

     

       152
       152
       -
       

     

       153
       153
       -
       let read_file file = In_channel.(with_open_bin file input_all)

     

       154
       154
       -
       

     

       155
       155
       -
       let of_md ~slug ~ver fname =

     

       156
       156
       -
         (* TODO fix Jekyll_post to not error on no date *)

     

       157
       157
       -
         let fname' = "2000-01-01-" ^ Filename.basename fname in

     

       158
       158
       -
         match Jekyll_post.of_string ~fname:fname' (read_file fname) with

     

       159
       159
       -
         | Error (`Msg m) -> failwith ("paper_of_md: " ^ m)

     

       160
       160
       -
         | Ok jp ->

     

       161
       161
       -
           let fields = jp.Jekyll_post.fields |> Jekyll_format.fields_to_yaml in

     

       162
       162
       -
           let { Jekyll_post.body; _ } = jp in

     

       163
       163
       -
           { slug; ver; abstract = body; paper = fields; latest = false }

     

       164
       164
       -
       ;;

     

       165
       165
       -
       

     

       166
       166
       -
       let tv (l : t list) =

     

       167
       167
       -
         let h = Hashtbl.create 7 in

     

       168
       168
       -
         List.iter

     

       169
       169
       -
           (fun { slug; ver; _ } ->

     

       170
       170
       -
             match Hashtbl.find_opt h slug with

     

       171
       171
       -
             | None -> Hashtbl.add h slug [ ver ]

     

       172
       172
       -
             | Some l ->

     

       173
       173
       -
               let l = ver :: l in

     

       174
       174
       -
               let l = List.sort Stdlib.compare l in

     

       175
       175
       -
               Hashtbl.replace h slug l)

     

       176
       176
       -
           l;

     

       177
       177
       -
         List.map

     

       178
       178
       -
           (fun p ->

     

       179
       179
       -
             let latest = Hashtbl.find h p.slug |> List.rev |> List.hd in

     

       180
       180
       -
             let latest = p.ver = latest in

     

       181
       181
       -
             { p with latest })

     

       182
       182
       -
           l

     

       183
       183
       -
       ;;

     

       184
       184
       -
       

     

       185
       185
       -
       let lookup ts slug = List.find_opt (fun t -> t.slug = slug && t.latest) ts

     

       186
       186
       -
       

     

       187
       187
       -
       let tag_of_bibtype bt =

     

       188
       188
       -
         match String.lowercase_ascii bt with

     

       189
       189
       -
         | "article" -> "journal"

     

       190
       190
       -
         | "inproceedings" -> "conference"

     

       191
       191
       -
         | "techreport" -> "report"

     

       192
       192
       -
         | "misc" -> "preprint"

     

       193
       193
       -
         | "book" -> "book"

     

       194
       194
       -
         | x -> x

     

       195
       195
       -
       ;;

     

       196
       196
       -
       

     

       197
       197
       -
       let tags { paper; _ } =

     

       198
       198
       -
         let tags f =

     

       199
       199
       -
           try key paper f |> J.get_list J.get_string with

     

       200
       200
       -
           | _ -> []

     

       201
       201
       -
         in

     

       202
       202
       -
         let core = tags "tags" in

     

       203
       203
       -
         let extra = tags "keywords" in

     

       204
       204
       -
         let projects = tags "projects" in

     

       205
       205
       -
         let ty = [ key paper "bibtype" |> J.get_string |> tag_of_bibtype ] in

     

       206
       206
       -
         List.flatten [ core; extra; ty; projects ]

     

       207
       207
       -
       ;;

     

       208
       208
       -
       

     

       209
       209
       -
       let best_url p =

     

       210
       210
       -
         if Sys.file_exists (Printf.sprintf "static/papers/%s.pdf" (slug p))

     

       211
       211
       -
         then Some (Printf.sprintf "/papers/%s.pdf" (slug p))

     

       212
       212
       -
         else url p

     

       213
       213
       -
       ;;

     

       214
       214
       -
       

     

       215
       215
       -
       (** TODO:claude Classification types for papers *)

     

       216
       216
       -
       type classification = Full | Short | Preprint

     

       217
       217
       -
       

     

       218
       218
       -
       let string_of_classification = function

     

       219
       219
       -
         | Full -> "full"

     

       220
       220
       -
         | Short -> "short" 

     

       221
       221
       -
         | Preprint -> "preprint"

     

       222
       222
       -
       

     

       223
       223
       -
       let classification_of_string = function

     

       224
       224
       -
         | "full" -> Full

     

       225
       225
       -
         | "short" -> Short

     

       226
       226
       -
         | "preprint" -> Preprint

     

       227
       227
       -
         | _ -> Full (* default to full if unknown *)

     

       228
       228
       -
       

     

       229
       229
       -
       (** TODO:claude Get classification from paper metadata, with fallback to heuristic *)

     

       230
       230
       -
       let classification { paper; _ } =

     

       231
       231
       -
         try 

     

       232
       232
       -
           key paper "classification" |> J.get_string |> classification_of_string

     

       233
       233
       -
         with _ -> 

     

       234
       234
       -
           (* Fallback to heuristic classification based on venue/bibtype/title *)

     

       235
       235
       -
           let bibtype = try key paper "bibtype" |> J.get_string with _ -> "" in

     

       236
       236
       -
           let journal = try key paper "journal" |> J.get_string |> String.lowercase_ascii with _ -> "" in

     

       237
       237
       -
           let booktitle = try key paper "booktitle" |> J.get_string |> String.lowercase_ascii with _ -> "" in

     

       238
       238
       -
           let title_str = try key paper "title" |> J.get_string |> String.lowercase_ascii with _ -> "" in

     

       239
       239
       -
           

     

       240
       240
       -
           (* Helper function to check if text contains any of the patterns *)

     

       241
       241
       -
           let contains_any text patterns =

     

       242
       242
       -
             List.exists (fun pattern ->

     

       243
       243
       -
               let regex = Re.Perl.compile_pat ~opts:[`Caseless] pattern in

     

       244
       244
       -
               Re.execp regex text

     

       245
       245
       -
             ) patterns

     

       246
       246
       -
           in

     

       247
       247
       -
           

     

       248
       248
       -
           (* Check for preprint indicators *)

     

       249
       249
       -
           let bibtype_lower = String.lowercase_ascii bibtype in

     

       250
       250
       -
           if contains_any journal ["arxiv"] || contains_any booktitle ["arxiv"] || bibtype_lower = "misc" || bibtype_lower = "techreport"

     

       251
       251
       -
           then Preprint

     

       252
       252
       -
           (* Check for workshop/short paper indicators including in title *)

     

       253
       253
       -
           else if contains_any journal ["workshop"; "wip"; "poster"; "demo"; "hotdep"; "short"] ||

     

       254
       254
       -
                   contains_any booktitle ["workshop"; "wip"; "poster"; "demo"; "hotdep"; "short"] ||

     

       255
       255
       -
                   contains_any title_str ["poster"]

     

       256
       256
       -
           then Short

     

       257
       257
       -
           (* Default to full paper (journal or conference) *)

     

       258
       258
       -
           else Full

     

       259
       259
       -
       

     

       260
       260
       -
       (** TODO:claude Check if paper is marked as selected *)

     

       261
       261
       -
       let selected { paper; _ } =

     

       262
       262
       -
         try 

     

       263
       263
       -
           let keys = J.get_dict paper in

     

       264
       264
       -
           match List.assoc_opt "selected" keys with

     

       265
       265
       -
           | Some (`Bool true) -> true

     

       266
       266
       -
           | Some (`String "true") -> true

     

       267
       267
       -
           | _ -> false

     

       268
       268
       -
         with _ -> false

     

       269
       269
       -
       

     

       270
       270
       -
       (** TODO:claude Get note field from paper metadata *)

     

       271
       271
       -
       let note { paper; _ } =

     

       272
       272
       -
         try 

     

       273
       273
       -
           let keys = J.get_dict paper in

     

       274
       274
       -
           match List.assoc_opt "note" keys with

     

       275
       275
       -
           | Some note_json -> Some (J.get_string note_json)

     

       276
       276
       -
           | None -> None

     

       277
       277
       -
         with _ -> None

     

       278
       278
       -
       

     

       279
       279
       -
       (* TODO:claude *)

     

       280
       280
       -
       let to_yaml ?abstract ~ver:_ json_data =

     

       281
       281
       -
         (* Don't add version - it's inferred from filename *)

     

       282
       282
       -
         let frontmatter = Yaml.to_string_exn json_data in

     

       283
       283
       -
         match abstract with

     

       284
       284
       -
         | Some abs -> 

     

       285
       285
       -
           (* Trim leading/trailing whitespace and normalize blank lines *)

     

       286
       286
       -
           let trimmed_abs = String.trim abs in

     

       287
       287
       -
           let normalized_abs = 

     

       288
       288
       -
             (* Replace 3+ consecutive newlines with exactly 2 newlines *)

     

       289
       289
       -
             Re.replace_string (Re.compile (Re.seq [Re.char '\n'; Re.char '\n'; Re.rep1 (Re.char '\n')])) ~by:"\n\n" trimmed_abs

     

       290
       290
       -
           in

     

       291
       291
       -
           if normalized_abs = "" then

     

       292
       292
       -
             Printf.sprintf "---\n%s---\n" frontmatter

     

       293
       293
       -
           else

     

       294
       294
       -
             Printf.sprintf "---\n%s---\n\n%s\n" frontmatter normalized_abs

     

       295
       295
       -
         | None -> Printf.sprintf "---\n%s---\n" frontmatter

     

       296
       296
       -
       

     

       297
       297
       -
       (* TODO:claude *)

     

       298
       298
       -
       let typesense_schema =

     

       299
       299
       -
         let open Ezjsonm in

     

       300
       300
       -
         dict [

     

       301
       301
       -
           ("name", string "papers");

     

       302
       302
       -
           ("fields", list (fun d -> dict d) [

     

       303
       303
       -
             [("name", string "id"); ("type", string "string")];

     

       304
       304
       -
             [("name", string "title"); ("type", string "string")];

     

       305
       305
       -
             [("name", string "authors"); ("type", string "string[]")];

     

       306
       306
       -
             [("name", string "abstract"); ("type", string "string")];

     

       307
       307
       -
             [("name", string "date"); ("type", string "string")];

     

       308
       308
       -
             [("name", string "date_timestamp"); ("type", string "int64")];

     

       309
       309
       -
             [("name", string "tags"); ("type", string "string[]"); ("facet", bool true)];

     

       310
       310
       -
             [("name", string "doi"); ("type", string "string[]"); ("optional", bool true)];

     

       311
       311
       -
             [("name", string "arxiv_id"); ("type", string "string"); ("optional", bool true)];

     

       312
       312
       -
             [("name", string "pdf_url"); ("type", string "string[]"); ("optional", bool true)];

     

       313
       313
       -
             [("name", string "thumbnail_url"); ("type", string "string"); ("optional", bool true)];

     

       314
       314
       -
             [("name", string "journal"); ("type", string "string[]"); ("optional", bool true)];

     

       315
       315
       -
             [("name", string "related_projects"); ("type", string "string[]"); ("optional", bool true)];

     

       316
       316
       -
             [("name", string "related_talks"); ("type", string "string[]"); ("optional", bool true)];

     

       317
       317
       -
           ]);

     

       318
       318
       -
           ("default_sorting_field", string "date_timestamp");

     

       319
       319
       -
         ]

     

       320
       320
       -
       

     

       321
       321
       -
       (** TODO:claude Pretty-print a paper with ANSI formatting *)

     

       322
       322
       -
       let pp ppf p =

     

       323
       323
       -
         let open Fmt in

     

       324
       324
       -
         pf ppf "@[<v>";

     

       325
       325
       -
         pf ppf "%a: %a@," (styled `Bold string) "Type" (styled `Cyan string) "Paper";

     

       326
       326
       -
         pf ppf "%a: %a@," (styled `Bold string) "Slug" string (slug p);

     

       327
       327
       -
         pf ppf "%a: %a@," (styled `Bold string) "Version" string p.ver;

     

       328
       328
       -
         pf ppf "%a: %a@," (styled `Bold string) "Title" string (title p);

     

       329
       329
       -
         pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Authors" (list ~sep:comma string) (authors p);

     

       330
       330
       -
         pf ppf "%a: %a@," (styled `Bold string) "Year" int (year p);

     

       331
       331
       -
         pf ppf "%a: %a@," (styled `Bold string) "Bibtype" string (bibtype p);

     

       332
       332
       -
         (match doi p with

     

       333
       333
       -
          | Some d -> pf ppf "%a: %a@," (styled `Bold string) "DOI" string d

     

       334
       334
       -
          | None -> ());

     

       335
       335
       -
         (match url p with

     

       336
       336
       -
          | Some u -> pf ppf "%a: %a@," (styled `Bold string) "URL" string u

     

       337
       337
       -
          | None -> ());

     

       338
       338
       -
         (match video p with

     

       339
       339
       -
          | Some v -> pf ppf "%a: %a@," (styled `Bold string) "Video" string v

     

       340
       340
       -
          | None -> ());

     

       341
       341
       -
         let projs = project_slugs p in

     

       342
       342
       -
         if projs <> [] then

     

       343
       343
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Projects" (list ~sep:comma string) projs;

     

       344
       344
       -
         let sl = slides p in

     

       345
       345
       -
         if sl <> [] then

     

       346
       346
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Slides" (list ~sep:comma string) sl;

     

       347
       347
       -
         (match bibtype p with

     

       348
       348
       -
          | "article" ->

     

       349
       349
       -
            pf ppf "%a: %a@," (styled `Bold string) "Journal" string (journal p);

     

       350
       350
       -
            (match volume p with

     

       351
       351
       -
             | Some vol -> pf ppf "%a: %a@," (styled `Bold string) "Volume" string vol

     

       352
       352
       -
             | None -> ());

     

       353
       353
       -
            (match issue p with

     

       354
       354
       -
             | Some iss -> pf ppf "%a: %a@," (styled `Bold string) "Issue" string iss

     

       355
       355
       -
             | None -> ());

     

       356
       356
       -
            let pgs = pages p in

     

       357
       357
       -
            if pgs <> "" then

     

       358
       358
       -
              pf ppf "%a: %a@," (styled `Bold string) "Pages" string pgs;

     

       359
       359
       -
          | "inproceedings" ->

     

       360
       360
       -
            pf ppf "%a: %a@," (styled `Bold string) "Booktitle" string (booktitle p);

     

       361
       361
       -
            let pgs = pages p in

     

       362
       362
       -
            if pgs <> "" then

     

       363
       363
       -
              pf ppf "%a: %a@," (styled `Bold string) "Pages" string pgs;

     

       364
       364
       -
          | "techreport" ->

     

       365
       365
       -
            pf ppf "%a: %a@," (styled `Bold string) "Institution" string (institution p);

     

       366
       366
       -
            (match number p with

     

       367
       367
       -
             | Some num -> pf ppf "%a: %a@," (styled `Bold string) "Number" string num

     

       368
       368
       -
             | None -> ());

     

       369
       369
       -
          | _ -> ());

     

       370
       370
       -
         pf ppf "@,";

     

       371
       371
       -
         pf ppf "%a:@," (styled `Bold string) "Abstract";

     

       372
       372
       -
         pf ppf "%a@," (styled `Faint string) (abstract p);

     

       373
       373
       -
         pf ppf "@]"

-55

stack/bushel/lib/paper.mli

···

       1
       1
       -
       type paper

     

       2
       2
       -
       

     

       3
       3
       -
       type t =

     

       4
       4
       -
         { slug : string

     

       5
       5
       -
         ; ver : string

     

       6
       6
       -
         ; paper : paper

     

       7
       7
       -
         ; abstract : string

     

       8
       8
       -
         ; latest : bool

     

       9
       9
       -
         }

     

       10
       10
       -
       

     

       11
       11
       -
       type ts = t list

     

       12
       12
       -
       

     

       13
       13
       -
       val tv : t list -> ts

     

       14
       14
       -
       val slug : t -> string

     

       15
       15
       -
       val title : t -> string

     

       16
       16
       -
       val authors : t -> string list

     

       17
       17
       -
       val project_slugs : t -> string list

     

       18
       18
       -
       val slides : t -> string list

     

       19
       19
       -
       val bibtype : t -> string

     

       20
       20
       -
       val journal : t -> string

     

       21
       21
       -
       val raw_json : t -> Ezjsonm.value

     

       22
       22
       -
       val doi : t -> string option

     

       23
       23
       -
       val volume : t -> string option

     

       24
       24
       -
       val video : t -> string option

     

       25
       25
       -
       val issue : t -> string option

     

       26
       26
       -
       val url : t -> string option

     

       27
       27
       -
       val best_url : t -> string option

     

       28
       28
       -
       val pages : t -> string

     

       29
       29
       -
       val abstract : t -> string

     

       30
       30
       -
       val institution : t -> string

     

       31
       31
       -
       val number : t -> string option

     

       32
       32
       -
       val editor : t -> string

     

       33
       33
       -
       val isbn : t -> string

     

       34
       34
       -
       val bib : t -> string

     

       35
       35
       -
       val year : t -> int

     

       36
       36
       -
       val publisher : t -> string

     

       37
       37
       -
       val booktitle : t -> string

     

       38
       38
       -
       val tags : t -> string list

     

       39
       39
       -
       val date : t -> int * int * int

     

       40
       40
       -
       val datetime : t -> Ptime.t

     

       41
       41
       -
       val compare : t -> t -> int

     

       42
       42
       -
       val get_papers : slug:string -> ts -> ts

     

       43
       43
       -
       val slugs : ts -> string list

     

       44
       44
       -
       val lookup : ts -> string -> t option

     

       45
       45
       -
       val of_md : slug:string -> ver:string -> string -> t

     

       46
       46
       -
       val to_yaml : ?abstract:string -> ver:string -> Ezjsonm.value -> string

     

       47
       47
       -
       val typesense_schema : Ezjsonm.value

     

       48
       48
       -
       

     

       49
       49
       -
       type classification = Full | Short | Preprint

     

       50
       50
       -
       val string_of_classification : classification -> string

     

       51
       51
       -
       val classification_of_string : string -> classification

     

       52
       52
       -
       val classification : t -> classification

     

       53
       53
       -
       val selected : t -> bool

     

       54
       54
       -
       val note : t -> string option

     

       55
       55
       -
       val pp : Format.formatter -> t -> unit

-100

stack/bushel/lib/project.ml

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { slug : string

     

       3
       3
       -
         ; title : string

     

       4
       4
       -
         ; start : int (* year *)

     

       5
       5
       -
         ; finish : int option

     

       6
       6
       -
         ; tags : string list

     

       7
       7
       -
         ; ideas : string

     

       8
       8
       -
         ; body : string

     

       9
       9
       -
         }

     

       10
       10
       -
       

     

       11
       11
       -
       type ts = t list

     

       12
       12
       -
       

     

       13
       13
       -
       let tags p = p.tags

     

       14
       14
       -
       

     

       15
       15
       -
       let compare a b =

     

       16
       16
       -
         match compare a.start b.start with

     

       17
       17
       -
         | 0 -> compare b.finish a.finish

     

       18
       18
       -
         | n -> n

     

       19
       19
       -
       ;;

     

       20
       20
       -
       

     

       21
       21
       -
       let title { title; _ } = title

     

       22
       22
       -
       let body { body; _ } = body

     

       23
       23
       -
       let ideas { ideas; _ } = ideas

     

       24
       24
       -
       

     

       25
       25
       -
       let of_md fname =

     

       26
       26
       -
         match Jekyll_post.of_string ~fname (Util.read_file fname) with

     

       27
       27
       -
         | Error (`Msg m) -> failwith ("Project.of_file: " ^ m)

     

       28
       28
       -
         | Ok jp ->

     

       29
       29
       -
           let fields = jp.Jekyll_post.fields in

     

       30
       30
       -
           let { Jekyll_post.title; date; slug; body; _ } = jp in

     

       31
       31
       -
           let (start, _, _), _ = Ptime.to_date_time date in

     

       32
       32
       -
           let finish =

     

       33
       33
       -
             match Jekyll_format.find "finish" fields with

     

       34
       34
       -
             | Some (`String date) ->

     

       35
       35
       -
               let date = Jekyll_format.parse_date_exn date in

     

       36
       36
       -
               let (finish, _, _), _ = Ptime.to_date_time date in

     

       37
       37
       -
               Some finish

     

       38
       38
       -
             | _ -> None

     

       39
       39
       -
           in

     

       40
       40
       -
           let ideas =

     

       41
       41
       -
             match Jekyll_format.find "ideas" fields with

     

       42
       42
       -
             | Some (`String e) -> e

     

       43
       43
       -
             | _ -> failwith ("no ideas key in " ^ fname)

     

       44
       44
       -
           in

     

       45
       45
       -
           let tags =

     

       46
       46
       -
             match Jekyll_format.find "tags" fields with

     

       47
       47
       -
             | Some (`A tags) -> List.map Yaml.Util.to_string_exn tags

     

       48
       48
       -
             | _ -> []

     

       49
       49
       -
           in

     

       50
       50
       -
           { slug; title; start; finish; ideas; tags; body }

     

       51
       51
       -
       ;;

     

       52
       52
       -
       

     

       53
       53
       -
       let lookup projects slug = List.find_opt (fun p -> p.slug = slug) projects

     

       54
       54
       -
       

     

       55
       55
       -
       (* TODO:claude *)

     

       56
       56
       -
       let typesense_schema =

     

       57
       57
       -
         let open Ezjsonm in

     

       58
       58
       -
         dict [

     

       59
       59
       -
           ("name", string "projects");

     

       60
       60
       -
           ("fields", list (fun d -> dict d) [

     

       61
       61
       -
             [("name", string "id"); ("type", string "string")];

     

       62
       62
       -
             [("name", string "title"); ("type", string "string")];

     

       63
       63
       -
             [("name", string "description"); ("type", string "string")];

     

       64
       64
       -
             [("name", string "start_year"); ("type", string "int32")];

     

       65
       65
       -
             [("name", string "finish_year"); ("type", string "int32"); ("optional", bool true)];

     

       66
       66
       -
             [("name", string "date"); ("type", string "string")];

     

       67
       67
       -
             [("name", string "date_timestamp"); ("type", string "int64")];

     

       68
       68
       -
             [("name", string "tags"); ("type", string "string[]"); ("facet", bool true)];

     

       69
       69
       -
             [("name", string "repository_url"); ("type", string "string"); ("optional", bool true)];

     

       70
       70
       -
             [("name", string "homepage_url"); ("type", string "string"); ("optional", bool true)];

     

       71
       71
       -
             [("name", string "languages"); ("type", string "string[]"); ("facet", bool true); ("optional", bool true)];

     

       72
       72
       -
             [("name", string "license"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       73
       73
       -
             [("name", string "status"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       74
       74
       -
             [("name", string "related_papers"); ("type", string "string[]"); ("optional", bool true)];

     

       75
       75
       -
             [("name", string "related_talks"); ("type", string "string[]"); ("optional", bool true)];

     

       76
       76
       -
             [("name", string "body"); ("type", string "string"); ("optional", bool true)];

     

       77
       77
       -
             [("name", string "ideas"); ("type", string "string"); ("optional", bool true)];

     

       78
       78
       -
           ]);

     

       79
       79
       -
           ("default_sorting_field", string "date_timestamp");

     

       80
       80
       -
         ]

     

       81
       81
       -
       

     

       82
       82
       -
       (** TODO:claude Pretty-print a project with ANSI formatting *)

     

       83
       83
       -
       let pp ppf p =

     

       84
       84
       -
         let open Fmt in

     

       85
       85
       -
         pf ppf "@[<v>";

     

       86
       86
       -
         pf ppf "%a: %a@," (styled `Bold string) "Type" (styled `Cyan string) "Project";

     

       87
       87
       -
         pf ppf "%a: %a@," (styled `Bold string) "Slug" string p.slug;

     

       88
       88
       -
         pf ppf "%a: %a@," (styled `Bold string) "Title" string (title p);

     

       89
       89
       -
         pf ppf "%a: %d@," (styled `Bold string) "Start" p.start;

     

       90
       90
       -
         (match p.finish with

     

       91
       91
       -
          | Some year -> pf ppf "%a: %d@," (styled `Bold string) "Finish" year

     

       92
       92
       -
          | None -> pf ppf "%a: ongoing@," (styled `Bold string) "Finish");

     

       93
       93
       -
         let t = tags p in

     

       94
       94
       -
         if t <> [] then

     

       95
       95
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Tags" (list ~sep:comma string) t;

     

       96
       96
       -
         pf ppf "%a: %a@," (styled `Bold string) "Ideas" string (ideas p);

     

       97
       97
       -
         pf ppf "@,";

     

       98
       98
       -
         pf ppf "%a:@," (styled `Bold string) "Body";

     

       99
       99
       -
         pf ppf "%a@," string (body p);

     

       100
       100
       -
         pf ppf "@]"

-21

stack/bushel/lib/project.mli

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { slug : string

     

       3
       3
       -
         ; title : string

     

       4
       4
       -
         ; start : int

     

       5
       5
       -
         ; finish : int option

     

       6
       6
       -
         ; tags : string list

     

       7
       7
       -
         ; ideas : string

     

       8
       8
       -
         ; body : string

     

       9
       9
       -
         }

     

       10
       10
       -
       

     

       11
       11
       -
       type ts = t list

     

       12
       12
       -
       

     

       13
       13
       -
       val title : t -> string

     

       14
       14
       -
       val body : t -> string

     

       15
       15
       -
       val ideas : t -> string

     

       16
       16
       -
       val lookup : t list -> string -> t option

     

       17
       17
       -
       val tags : t -> string list

     

       18
       18
       -
       val compare : t -> t -> int

     

       19
       19
       -
       val of_md : string -> t

     

       20
       20
       -
       val typesense_schema : Ezjsonm.value

     

       21
       21
       -
       val pp : Format.formatter -> t -> unit

-44

stack/bushel/lib/srcsetter.ml

···

       1
       1
       -
       module MS = Map.Make (String)

     

       2
       2
       -
       

     

       3
       3
       -
       type t =

     

       4
       4
       -
         { name : string

     

       5
       5
       -
         ; slug : string

     

       6
       6
       -
         ; origin : string

     

       7
       7
       -
         ; dims : int * int

     

       8
       8
       -
         ; variants : (int * int) MS.t

     

       9
       9
       -
         }

     

       10
       10
       -
       

     

       11
       11
       -
       type ts = t list

     

       12
       12
       -
       

     

       13
       13
       -
       let v name slug origin variants dims = { name; slug; origin; variants; dims }

     

       14
       14
       -
       let slug { slug; _ } = slug

     

       15
       15
       -
       let origin { origin; _ } = origin

     

       16
       16
       -
       let name { name; _ } = name

     

       17
       17
       -
       let dims { dims; _ } = dims

     

       18
       18
       -
       let variants { variants; _ } = variants

     

       19
       19
       -
       

     

       20
       20
       -
       let dims_json_t =

     

       21
       21
       -
         let open Jsont in

     

       22
       22
       -
         let dec x y = x, y in

     

       23
       23
       -
         let enc (w, h) = function

     

       24
       24
       -
           | 0 -> w

     

       25
       25
       -
           | _ -> h

     

       26
       26
       -
         in

     

       27
       27
       -
         t2 ~dec ~enc uint16

     

       28
       28
       -
       ;;

     

       29
       29
       -
       

     

       30
       30
       -
       let json_t =

     

       31
       31
       -
         let open Jsont in

     

       32
       32
       -
         let open Jsont.Object in

     

       33
       33
       -
         map ~kind:"Entry" v

     

       34
       34
       -
         |> mem "name" string ~enc:name

     

       35
       35
       -
         |> mem "slug" string ~enc:slug

     

       36
       36
       -
         |> mem "origin" string ~enc:origin

     

       37
       37
       -
         |> mem "variants" (as_string_map dims_json_t) ~enc:variants

     

       38
       38
       -
         |> mem "dims" dims_json_t ~enc:dims

     

       39
       39
       -
         |> finish

     

       40
       40
       -
       ;;

     

       41
       41
       -
       

     

       42
       42
       -
       let list = Jsont.list json_t

     

       43
       43
       -
       let list_to_json es = Jsont_bytesrw.encode_string list ~format:Jsont.Indent es

     

       44
       44
       -
       let list_of_json = Jsont_bytesrw.decode_string list

-21

stack/bushel/lib/srcsetter.mli

···

       1
       1
       -
       module MS : Map.S with type key = string

     

       2
       2
       -
       

     

       3
       3
       -
       type t =

     

       4
       4
       -
         { name : string

     

       5
       5
       -
         ; slug : string

     

       6
       6
       -
         ; origin : string

     

       7
       7
       -
         ; dims : int * int

     

       8
       8
       -
         ; variants : (int * int) MS.t

     

       9
       9
       -
         }

     

       10
       10
       -
       

     

       11
       11
       -
       type ts = t list

     

       12
       12
       -
       

     

       13
       13
       -
       val origin : t -> string

     

       14
       14
       -
       val slug : t -> string

     

       15
       15
       -
       val name : t -> string

     

       16
       16
       -
       val dims : t -> int * int

     

       17
       17
       -
       val variants : t -> (int * int) MS.t

     

       18
       18
       -
       val list_to_json : t list -> (string, string) result

     

       19
       19
       -
       val list_of_json : string -> (t list, string) result

     

       20
       20
       -
       val json_t : t Jsont.t

     

       21
       21
       -
       val list : t list Jsont.t

-114

stack/bushel/lib/tags.ml

···

       1
       1
       -
       open Entry

     

       2
       2
       -
       

     

       3
       3
       -
       type t =

     

       4
       4
       -
         [ `Slug of string (* :foo points to the specific slug foo *)

     

       5
       5
       -
         | `Contact of string (* @foo points to contact foo *)

     

       6
       6
       -
         | `Set of string (* #papers points to all Paper entries *)

     

       7
       7
       -
         | `Text of string (* foo points to a free text "foo" *)

     

       8
       8
       -
         | `Year of int (* a number between 1900--2100 is interpreted as a year *)

     

       9
       9
       -
         ]

     

       10
       10
       -
       

     

       11
       11
       -
       let is_text = function

     

       12
       12
       -
         | `Text _ -> true

     

       13
       13
       -
         | _ -> false

     

       14
       14
       -
       ;;

     

       15
       15
       -
       

     

       16
       16
       -
       let is_slug = function

     

       17
       17
       -
         | `Slug _ -> true

     

       18
       18
       -
         | _ -> false

     

       19
       19
       -
       ;;

     

       20
       20
       -
       

     

       21
       21
       -
       let is_set = function

     

       22
       22
       -
         | `Set _ -> true

     

       23
       23
       -
         | _ -> false

     

       24
       24
       -
       ;;

     

       25
       25
       -
       

     

       26
       26
       -
       let is_year = function

     

       27
       27
       -
         | `Year _ -> true

     

       28
       28
       -
         | _ -> false

     

       29
       29
       -
       ;;

     

       30
       30
       -
       

     

       31
       31
       -
       let of_string s : t =

     

       32
       32
       -
         if String.length s < 2 then invalid_arg ("Tag.of_string: " ^ s);

     

       33
       33
       -
         match s.[0] with

     

       34
       34
       -
         | ':' ->

     

       35
       35
       -
           let slug = String.sub s 1 (String.length s - 1) in

     

       36
       36
       -
           `Slug slug

     

       37
       37
       -
         | '@' -> failwith "TODO add contacts to entries"

     

       38
       38
       -
         | '#' ->

     

       39
       39
       -
           let cl = String.sub s 1 (String.length s - 1) in

     

       40
       40
       -
           `Set cl

     

       41
       41
       -
         | _ ->

     

       42
       42
       -
           (try

     

       43
       43
       -
              let x = int_of_string s in

     

       44
       44
       -
              if x > 1900 && x < 2100 then `Year x else `Text s

     

       45
       45
       -
            with

     

       46
       46
       -
            | _ -> `Text s)

     

       47
       47
       -
       ;;

     

       48
       48
       -
       

     

       49
       49
       -
       let of_string_list l = List.map of_string l

     

       50
       50
       -
       

     

       51
       51
       -
       let to_string = function

     

       52
       52
       -
         | `Slug t -> ":" ^ t

     

       53
       53
       -
         | `Contact c -> "@" ^ c

     

       54
       54
       -
         | `Set s -> "#" ^ s

     

       55
       55
       -
         | `Text t -> t

     

       56
       56
       -
         | `Year y -> string_of_int y

     

       57
       57
       -
       ;;

     

       58
       58
       -
       

     

       59
       59
       -
       let to_raw_string = function

     

       60
       60
       -
         | `Slug t -> t

     

       61
       61
       -
         | `Contact c -> c

     

       62
       62
       -
         | `Set s -> s

     

       63
       63
       -
         | `Text t -> t

     

       64
       64
       -
         | `Year y -> string_of_int y

     

       65
       65
       -
       ;;

     

       66
       66
       -
       

     

       67
       67
       -
       let pp ppf t = Fmt.string ppf (to_string t)

     

       68
       68
       -
       

     

       69
       69
       -
       let tags_of_ent _entries ent : t list =

     

       70
       70
       -
         match ent with

     

       71
       71
       -
         | `Paper p -> of_string_list @@ Paper.tags p

     

       72
       72
       -
         | `Video v -> of_string_list v.Video.tags

     

       73
       73
       -
         | `Project p -> of_string_list @@ Project.tags p

     

       74
       74
       -
         | `Note n -> of_string_list @@ Note.tags n

     

       75
       75
       -
         | `Idea i -> of_string_list i.Idea.tags

     

       76
       76
       -
       ;;

     

       77
       77
       -
       

     

       78
       78
       -
       let mentions tags =

     

       79
       79
       -
         List.filter

     

       80
       80
       -
           (function

     

       81
       81
       -
             | `Contact _ | `Slug _ -> true

     

       82
       82
       -
             | _ -> false)

     

       83
       83
       -
           tags

     

       84
       84
       -
       ;;

     

       85
       85
       -
       

     

       86
       86
       -
       let mention_entries entries tags =

     

       87
       87
       -
         let lk t =

     

       88
       88
       -
          try Some (lookup_exn entries t)

     

       89
       89
       -
          with Not_found -> Printf.eprintf "mention_entries not found: %s\n%!" t; None

     

       90
       90
       -
         in

     

       91
       91
       -
         List.filter_map

     

       92
       92
       -
           (function

     

       93
       93
       -
             | `Slug t -> lk t

     

       94
       94
       -
             | _ -> None)

     

       95
       95
       -
           tags

     

       96
       96
       -
       ;;

     

       97
       97
       -
       

     

       98
       98
       -
       let count_tags ?h fn vs =

     

       99
       99
       -
         let h =

     

       100
       100
       -
           match h with

     

       101
       101
       -
           | Some h -> h

     

       102
       102
       -
           | None -> Hashtbl.create 42

     

       103
       103
       -
         in

     

       104
       104
       -
         List.iter

     

       105
       105
       -
           (fun ent ->

     

       106
       106
       -
             List.iter

     

       107
       107
       -
               (fun tag ->

     

       108
       108
       -
                 match Hashtbl.find_opt h tag with

     

       109
       109
       -
                 | Some num -> Hashtbl.replace h tag (num + 1)

     

       110
       110
       -
                 | None -> Hashtbl.add h tag 1)

     

       111
       111
       -
               (fn ent))

     

       112
       112
       -
           vs;

     

       113
       113
       -
         h

     

       114
       114
       -
       ;;

-25

stack/bushel/lib/tags.mli

···

       1
       1
       -
       type t =

     

       2
       2
       -
         [ `Contact of string

     

       3
       3
       -
         | `Set of string

     

       4
       4
       -
         | `Slug of string

     

       5
       5
       -
         | `Text of string

     

       6
       6
       -
         | `Year of int

     

       7
       7
       -
         ]

     

       8
       8
       -
       

     

       9
       9
       -
       val is_text : t -> bool

     

       10
       10
       -
       val is_set : t -> bool

     

       11
       11
       -
       val is_slug : t -> bool

     

       12
       12
       -
       val is_year : t -> bool

     

       13
       13
       -
       val of_string : string -> t

     

       14
       14
       -
       val to_string : t -> string

     

       15
       15
       -
       val to_raw_string : t -> string

     

       16
       16
       -
       val pp : Format.formatter -> t -> unit

     

       17
       17
       -
       val mention_entries : Entry.t -> t list -> Entry.entry list

     

       18
       18
       -
       val tags_of_ent : Entry.t -> Entry.entry -> t list

     

       19
       19
       -
       val mentions : t list -> t list

     

       20
       20
       -
       

     

       21
       21
       -
       val count_tags

     

       22
       22
       -
         :  ?h:('a, int) Hashtbl.t

     

       23
       23
       -
         -> ('b -> 'a list)

     

       24
       24
       -
         -> 'b list

     

       25
       25
       -
         -> ('a, int) Hashtbl.t

-527

stack/bushel/lib/typesense.ml

···

       1
       1
       -
       (** Typesense API client for Bushel *)

     

       2
       2
       -
       

     

       3
       3
       -
       type config = {

     

       4
       4
       -
         endpoint : string;

     

       5
       5
       -
         api_key : string;

     

       6
       6
       -
         openai_key : string;

     

       7
       7
       -
       }

     

       8
       8
       -
       

     

       9
       9
       -
       type error =

     

       10
       10
       -
         | Http_error of int * string

     

       11
       11
       -
         | Json_error of string

     

       12
       12
       -
         | Connection_error of string

     

       13
       13
       -
       

     

       14
       14
       -
       let pp_error fmt = function

     

       15
       15
       -
         | Http_error (code, msg) -> Fmt.pf fmt "HTTP %d: %s" code msg

     

       16
       16
       -
         | Json_error msg -> Fmt.pf fmt "JSON error: %s" msg

     

       17
       17
       -
         | Connection_error msg -> Fmt.pf fmt "Connection error: %s" msg

     

       18
       18
       -
       

     

       19
       19
       -
       (** Create authentication headers for Typesense API *)

     

       20
       20
       -
       let auth_headers api_key =

     

       21
       21
       -
         Requests.Headers.empty

     

       22
       22
       -
         |> Requests.Headers.set "X-TYPESENSE-API-KEY" api_key

     

       23
       23
       -
         |> Requests.Headers.set "Content-Type" "application/json"

     

       24
       24
       -
       

     

       25
       25
       -
       (** Make HTTP request to Typesense API *)

     

       26
       26
       -
       let make_request ~sw ~env ?(meth=`GET) ?(body="") config path =

     

       27
       27
       -
         let uri = Uri.of_string (config.endpoint ^ path) in

     

       28
       28
       -
         let headers = auth_headers config.api_key in

     

       29
       29
       -
         let body = if body = "" then None else Some (Requests.Body.of_string Requests.Mime.json body) in

     

       30
       30
       -
       

     

       31
       31
       -
         try

     

       32
       32
       -
           let response = Requests.One.request ~sw

     

       33
       33
       -
             ~clock:env#clock ~net:env#net

     

       34
       34
       -
             ?body

     

       35
       35
       -
             ~headers

     

       36
       36
       -
             ~method_:meth

     

       37
       37
       -
             (Uri.to_string uri)

     

       38
       38
       -
           in

     

       39
       39
       -
       

     

       40
       40
       -
           let status = Requests.Response.status_code response in

     

       41
       41
       -
           let body_flow = Requests.Response.body response in

     

       42
       42
       -
           let body_str = Eio.Flow.read_all body_flow in

     

       43
       43
       -
       

     

       44
       44
       -
           if status >= 200 && status < 300 then

     

       45
       45
       -
             Ok body_str

     

       46
       46
       -
           else

     

       47
       47
       -
             Error (Http_error (status, body_str))

     

       48
       48
       -
         with exn ->

     

       49
       49
       -
           Error (Connection_error (Printexc.to_string exn))

     

       50
       50
       -
       

     

       51
       51
       -
       (** Create a collection with given schema *)

     

       52
       52
       -
       let create_collection ~sw ~env config (schema : Ezjsonm.value) =

     

       53
       53
       -
         let body = Ezjsonm.value_to_string schema in

     

       54
       54
       -
         make_request ~sw ~env ~meth:`POST ~body config "/collections"

     

       55
       55
       -
       

     

       56
       56
       -
       (** Check if collection exists *)

     

       57
       57
       -
       let collection_exists ~sw ~env config name =

     

       58
       58
       -
         let result = make_request ~sw ~env config ("/collections/" ^ name) in

     

       59
       59
       -
         match result with

     

       60
       60
       -
         | Ok _ -> true

     

       61
       61
       -
         | Error (Http_error (404, _)) -> false

     

       62
       62
       -
         | Error _ -> false

     

       63
       63
       -
       

     

       64
       64
       -
       (** Delete a collection *)

     

       65
       65
       -
       let delete_collection ~sw ~env config name =

     

       66
       66
       -
         make_request ~sw ~env ~meth:`DELETE config ("/collections/" ^ name)

     

       67
       67
       -
       

     

       68
       68
       -
       (** Upload documents to a collection in batch *)

     

       69
       69
       -
       let upload_documents ~sw ~env config collection_name (documents : Ezjsonm.value list) =

     

       70
       70
       -
         let jsonl_lines = List.map (fun doc -> Ezjsonm.value_to_string doc) documents in

     

       71
       71
       -
         let body = String.concat "\n" jsonl_lines in

     

       72
       72
       -
         make_request ~sw ~env ~meth:`POST ~body config

     

       73
       73
       -
           (Printf.sprintf "/collections/%s/documents/import?action=upsert" collection_name)

     

       74
       74
       -
       

     

       75
       75
       -
       

     

       76
       76
       -
       (** Convert Bushel objects to Typesense documents *)

     

       77
       77
       -
       

     

       78
       78
       -
       (** Helper function to truncate long strings for embedding *)

     

       79
       79
       -
       let truncate_for_embedding ?(max_chars=20000) text =

     

       80
       80
       -
         if String.length text <= max_chars then text

     

       81
       81
       -
         else String.sub text 0 max_chars

     

       82
       82
       -
       

     

       83
       83
       -
       (** Helper function to convert Ptime to Unix timestamp *)

     

       84
       84
       -
       let ptime_to_timestamp ptime =

     

       85
       85
       -
         let span = Ptime.to_span ptime in

     

       86
       86
       -
         let seconds = Ptime.Span.to_int_s span in

     

       87
       87
       -
         match seconds with

     

       88
       88
       -
         | Some s -> Int64.of_int s

     

       89
       89
       -
         | None -> 0L

     

       90
       90
       -
       

     

       91
       91
       -
       (** Helper function to convert date tuple to Unix timestamp *)

     

       92
       92
       -
       let date_to_timestamp (year, month, day) =

     

       93
       93
       -
         match Ptime.of_date (year, month, day) with

     

       94
       94
       -
         | Some ptime -> ptime_to_timestamp ptime

     

       95
       95
       -
         | None -> 0L

     

       96
       96
       -
       

     

       97
       97
       -
       (** Resolve author handles to full names in a list *)

     

       98
       98
       -
       let resolve_author_list contacts authors =

     

       99
       99
       -
         List.map (fun author ->

     

       100
       100
       -
           (* Strip '@' prefix if present *)

     

       101
       101
       -
           let handle =

     

       102
       102
       -
             if String.length author > 0 && author.[0] = '@' then

     

       103
       103
       -
               String.sub author 1 (String.length author - 1)

     

       104
       104
       -
             else

     

       105
       105
       -
               author

     

       106
       106
       -
           in

     

       107
       107
       -
           (* Try to look up as a contact handle *)

     

       108
       108
       -
           match Contact.find_by_handle contacts handle with

     

       109
       109
       -
           | Some contact -> Contact.name contact

     

       110
       110
       -
           | None -> author (* Keep original if not found *)

     

       111
       111
       -
         ) authors

     

       112
       112
       -
       

     

       113
       113
       -
       let contact_to_document (contact : Contact.t) =

     

       114
       114
       -
         let open Ezjsonm in

     

       115
       115
       -
         let safe_string_list_from_opt = function

     

       116
       116
       -
           | Some s -> [s]

     

       117
       117
       -
           | None -> []

     

       118
       118
       -
         in

     

       119
       119
       -
         dict [

     

       120
       120
       -
           ("id", string (Contact.handle contact));

     

       121
       121
       -
           ("handle", string (Contact.handle contact));

     

       122
       122
       -
           ("name", string (Contact.name contact));

     

       123
       123
       -
           ("names", list string (Contact.names contact));

     

       124
       124
       -
           ("email", list string (safe_string_list_from_opt (Contact.email contact)));

     

       125
       125
       -
           ("icon", list string (safe_string_list_from_opt (Contact.icon contact)));

     

       126
       126
       -
           ("github", list string (safe_string_list_from_opt (Contact.github contact)));

     

       127
       127
       -
           ("twitter", list string (safe_string_list_from_opt (Contact.twitter contact)));

     

       128
       128
       -
           ("url", list string (safe_string_list_from_opt (Contact.url contact)));

     

       129
       129
       -
         ]

     

       130
       130
       -
       

     

       131
       131
       -
       let paper_to_document entries (paper : Paper.t) =

     

       132
       132
       -
         let date_tuple = Paper.date paper in

     

       133
       133
       -
         let contacts = Entry.contacts entries in

     

       134
       134
       -
       

     

       135
       135
       -
         (* Helper to extract string arrays from JSON, handling both single strings and arrays *)

     

       136
       136
       -
         let extract_string_array_from_json json_field_name =

     

       137
       137
       -
           try

     

       138
       138
       -
             (* Access the raw JSON from the paper record *)

     

       139
       139
       -
             let paper_json = Paper.raw_json paper in

     

       140
       140
       -
             let value = Ezjsonm.get_dict paper_json |> List.assoc json_field_name in

     

       141
       141
       -
             match value with

     

       142
       142
       -
             | `String s -> [s]

     

       143
       143
       -
             | `A l -> List.filter_map (function `String s -> Some s | _ -> None) l

     

       144
       144
       -
             | _ -> []

     

       145
       145
       -
           with _ -> []

     

       146
       146
       -
         in

     

       147
       147
       -
       

     

       148
       148
       -
         (* Resolve author handles to full names *)

     

       149
       149
       -
         let authors = resolve_author_list contacts (Paper.authors paper) in

     

       150
       150
       -
       

     

       151
       151
       -
         (* Convert abstract markdown to plain text *)

     

       152
       152
       -
         let abstract = Md.markdown_to_plaintext entries (Paper.abstract paper) |> truncate_for_embedding in

     

       153
       153
       -
       

     

       154
       154
       -
         (* Extract publication metadata *)

     

       155
       155
       -
         let bibtype = Paper.bibtype paper in

     

       156
       156
       -
         let metadata =

     

       157
       157
       -
           try

     

       158
       158
       -
             match bibtype with

     

       159
       159
       -
             | "article" -> Printf.sprintf "Journal: %s" (Paper.journal paper)

     

       160
       160
       -
             | "inproceedings" -> Printf.sprintf "Proceedings: %s" (Paper.journal paper)

     

       161
       161
       -
             | "misc" | "techreport" -> Printf.sprintf "Preprint: %s" (Paper.journal paper)

     

       162
       162
       -
             | _ -> Printf.sprintf "%s: %s" (String.capitalize_ascii bibtype) (Paper.journal paper)

     

       163
       163
       -
           with _ -> bibtype

     

       164
       164
       -
         in

     

       165
       165
       -
       

     

       166
       166
       -
         (* Get bibtex from raw JSON *)

     

       167
       167
       -
         let bibtex =

     

       168
       168
       -
           try

     

       169
       169
       -
             let paper_json = Paper.raw_json paper in

     

       170
       170
       -
             Ezjsonm.get_dict paper_json

     

       171
       171
       -
             |> List.assoc "bibtex"

     

       172
       172
       -
             |> Ezjsonm.get_string

     

       173
       173
       -
           with _ -> ""

     

       174
       174
       -
         in

     

       175
       175
       -
       

     

       176
       176
       -
         let thumbnail_url = Entry.thumbnail entries (`Paper paper) in

     

       177
       177
       -
         Ezjsonm.dict [

     

       178
       178
       -
           ("id", Ezjsonm.string (Paper.slug paper));

     

       179
       179
       -
           ("title", Ezjsonm.string (Paper.title paper));

     

       180
       180
       -
           ("authors", Ezjsonm.list Ezjsonm.string authors);

     

       181
       181
       -
           ("abstract", Ezjsonm.string abstract);

     

       182
       182
       -
           ("metadata", Ezjsonm.string metadata);

     

       183
       183
       -
           ("bibtex", Ezjsonm.string bibtex);

     

       184
       184
       -
           ("date", Ezjsonm.string (let y, m, d = date_tuple in Printf.sprintf "%04d-%02d-%02d" y m d));

     

       185
       185
       -
           ("date_timestamp", Ezjsonm.int64 (date_to_timestamp date_tuple));

     

       186
       186
       -
           ("tags", Ezjsonm.list Ezjsonm.string (Paper.tags paper));

     

       187
       187
       -
           ("doi", Ezjsonm.list Ezjsonm.string (extract_string_array_from_json "doi"));

     

       188
       188
       -
           ("pdf_url", Ezjsonm.list Ezjsonm.string (extract_string_array_from_json "pdf_url"));

     

       189
       189
       -
           ("journal", Ezjsonm.list Ezjsonm.string (extract_string_array_from_json "journal"));

     

       190
       190
       -
           ("related_projects", Ezjsonm.list Ezjsonm.string (Paper.project_slugs paper));

     

       191
       191
       -
           ("thumbnail_url", Ezjsonm.string (Option.value ~default:"" thumbnail_url));

     

       192
       192
       -
         ]

     

       193
       193
       -
       

     

       194
       194
       -
       let project_to_document entries (project : Project.t) =

     

       195
       195
       -
         let open Ezjsonm in

     

       196
       196
       -
         (* Use January 1st of start year as the date for sorting *)

     

       197
       197
       -
         let date_timestamp = date_to_timestamp (project.start, 1, 1) in

     

       198
       198
       -
       

     

       199
       199
       -
         (* Convert body markdown to plain text *)

     

       200
       200
       -
         let description = Md.markdown_to_plaintext entries (Project.body project) |> truncate_for_embedding in

     

       201
       201
       -
       

     

       202
       202
       -
         let thumbnail_url = Entry.thumbnail entries (`Project project) in

     

       203
       203
       -
         dict [

     

       204
       204
       -
           ("id", string project.slug);

     

       205
       205
       -
           ("title", string (Project.title project));

     

       206
       206
       -
           ("description", string description);

     

       207
       207
       -
           ("start", int project.start);

     

       208
       208
       -
           ("finish", option int project.finish);

     

       209
       209
       -
           ("start_year", int project.start);

     

       210
       210
       -
           ("date", string (Printf.sprintf "%04d-01-01" project.start));

     

       211
       211
       -
           ("date_timestamp", int64 date_timestamp);

     

       212
       212
       -
           ("tags", list string (Project.tags project));

     

       213
       213
       -
           ("thumbnail_url", string (Option.value ~default:"" thumbnail_url));

     

       214
       214
       -
         ]

     

       215
       215
       -
       

     

       216
       216
       -
       let video_to_document entries (video : Video.t) =

     

       217
       217
       -
         let open Ezjsonm in

     

       218
       218
       -
         let datetime = Video.datetime video in

     

       219
       219
       -
         let safe_string_list_from_opt = function

     

       220
       220
       -
           | Some s -> [s]

     

       221
       221
       -
           | None -> []

     

       222
       222
       -
         in

     

       223
       223
       -
       

     

       224
       224
       -
         (* Convert body markdown to plain text *)

     

       225
       225
       -
         let description = Md.markdown_to_plaintext entries (Video.body video) |> truncate_for_embedding in

     

       226
       226
       -
       

     

       227
       227
       -
         (* Resolve paper and project slugs to titles *)

     

       228
       228
       -
         let paper_title = match Video.paper video with

     

       229
       229
       -
           | Some slug ->

     

       230
       230
       -
               (match Entry.lookup entries slug with

     

       231
       231
       -
                | Some entry -> Some (Entry.title entry)

     

       232
       232
       -
                | None -> Some slug) (* Fallback to slug if not found *)

     

       233
       233
       -
           | None -> None

     

       234
       234
       -
         in

     

       235
       235
       -
         let project_title = match Video.project video with

     

       236
       236
       -
           | Some slug ->

     

       237
       237
       -
               (match Entry.lookup entries slug with

     

       238
       238
       -
                | Some entry -> Some (Entry.title entry)

     

       239
       239
       -
                | None -> Some slug) (* Fallback to slug if not found *)

     

       240
       240
       -
           | None -> None

     

       241
       241
       -
         in

     

       242
       242
       -
       

     

       243
       243
       -
         let thumbnail_url = Entry.thumbnail entries (`Video video) in

     

       244
       244
       -
         dict [

     

       245
       245
       -
           ("id", string (Video.slug video));

     

       246
       246
       -
           ("title", string (Video.title video));

     

       247
       247
       -
           ("description", string description);

     

       248
       248
       -
           ("published_date", string (Ptime.to_rfc3339 datetime));

     

       249
       249
       -
           ("date", string (Ptime.to_rfc3339 datetime));

     

       250
       250
       -
           ("date_timestamp", int64 (ptime_to_timestamp datetime));

     

       251
       251
       -
           ("url", string (Video.url video));

     

       252
       252
       -
           ("uuid", string (Video.uuid video));

     

       253
       253
       -
           ("is_talk", bool (Video.talk video));

     

       254
       254
       -
           ("paper", list string (safe_string_list_from_opt paper_title));

     

       255
       255
       -
           ("project", list string (safe_string_list_from_opt project_title));

     

       256
       256
       -
           ("tags", list string video.tags);

     

       257
       257
       -
           ("thumbnail_url", string (Option.value ~default:"" thumbnail_url));

     

       258
       258
       -
         ]

     

       259
       259
       -
       

     

       260
       260
       -
       let note_to_document entries (note : Note.t) =

     

       261
       261
       -
         let open Ezjsonm in

     

       262
       262
       -
         let datetime = Note.datetime note in

     

       263
       263
       -
         let safe_string_list_from_opt = function

     

       264
       264
       -
           | Some s -> [s]

     

       265
       265
       -
           | None -> []

     

       266
       266
       -
         in

     

       267
       267
       -
       

     

       268
       268
       -
         (* Convert body markdown to plain text *)

     

       269
       269
       -
         let content = Md.markdown_to_plaintext entries (Note.body note) |> truncate_for_embedding in

     

       270
       270
       -
       

     

       271
       271
       -
         let thumbnail_url = Entry.thumbnail entries (`Note note) in

     

       272
       272
       -
         let word_count = Note.words note in

     

       273
       273
       -
         dict [

     

       274
       274
       -
           ("id", string (Note.slug note));

     

       275
       275
       -
           ("title", string (Note.title note));

     

       276
       276
       -
           ("date", string (Ptime.to_rfc3339 datetime));

     

       277
       277
       -
           ("date_timestamp", int64 (ptime_to_timestamp datetime));

     

       278
       278
       -
           ("content", string content);

     

       279
       279
       -
           ("tags", list string (Note.tags note));

     

       280
       280
       -
           ("draft", bool (Note.draft note));

     

       281
       281
       -
           ("synopsis", list string (safe_string_list_from_opt (Note.synopsis note)));

     

       282
       282
       -
           ("thumbnail_url", string (Option.value ~default:"" thumbnail_url));

     

       283
       283
       -
           ("words", int word_count);

     

       284
       284
       -
         ]

     

       285
       285
       -
       

     

       286
       286
       -
       let idea_to_document entries (idea : Idea.t) =

     

       287
       287
       -
         let open Ezjsonm in

     

       288
       288
       -
         let contacts = Entry.contacts entries in

     

       289
       289
       -
         (* Use January 1st of the year as the date for sorting *)

     

       290
       290
       -
         let date_timestamp = date_to_timestamp (Idea.year idea, 1, 1) in

     

       291
       291
       -
       

     

       292
       292
       -
         (* Convert body markdown to plain text *)

     

       293
       293
       -
         let description = Md.markdown_to_plaintext entries (Idea.body idea) |> truncate_for_embedding in

     

       294
       294
       -
       

     

       295
       295
       -
         (* Resolve supervisor and student handles to full names *)

     

       296
       296
       -
         let supervisors = resolve_author_list contacts (Idea.supervisors idea) in

     

       297
       297
       -
         let students = resolve_author_list contacts (Idea.students idea) in

     

       298
       298
       -
       

     

       299
       299
       -
         (* Resolve project slug to project title *)

     

       300
       300
       -
         let project_title =

     

       301
       301
       -
           match Entry.lookup entries (Idea.project idea) with

     

       302
       302
       -
           | Some entry -> Entry.title entry

     

       303
       303
       -
           | None -> Idea.project idea (* Fallback to slug if not found *)

     

       304
       304
       -
         in

     

       305
       305
       -
       

     

       306
       306
       -
         let thumbnail_url = Entry.thumbnail entries (`Idea idea) in

     

       307
       307
       -
         dict [

     

       308
       308
       -
           ("id", string idea.slug);

     

       309
       309
       -
           ("title", string (Idea.title idea));

     

       310
       310
       -
           ("description", string description);

     

       311
       311
       -
           ("level", string (Idea.level_to_string (Idea.level idea)));

     

       312
       312
       -
           ("project", string project_title);

     

       313
       313
       -
           ("status", string (Idea.status_to_string (Idea.status idea)));

     

       314
       314
       -
           ("year", int (Idea.year idea));

     

       315
       315
       -
           ("date", string (Printf.sprintf "%04d-01-01" (Idea.year idea)));

     

       316
       316
       -
           ("date_timestamp", int64 date_timestamp);

     

       317
       317
       -
           ("supervisors", list string supervisors);

     

       318
       318
       -
           ("students", list string students);

     

       319
       319
       -
           ("tags", list string idea.tags);

     

       320
       320
       -
           ("thumbnail_url", string (Option.value ~default:"" thumbnail_url));

     

       321
       321
       -
         ]

     

       322
       322
       -
       

     

       323
       323
       -
       (** Helper function to add embedding field to schema *)

     

       324
       324
       -
       let add_embedding_field_to_schema schema config embedding_from_fields =

     

       325
       325
       -
         let open Ezjsonm in

     

       326
       326
       -
         let fields = get_dict schema |> List.assoc "fields" |> get_list (fun f -> f) in

     

       327
       327
       -
         let embedding_field = dict [

     

       328
       328
       -
           ("name", string "embedding");

     

       329
       329
       -
           ("type", string "float[]");

     

       330
       330
       -
           ("embed", dict [

     

       331
       331
       -
             ("from", list string embedding_from_fields);

     

       332
       332
       -
             ("model_config", dict [

     

       333
       333
       -
               ("model_name", string "openai/text-embedding-3-small");

     

       334
       334
       -
               ("api_key", string config.openai_key);

     

       335
       335
       -
             ]);

     

       336
       336
       -
           ]);

     

       337
       337
       -
         ] in

     

       338
       338
       -
         let updated_fields = fields @ [embedding_field] in

     

       339
       339
       -
         let updated_schema =

     

       340
       340
       -
           List.map (fun (k, v) ->

     

       341
       341
       -
             if k = "fields" then (k, list (fun f -> f) updated_fields)

     

       342
       342
       -
             else (k, v)

     

       343
       343
       -
           ) (get_dict schema)

     

       344
       344
       -
         in

     

       345
       345
       -
         dict updated_schema

     

       346
       346
       -
       

     

       347
       347
       -
       (** Upload all bushel objects to their respective collections *)

     

       348
       348
       -
       let upload_all ~sw ~env config entries =

     

       349
       349
       -
         print_string "Uploading bushel data to Typesense\n";

     

       350
       350
       -
       

     

       351
       351
       -
         let contacts = Entry.contacts entries in

     

       352
       352
       -
         let papers = Entry.papers entries in

     

       353
       353
       -
         let projects = Entry.projects entries in

     

       354
       354
       -
         let notes = Entry.notes entries in

     

       355
       355
       -
         let videos = Entry.videos entries in

     

       356
       356
       -
         let ideas = Entry.ideas entries in

     

       357
       357
       -
       

     

       358
       358
       -
         let collections = [

     

       359
       359
       -
           ("contacts", add_embedding_field_to_schema Contact.typesense_schema config ["name"; "names"], (List.map contact_to_document contacts : Ezjsonm.value list));

     

       360
       360
       -
           ("papers", add_embedding_field_to_schema Paper.typesense_schema config ["title"; "abstract"; "authors"], (List.map (paper_to_document entries) papers : Ezjsonm.value list));

     

       361
       361
       -
           ("videos", add_embedding_field_to_schema Video.typesense_schema config ["title"; "description"], (List.map (video_to_document entries) videos : Ezjsonm.value list));

     

       362
       362
       -
           ("projects", add_embedding_field_to_schema Project.typesense_schema config ["title"; "description"; "tags"], (List.map (project_to_document entries) projects : Ezjsonm.value list));

     

       363
       363
       -
           ("notes", add_embedding_field_to_schema Note.typesense_schema config ["title"; "content"; "tags"], (List.map (note_to_document entries) notes : Ezjsonm.value list));

     

       364
       364
       -
           ("ideas", add_embedding_field_to_schema Idea.typesense_schema config ["title"; "description"; "tags"], (List.map (idea_to_document entries) ideas : Ezjsonm.value list));

     

       365
       365
       -
         ] in

     

       366
       366
       -
       

     

       367
       367
       -
         let upload_collection ((name, schema, documents) : string * Ezjsonm.value * Ezjsonm.value list) =

     

       368
       368
       -
           Printf.printf "Processing collection: %s\n%!" name;

     

       369
       369
       -
           let exists = collection_exists ~sw ~env config name in

     

       370
       370
       -
           (if exists then (

     

       371
       371
       -
             Printf.printf "Collection %s exists, deleting...\n%!" name;

     

       372
       372
       -
             let result = delete_collection ~sw ~env config name in

     

       373
       373
       -
             match result with

     

       374
       374
       -
             | Ok _ -> Printf.printf "Deleted collection %s\n%!" name

     

       375
       375
       -
             | Error err ->

     

       376
       376
       -
               let err_str = Fmt.str "%a" pp_error err in

     

       377
       377
       -
               Printf.printf "Failed to delete collection %s: %s\n%!" name err_str

     

       378
       378
       -
           ));

     

       379
       379
       -
           Printf.printf "Creating collection %s with %d documents\n%!" name (List.length documents);

     

       380
       380
       -
           let result = create_collection ~sw ~env config schema in

     

       381
       381
       -
           match result with

     

       382
       382
       -
           | Ok _ ->

     

       383
       383
       -
             Printf.printf "Created collection %s\n%!" name;

     

       384
       384
       -
             if documents = [] then

     

       385
       385
       -
               Printf.printf "No documents to upload for %s\n%!" name

     

       386
       386
       -
             else (

     

       387
       387
       -
               let result = upload_documents ~sw ~env config name documents in

     

       388
       388
       -
               match result with

     

       389
       389
       -
               | Ok response ->

     

       390
       390
       -
                 (* Count successes and failures *)

     

       391
       391
       -
                 let lines = String.split_on_char '\n' response in

     

       392
       392
       -
                 let successes = List.fold_left (fun acc line ->

     

       393
       393
       -
                   if String.contains line ':' && Str.string_match (Str.regexp ".*success.*true.*") line 0 then acc + 1 else acc) 0 lines in

     

       394
       394
       -
                 let failures = List.fold_left (fun acc line ->

     

       395
       395
       -
                   if String.contains line ':' && Str.string_match (Str.regexp ".*success.*false.*") line 0 then acc + 1 else acc) 0 lines in

     

       396
       396
       -
                 Printf.printf "Upload results for %s: %d successful, %d failed out of %d total\n%!"

     

       397
       397
       -
                   name successes failures (List.length documents);

     

       398
       398
       -
                 if failures > 0 then (

     

       399
       399
       -
                   Printf.printf "Failed documents in %s:\n%!" name;

     

       400
       400
       -
                   let failed_lines = List.filter (fun line -> Str.string_match (Str.regexp ".*success.*false.*") line 0) lines in

     

       401
       401
       -
                   List.iter (fun line -> Printf.printf "%s\n%!" line) failed_lines

     

       402
       402
       -
                 )

     

       403
       403
       -
               | Error err ->

     

       404
       404
       -
                 let err_str = Fmt.str "%a" pp_error err in

     

       405
       405
       -
                 Printf.printf "Failed to upload documents to %s: %s\n%!" name err_str

     

       406
       406
       -
             )

     

       407
       407
       -
           | Error err ->

     

       408
       408
       -
             let err_str = Fmt.str "%a" pp_error err in

     

       409
       409
       -
             Printf.printf "Failed to create collection %s: %s\n%!" name err_str

     

       410
       410
       -
         in

     

       411
       411
       -
       

     

       412
       412
       -
         List.iter upload_collection collections

     

       413
       413
       -
       

     

       414
       414
       -
       (** Re-export search types from Typesense_client *)

     

       415
       415
       -
       type search_result = Typesense_client.search_result = {

     

       416
       416
       -
         id: string;

     

       417
       417
       -
         title: string;

     

       418
       418
       -
         content: string;

     

       419
       419
       -
         score: float;

     

       420
       420
       -
         collection: string;

     

       421
       421
       -
         highlights: (string * string list) list;

     

       422
       422
       -
         document: Ezjsonm.value;

     

       423
       423
       -
       }

     

       424
       424
       -
       

     

       425
       425
       -
       type search_response = Typesense_client.search_response = {

     

       426
       426
       -
         hits: search_result list;

     

       427
       427
       -
         total: int;

     

       428
       428
       -
         query_time: float;

     

       429
       429
       -
       }

     

       430
       430
       -
       

     

       431
       431
       -
       (** Convert bushel config to client config *)

     

       432
       432
       -
       let to_client_config (config : config) =

     

       433
       433
       -
         Typesense_client.{ endpoint = config.endpoint; api_key = config.api_key }

     

       434
       434
       -
       

     

       435
       435
       -
       (** Search a single collection *)

     

       436
       436
       -
       let search_collection ~sw ~env (config : config) collection_name query ?(limit=10) ?(offset=0) () =

     

       437
       437
       -
         let client_config = to_client_config config in

     

       438
       438
       -
         let requests_session = Requests.create ~sw env in

     

       439
       439
       -
         let client = Typesense_client.create ~requests_session ~config:client_config in

     

       440
       440
       -
         let result = Typesense_client.search_collection client collection_name query ~limit ~offset () in

     

       441
       441
       -
         match result with

     

       442
       442
       -
         | Ok response -> Ok response

     

       443
       443
       -
         | Error (Typesense_client.Http_error (code, msg)) -> Error (Http_error (code, msg))

     

       444
       444
       -
         | Error (Typesense_client.Json_error msg) -> Error (Json_error msg)

     

       445
       445
       -
         | Error (Typesense_client.Connection_error msg) -> Error (Connection_error msg)

     

       446
       446
       -
       

     

       447
       447
       -
       (** Search across all collections - use client multisearch *)

     

       448
       448
       -
       let search_all ~sw ~env (config : config) query ?(limit=10) ?(offset=0) () =

     

       449
       449
       -
         let client_config = to_client_config config in

     

       450
       450
       -
         let requests_session = Requests.create ~sw env in

     

       451
       451
       -
         let client = Typesense_client.create ~requests_session ~config:client_config in

     

       452
       452
       -
         let result = Typesense_client.multisearch client query ~limit:50 () in

     

       453
       453
       -
         match result with

     

       454
       454
       -
         | Ok multisearch_resp ->

     

       455
       455
       -
           let combined_response = Typesense_client.combine_multisearch_results multisearch_resp ~limit ~offset () in

     

       456
       456
       -
           Ok combined_response

     

       457
       457
       -
         | Error (Typesense_client.Http_error (code, msg)) -> Error (Http_error (code, msg))

     

       458
       458
       -
         | Error (Typesense_client.Json_error msg) -> Error (Json_error msg)

     

       459
       459
       -
         | Error (Typesense_client.Connection_error msg) -> Error (Connection_error msg)

     

       460
       460
       -
       

     

       461
       461
       -
       (** List all collections *)

     

       462
       462
       -
       let list_collections ~sw ~env (config : config) =

     

       463
       463
       -
         let client_config = to_client_config config in

     

       464
       464
       -
         let requests_session = Requests.create ~sw env in

     

       465
       465
       -
         let client = Typesense_client.create ~requests_session ~config:client_config in

     

       466
       466
       -
         let result = Typesense_client.list_collections client in

     

       467
       467
       -
         match result with

     

       468
       468
       -
         | Ok collections -> Ok collections

     

       469
       469
       -
         | Error (Typesense_client.Http_error (code, msg)) -> Error (Http_error (code, msg))

     

       470
       470
       -
         | Error (Typesense_client.Json_error msg) -> Error (Json_error msg)

     

       471
       471
       -
         | Error (Typesense_client.Connection_error msg) -> Error (Connection_error msg)

     

       472
       472
       -
       

     

       473
       473
       -
       (** Re-export multisearch types from Typesense_client *)

     

       474
       474
       -
       type multisearch_response = Typesense_client.multisearch_response = {

     

       475
       475
       -
         results: search_response list;

     

       476
       476
       -
       }

     

       477
       477
       -
       

     

       478
       478
       -
       (** Perform multisearch across all collections *)

     

       479
       479
       -
       let multisearch ~sw ~env (config : config) query ?(limit=10) () =

     

       480
       480
       -
         let client_config = to_client_config config in

     

       481
       481
       -
         let requests_session = Requests.create ~sw env in

     

       482
       482
       -
         let client = Typesense_client.create ~requests_session ~config:client_config in

     

       483
       483
       -
         let result = Typesense_client.multisearch client query ~limit () in

     

       484
       484
       -
         match result with

     

       485
       485
       -
         | Ok multisearch_resp -> Ok multisearch_resp

     

       486
       486
       -
         | Error (Typesense_client.Http_error (code, msg)) -> Error (Http_error (code, msg))

     

       487
       487
       -
         | Error (Typesense_client.Json_error msg) -> Error (Json_error msg)

     

       488
       488
       -
         | Error (Typesense_client.Connection_error msg) -> Error (Connection_error msg)

     

       489
       489
       -
       

     

       490
       490
       -
       (** Combine multisearch results into single result set *)

     

       491
       491
       -
       let combine_multisearch_results (multisearch_resp : multisearch_response) ?(limit=10) ?(offset=0) () =

     

       492
       492
       -
         Typesense_client.combine_multisearch_results multisearch_resp ~limit ~offset ()

     

       493
       493
       -
       

     

       494
       494
       -
       (** Load configuration from files *)

     

       495
       495
       -
       let load_config_from_files () =

     

       496
       496
       -
         let read_file_if_exists filename =

     

       497
       497
       -
           if Sys.file_exists filename then

     

       498
       498
       -
             let ic = open_in filename in

     

       499
       499
       -
             let content = really_input_string ic (in_channel_length ic) in

     

       500
       500
       -
             close_in ic;

     

       501
       501
       -
             Some (String.trim content)

     

       502
       502
       -
           else None

     

       503
       503
       -
         in

     

       504
       504
       -
       

     

       505
       505
       -
         let endpoint = match read_file_if_exists ".typesense-url" with

     

       506
       506
       -
           | Some url -> url

     

       507
       507
       -
           | None -> "http://localhost:8108"

     

       508
       508
       -
         in

     

       509
       509
       -
       

     

       510
       510
       -
         let api_key = match read_file_if_exists ".typesense-key" with

     

       511
       511
       -
           | Some key -> key

     

       512
       512
       -
           | None ->

     

       513
       513
       -
             try Sys.getenv "TYPESENSE_API_KEY"

     

       514
       514
       -
             with Not_found -> ""

     

       515
       515
       -
         in

     

       516
       516
       -
       

     

       517
       517
       -
         let openai_key = match read_file_if_exists ".openrouter-api" with

     

       518
       518
       -
           | Some key -> key

     

       519
       519
       -
           | None ->

     

       520
       520
       -
             try Sys.getenv "OPENAI_API_KEY"

     

       521
       521
       -
             with Not_found -> ""

     

       522
       522
       -
         in

     

       523
       523
       -
       

     

       524
       524
       -
         { endpoint; api_key; openai_key }

     

       525
       525
       -
       

     

       526
       526
       -
       (** Re-export pretty printer from Typesense_client *)

     

       527
       527
       -
       let pp_search_result_oneline = Typesense_client.pp_search_result_oneline

-168

stack/bushel/lib/typesense.mli

···

       1
       1
       -
       (** Typesense API client for Bushel

     

       2
       2
       -
       

     

       3
       3
       -
           This module provides an OCaml client for the Typesense search engine API.

     

       4
       4
       -
           It handles collection management and document indexing for all Bushel object

     

       5
       5
       -
           types including contacts, papers, projects, news, videos, notes, and ideas.

     

       6
       6
       -
       

     

       7
       7
       -
           Example usage:

     

       8
       8
       -
           {[

     

       9
       9
       -
             let config = { endpoint = "https://search.example.com"; api_key = "xyz123"; openai_key = "sk-..." } in

     

       10
       10
       -
             Eio_main.run (fun env ->

     

       11
       11
       -
               Eio.Switch.run (fun sw ->

     

       12
       12
       -
                 Typesense.upload_all ~sw ~env config entries))

     

       13
       13
       -
           ]}

     

       14
       14
       -
       *)

     

       15
       15
       -
       

     

       16
       16
       -
       (** Configuration for connecting to a Typesense server *)

     

       17
       17
       -
       type config = {

     

       18
       18
       -
         endpoint : string;    (** Typesense server URL (e.g., "https://search.example.com") *)

     

       19
       19
       -
         api_key : string;     (** API key for authentication *)

     

       20
       20
       -
         openai_key : string;  (** OpenAI API key for embeddings *)

     

       21
       21
       -
       }

     

       22
       22
       -
       

     

       23
       23
       -
       (** Possible errors that can occur during Typesense operations *)

     

       24
       24
       -
       type error =

     

       25
       25
       -
         | Http_error of int * string        (** HTTP error with status code and message *)

     

       26
       26
       -
         | Json_error of string              (** JSON parsing or encoding error *)

     

       27
       27
       -
         | Connection_error of string        (** Network connection error *)

     

       28
       28
       -
       

     

       29
       29
       -
       (** Pretty-printer for error types *)

     

       30
       30
       -
       val pp_error : Format.formatter -> error -> unit

     

       31
       31
       -
       

     

       32
       32
       -
       (** Create a collection with the given schema.

     

       33
       33
       -
           The schema should follow Typesense's collection schema format. *)

     

       34
       34
       -
       val create_collection :

     

       35
       35
       -
         sw:Eio.Switch.t ->

     

       36
       36
       -
         env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->

     

       37
       37
       -
         config ->

     

       38
       38
       -
         Ezjsonm.value ->

     

       39
       39
       -
         (string, error) result

     

       40
       40
       -
       

     

       41
       41
       -
       (** Check if a collection exists by name.

     

       42
       42
       -
           Returns true if the collection exists, false otherwise. *)

     

       43
       43
       -
       val collection_exists :

     

       44
       44
       -
         sw:Eio.Switch.t ->

     

       45
       45
       -
         env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->

     

       46
       46
       -
         config ->

     

       47
       47
       -
         string ->

     

       48
       48
       -
         bool

     

       49
       49
       -
       

     

       50
       50
       -
       (** Delete a collection by name. *)

     

       51
       51
       -
       val delete_collection :

     

       52
       52
       -
         sw:Eio.Switch.t ->

     

       53
       53
       -
         env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->

     

       54
       54
       -
         config ->

     

       55
       55
       -
         string ->

     

       56
       56
       -
         (string, error) result

     

       57
       57
       -
       

     

       58
       58
       -
       (** Upload documents to a collection in batch using JSONL format.

     

       59
       59
       -
           More efficient than uploading documents one by one. *)

     

       60
       60
       -
       val upload_documents :

     

       61
       61
       -
         sw:Eio.Switch.t ->

     

       62
       62
       -
         env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->

     

       63
       63
       -
         config ->

     

       64
       64
       -
         string ->

     

       65
       65
       -
         Ezjsonm.value list ->

     

       66
       66
       -
         (string, error) result

     

       67
       67
       -
       

     

       68
       68
       -
       (** Upload all bushel objects to Typesense.

     

       69
       69
       -
           This function will:

     

       70
       70
       -
           - Extract all bushel data types from the Entry.t

     

       71
       71
       -
           - Create or recreate collections for each type

     

       72
       72
       -
           - Upload all documents in batches

     

       73
       73
       -
           - Report progress to stdout *)

     

       74
       74
       -
       val upload_all :

     

       75
       75
       -
         sw:Eio.Switch.t ->

     

       76
       76
       -
         env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->

     

       77
       77
       -
         config ->

     

       78
       78
       -
         Entry.t ->

     

       79
       79
       -
         unit

     

       80
       80
       -
       

     

       81
       81
       -
       (** Search result structure containing document information and relevance score *)

     

       82
       82
       -
       type search_result = {

     

       83
       83
       -
         id: string;                               (** Document ID *)

     

       84
       84
       -
         title: string;                            (** Document title *)

     

       85
       85
       -
         content: string;                          (** Document content/description *)

     

       86
       86
       -
         score: float;                             (** Relevance score *)

     

       87
       87
       -
         collection: string;                       (** Collection name *)

     

       88
       88
       -
         highlights: (string * string list) list; (** Highlighted search terms by field *)

     

       89
       89
       -
         document: Ezjsonm.value;                  (** Raw document for flexible field access *)

     

       90
       90
       -
       }

     

       91
       91
       -
       

     

       92
       92
       -
       (** Search response containing results and metadata *)

     

       93
       93
       -
       type search_response = {

     

       94
       94
       -
         hits: search_result list;                 (** List of matching documents *)

     

       95
       95
       -
         total: int;                               (** Total number of matches *)

     

       96
       96
       -
         query_time: float;                        (** Query execution time in milliseconds *)

     

       97
       97
       -
       }

     

       98
       98
       -
       

     

       99
       99
       -
       (** Search a specific collection. *)

     

       100
       100
       -
       val search_collection :

     

       101
       101
       -
         sw:Eio.Switch.t ->

     

       102
       102
       -
         env:< clock: float Eio.Time.clock_ty Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; net: [`Generic | `Unix] Eio.Net.ty Eio.Resource.t; .. > ->

     

       103
       103
       -
         config ->

     

       104
       104
       -
         string ->

     

       105
       105
       -
         string ->

     

       106
       106
       -
         ?limit:int ->

     

       107
       107
       -
         ?offset:int ->

     

       108
       108
       -
         unit ->

     

       109
       109
       -
         (search_response, error) result

     

       110
       110
       -
       

     

       111
       111
       -
       (** Search across all bushel collections.

     

       112
       112
       -
           Results are sorted by relevance score and paginated. *)

     

       113
       113
       -
       val search_all :

     

       114
       114
       -
         sw:Eio.Switch.t ->

     

       115
       115
       -
         env:< clock: float Eio.Time.clock_ty Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; net: [`Generic | `Unix] Eio.Net.ty Eio.Resource.t; .. > ->

     

       116
       116
       -
         config ->

     

       117
       117
       -
         string ->

     

       118
       118
       -
         ?limit:int ->

     

       119
       119
       -
         ?offset:int ->

     

       120
       120
       -
         unit ->

     

       121
       121
       -
         (search_response, error) result

     

       122
       122
       -
       

     

       123
       123
       -
       (** Multisearch response containing results from multiple collections *)

     

       124
       124
       -
       type multisearch_response = {

     

       125
       125
       -
         results: search_response list;                (** Results from each collection *)

     

       126
       126
       -
       }

     

       127
       127
       -
       

     

       128
       128
       -
       (** Perform multisearch across all collections using Typesense's multi_search endpoint.

     

       129
       129
       -
           More efficient than individual searches as it's done in a single request. *)

     

       130
       130
       -
       val multisearch :

     

       131
       131
       -
         sw:Eio.Switch.t ->

     

       132
       132
       -
         env:< clock: float Eio.Time.clock_ty Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; net: [`Generic | `Unix] Eio.Net.ty Eio.Resource.t; .. > ->

     

       133
       133
       -
         config ->

     

       134
       134
       -
         string ->

     

       135
       135
       -
         ?limit:int ->

     

       136
       136
       -
         unit ->

     

       137
       137
       -
         (multisearch_response, error) result

     

       138
       138
       -
       

     

       139
       139
       -
       (** Combine multisearch results into a single result set.

     

       140
       140
       -
           Results are sorted by relevance score and paginated. *)

     

       141
       141
       -
       val combine_multisearch_results : multisearch_response -> ?limit:int -> ?offset:int -> unit -> search_response

     

       142
       142
       -
       

     

       143
       143
       -
       (** List all collections with document counts.

     

       144
       144
       -
           Returns a list of (collection_name, document_count) pairs. *)

     

       145
       145
       -
       val list_collections :

     

       146
       146
       -
         sw:Eio.Switch.t ->

     

       147
       147
       -
         env:< clock: float Eio.Time.clock_ty Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; net: [`Generic | `Unix] Eio.Net.ty Eio.Resource.t; .. > ->

     

       148
       148
       -
         config ->

     

       149
       149
       -
         ((string * int) list, error) result

     

       150
       150
       -
       

     

       151
       151
       -
       (** Load configuration from .typesense-url and .typesense-api files.

     

       152
       152
       -
           Falls back to environment variables and defaults.

     

       153
       153
       -
           TODO:claude *)

     

       154
       154
       -
       val load_config_from_files : unit -> config

     

       155
       155
       -
       

     

       156
       156
       -
       (** Pretty-print a search result in a one-line format with relevant information.

     

       157
       157
       -
           Shows different fields based on the collection type (papers, videos, etc.).

     

       158
       158
       -
           TODO:claude *)

     

       159
       159
       -
       val pp_search_result_oneline : search_result -> string

     

       160
       160
       -
       

     

       161
       161
       -
       (** Convert Bushel objects to Typesense documents *)

     

       162
       162
       -
       

     

       163
       163
       -
       val contact_to_document : Contact.t -> Ezjsonm.value

     

       164
       164
       -
       val paper_to_document : Entry.t -> Paper.t -> Ezjsonm.value

     

       165
       165
       -
       val project_to_document : Entry.t -> Project.t -> Ezjsonm.value

     

       166
       166
       -
       val video_to_document : Entry.t -> Video.t -> Ezjsonm.value

     

       167
       167
       -
       val note_to_document : Entry.t -> Note.t -> Ezjsonm.value

     

       168
       168
       -
       val idea_to_document : Entry.t -> Idea.t -> Ezjsonm.value

-80

stack/bushel/lib/util.ml

···

       1
       1
       -
       let first_hunk s =

     

       2
       2
       -
         let lines = String.split_on_char '\n' s in

     

       3
       3
       -
         let rec aux acc = function

     

       4
       4
       -
           | [] -> String.concat "\n" (List.rev acc)

     

       5
       5
       -
           | "" :: "" :: _ -> String.concat "\n" (List.rev acc)

     

       6
       6
       -
           | line :: rest -> aux (line :: acc) rest

     

       7
       7
       -
         in

     

       8
       8
       -
         aux [] lines

     

       9
       9
       -
       ;;

     

       10
       10
       -
       

     

       11
       11
       -
       let first_and_last_hunks s =

     

       12
       12
       -
         let lines = String.split_on_char '\n' s in

     

       13
       13
       -
         let rec aux acc = function

     

       14
       14
       -
           | [] -> String.concat "\n" (List.rev acc), ""

     

       15
       15
       -
           | "" :: "" :: rest ->

     

       16
       16
       -
             String.concat "\n" (List.rev acc), String.concat "\n" (List.rev rest)

     

       17
       17
       -
           | line :: rest -> aux (line :: acc) rest

     

       18
       18
       -
         in

     

       19
       19
       -
         aux [] lines

     

       20
       20
       -
       ;;

     

       21
       21
       -
       

     

       22
       22
       -
       (* Find all footnote definition lines in text *)

     

       23
       23
       -
       let find_footnote_lines s =

     

       24
       24
       -
         let lines = String.split_on_char '\n' s in

     

       25
       25
       -
         let is_footnote_def line =

     

       26
       26
       -
           String.length line > 3 &&

     

       27
       27
       -
           line.[0] = '[' &&

     

       28
       28
       -
           line.[1] = '^' &&

     

       29
       29
       -
           String.contains line ':' &&

     

       30
       30
       -
           let colon_pos = String.index line ':' in

     

       31
       31
       -
           colon_pos > 2 && line.[colon_pos - 1] = ']'

     

       32
       32
       -
         in

     

       33
       33
       -
         let is_continuation line =

     

       34
       34
       -
           String.length line > 0 && (line.[0] = ' ' || line.[0] = '\t')

     

       35
       35
       -
         in

     

       36
       36
       -
         let rec collect_footnotes acc in_footnote = function

     

       37
       37
       -
           | [] -> List.rev acc

     

       38
       38
       -
           | line :: rest ->

     

       39
       39
       -
             if is_footnote_def line then

     

       40
       40
       -
               collect_footnotes (line :: acc) true rest

     

       41
       41
       -
             else if in_footnote && is_continuation line then

     

       42
       42
       -
               collect_footnotes (line :: acc) true rest

     

       43
       43
       -
             else

     

       44
       44
       -
               collect_footnotes acc false rest

     

       45
       45
       -
         in

     

       46
       46
       -
         collect_footnotes [] false lines

     

       47
       47
       -
       ;;

     

       48
       48
       -
       

     

       49
       49
       -
       (* Augment first hunk with footnote definitions from last hunk *)

     

       50
       50
       -
       let first_hunk_with_footnotes s =

     

       51
       51
       -
         let first, last = first_and_last_hunks s in

     

       52
       52
       -
         let footnote_lines = find_footnote_lines last in

     

       53
       53
       -
         if footnote_lines = [] then first

     

       54
       54
       -
         else first ^ "\n\n" ^ String.concat "\n" footnote_lines

     

       55
       55
       -
       ;;

     

       56
       56
       -
       

     

       57
       57
       -
       let count_words (text : string) : int =

     

       58
       58
       -
         let len = String.length text in

     

       59
       59
       -
         let rec count_words_helper (index : int) (in_word : bool) (count : int) : int =

     

       60
       60
       -
           if index >= len

     

       61
       61
       -
           then if in_word then count + 1 else count

     

       62
       62
       -
           else (

     

       63
       63
       -
             let char = String.get text index in

     

       64
       64
       -
             let is_whitespace =

     

       65
       65
       -
               Char.equal char ' '

     

       66
       66
       -
               || Char.equal char '\t'

     

       67
       67
       -
               || Char.equal char '\n'

     

       68
       68
       -
               || Char.equal char '\r'

     

       69
       69
       -
             in

     

       70
       70
       -
             if is_whitespace

     

       71
       71
       -
             then

     

       72
       72
       -
               if in_word

     

       73
       73
       -
               then count_words_helper (index + 1) false (count + 1)

     

       74
       74
       -
               else count_words_helper (index + 1) false count

     

       75
       75
       -
             else count_words_helper (index + 1) true count)

     

       76
       76
       -
         in

     

       77
       77
       -
         count_words_helper 0 false 0

     

       78
       78
       -
       ;;

     

       79
       79
       -
       

     

       80
       80
       -
       let read_file file = In_channel.(with_open_bin file input_all)

-166

stack/bushel/lib/video.ml

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { slug : string

     

       3
       3
       -
         ; title : string

     

       4
       4
       -
         ; published_date : Ptime.t

     

       5
       5
       -
         ; uuid : string

     

       6
       6
       -
         ; description : string

     

       7
       7
       -
         ; url : string

     

       8
       8
       -
         ; talk : bool

     

       9
       9
       -
         ; paper : string option

     

       10
       10
       -
         ; project : string option

     

       11
       11
       -
         ; tags : string list

     

       12
       12
       -
         }

     

       13
       13
       -
       

     

       14
       14
       -
       type ts = t list

     

       15
       15
       -
       

     

       16
       16
       -
       let get_shadow fs k =

     

       17
       17
       -
         match List.assoc_opt k fs with

     

       18
       18
       -
         | Some v -> Some v

     

       19
       19
       -
         | None -> List.assoc_opt ("_" ^ k) fs

     

       20
       20
       -
       ;;

     

       21
       21
       -
       

     

       22
       22
       -
       let get_shadow_string fs k =

     

       23
       23
       -
         match get_shadow fs k with

     

       24
       24
       -
         | Some (`String v) -> v

     

       25
       25
       -
         | _ -> failwith "invalid yaml"

     

       26
       26
       -
       ;;

     

       27
       27
       -
       

     

       28
       28
       -
       let get_shadow_bool fs k =

     

       29
       29
       -
         match get_shadow fs k with

     

       30
       30
       -
         | Some (`Bool v) -> v

     

       31
       31
       -
         | _ -> failwith "invalid yaml"

     

       32
       32
       -
       ;;

     

       33
       33
       -
       

     

       34
       34
       -
       let compare a b = Ptime.compare b.published_date a.published_date

     

       35
       35
       -
       let url v = v.url

     

       36
       36
       -
       let body { description; _ } = description

     

       37
       37
       -
       let title { title; _ } = title

     

       38
       38
       -
       let uuid { uuid; _ } = uuid

     

       39
       39
       -
       let paper { paper; _ } = paper

     

       40
       40
       -
       let project { project; _ } = project

     

       41
       41
       -
       let slug { slug; _ } = slug

     

       42
       42
       -
       let date { published_date; _ } = published_date |> Ptime.to_date

     

       43
       43
       -
       let datetime { published_date; _ } = published_date

     

       44
       44
       -
       let talk { talk; _ } = talk

     

       45
       45
       -
       

     

       46
       46
       -
       let t_of_yaml ~description = function

     

       47
       47
       -
         | `O fields ->

     

       48
       48
       -
           let slug = get_shadow_string fields "uuid" in

     

       49
       49
       -
           let title = get_shadow_string fields "title" in

     

       50
       50
       -
           let published_date =

     

       51
       51
       -
             get_shadow_string fields "published_date"

     

       52
       52
       -
             |> Ptime.of_rfc3339

     

       53
       53
       -
             |> Result.get_ok

     

       54
       54
       -
             |> fun (a, _, _) -> a

     

       55
       55
       -
           in

     

       56
       56
       -
           let uuid = get_shadow_string fields "uuid" in

     

       57
       57
       -
           let url = get_shadow_string fields "url" in

     

       58
       58
       -
           let talk =

     

       59
       59
       -
             try get_shadow_bool fields "talk" with

     

       60
       60
       -
             | _ -> false

     

       61
       61
       -
           in

     

       62
       62
       -
           let tags =

     

       63
       63
       -
             match List.assoc_opt "tags" fields with

     

       64
       64
       -
             | Some l -> Ezjsonm.get_list Ezjsonm.get_string l

     

       65
       65
       -
             | _ -> []

     

       66
       66
       -
           in

     

       67
       67
       -
           let paper =

     

       68
       68
       -
             try Some (get_shadow_string fields "paper") with

     

       69
       69
       -
             | _ -> None

     

       70
       70
       -
           in

     

       71
       71
       -
           let project =

     

       72
       72
       -
             try Some (get_shadow_string fields "project") with

     

       73
       73
       -
             | _ -> None

     

       74
       74
       -
           in

     

       75
       75
       -
           { slug; title; tags; published_date; uuid; description; talk; paper; project; url }

     

       76
       76
       -
         | _ -> failwith "invalid yaml"

     

       77
       77
       -
       ;;

     

       78
       78
       -
       

     

       79
       79
       -
       let to_yaml t =

     

       80
       80
       -
         `O [

     

       81
       81
       -
           ("title", `String t.title);

     

       82
       82
       -
           ("description", `String t.description);

     

       83
       83
       -
           ("url", `String t.url);

     

       84
       84
       -
           ("uuid", `String t.uuid);

     

       85
       85
       -
           ("slug", `String t.slug);

     

       86
       86
       -
           ("published_date", `String (Ptime.to_rfc3339 t.published_date));

     

       87
       87
       -
           ("talk", `Bool t.talk);

     

       88
       88
       -
           ("tags", `A (List.map (fun t -> `String t) t.tags));

     

       89
       89
       -
           ("paper", match t.paper with None -> `Null | Some p -> `String p);

     

       90
       90
       -
           ("project", match t.project with None -> `Null | Some p -> `String p)

     

       91
       91
       -
         ]

     

       92
       92
       -
       

     

       93
       93
       -
       let to_file output_dir t =

     

       94
       94
       -
         let file_path = Fpath.v (Filename.concat output_dir (t.uuid ^ ".md")) in

     

       95
       95
       -
         let yaml = to_yaml t in

     

       96
       96
       -
         let yaml_str = Yaml.to_string_exn yaml in

     

       97
       97
       -
         let content = "---\n" ^ yaml_str ^ "---\n" in

     

       98
       98
       -
         Bos.OS.File.write file_path content

     

       99
       99
       -
       ;;

     

       100
       100
       -
       

     

       101
       101
       -
       let of_md fname =

     

       102
       102
       -
         (* TODO fix Jekyll_post to not error on no date *)

     

       103
       103
       -
         let fname' = "2000-01-01-" ^ Filename.basename fname in

     

       104
       104
       -
         match Jekyll_post.of_string ~fname:fname' (Util.read_file fname) with

     

       105
       105
       -
         | Error (`Msg m) -> failwith ("paper_of_md: " ^ m)

     

       106
       106
       -
         | Ok jp ->

     

       107
       107
       -
           let fields = jp.Jekyll_post.fields |> Jekyll_format.fields_to_yaml in

     

       108
       108
       -
           let { Jekyll_post.body; _ } = jp in

     

       109
       109
       -
           t_of_yaml ~description:body fields

     

       110
       110
       -
       ;;

     

       111
       111
       -
       

     

       112
       112
       -
       (* TODO:claude *)

     

       113
       113
       -
       let typesense_schema =

     

       114
       114
       -
         let open Ezjsonm in

     

       115
       115
       -
         dict [

     

       116
       116
       -
           ("name", string "videos");

     

       117
       117
       -
           ("fields", list (fun d -> dict d) [

     

       118
       118
       -
             [("name", string "id"); ("type", string "string")];

     

       119
       119
       -
             [("name", string "title"); ("type", string "string")];

     

       120
       120
       -
             [("name", string "description"); ("type", string "string")];

     

       121
       121
       -
             [("name", string "published_date"); ("type", string "string")];

     

       122
       122
       -
             [("name", string "date"); ("type", string "string")];

     

       123
       123
       -
             [("name", string "date_timestamp"); ("type", string "int64")];

     

       124
       124
       -
             [("name", string "tags"); ("type", string "string[]"); ("facet", bool true)];

     

       125
       125
       -
             [("name", string "url"); ("type", string "string")];

     

       126
       126
       -
             [("name", string "uuid"); ("type", string "string")];

     

       127
       127
       -
             [("name", string "is_talk"); ("type", string "bool")];

     

       128
       128
       -
             [("name", string "paper"); ("type", string "string[]"); ("optional", bool true)];

     

       129
       129
       -
             [("name", string "project"); ("type", string "string[]"); ("optional", bool true)];

     

       130
       130
       -
             [("name", string "video_url"); ("type", string "string"); ("optional", bool true)];

     

       131
       131
       -
             [("name", string "embed_url"); ("type", string "string"); ("optional", bool true)];

     

       132
       132
       -
             [("name", string "duration"); ("type", string "int32"); ("optional", bool true)];

     

       133
       133
       -
             [("name", string "channel"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       134
       134
       -
             [("name", string "platform"); ("type", string "string"); ("facet", bool true); ("optional", bool true)];

     

       135
       135
       -
             [("name", string "views"); ("type", string "int32"); ("optional", bool true)];

     

       136
       136
       -
             [("name", string "related_papers"); ("type", string "string[]"); ("optional", bool true)];

     

       137
       137
       -
             [("name", string "related_talks"); ("type", string "string[]"); ("optional", bool true)];

     

       138
       138
       -
           ]);

     

       139
       139
       -
           ("default_sorting_field", string "date_timestamp");

     

       140
       140
       -
         ]

     

       141
       141
       -
       

     

       142
       142
       -
       (** TODO:claude Pretty-print a video with ANSI formatting *)

     

       143
       143
       -
       let pp ppf v =

     

       144
       144
       -
         let open Fmt in

     

       145
       145
       -
         pf ppf "@[<v>";

     

       146
       146
       -
         pf ppf "%a: %a@," (styled `Bold string) "Type" (styled `Cyan string) "Video";

     

       147
       147
       -
         pf ppf "%a: %a@," (styled `Bold string) "Slug" string (slug v);

     

       148
       148
       -
         pf ppf "%a: %a@," (styled `Bold string) "UUID" string (uuid v);

     

       149
       149
       -
         pf ppf "%a: %a@," (styled `Bold string) "Title" string (title v);

     

       150
       150
       -
         let (year, month, day) = date v in

     

       151
       151
       -
         pf ppf "%a: %04d-%02d-%02d@," (styled `Bold string) "Date" year month day;

     

       152
       152
       -
         pf ppf "%a: %a@," (styled `Bold string) "URL" string (url v);

     

       153
       153
       -
         pf ppf "%a: %b@," (styled `Bold string) "Talk" (talk v);

     

       154
       154
       -
         (match paper v with

     

       155
       155
       -
          | Some p -> pf ppf "%a: %a@," (styled `Bold string) "Paper" string p

     

       156
       156
       -
          | None -> ());

     

       157
       157
       -
         (match project v with

     

       158
       158
       -
          | Some p -> pf ppf "%a: %a@," (styled `Bold string) "Project" string p

     

       159
       159
       -
          | None -> ());

     

       160
       160
       -
         let t = v.tags in

     

       161
       161
       -
         if t <> [] then

     

       162
       162
       -
           pf ppf "%a: @[<h>%a@]@," (styled `Bold string) "Tags" (list ~sep:comma string) t;

     

       163
       163
       -
         pf ppf "@,";

     

       164
       164
       -
         pf ppf "%a:@," (styled `Bold string) "Description";

     

       165
       165
       -
         pf ppf "%a@," string v.description;

     

       166
       166
       -
         pf ppf "@]"

-32

stack/bushel/lib/video.mli

···

       1
       1
       -
       type t =

     

       2
       2
       -
         { slug : string

     

       3
       3
       -
         ; title : string

     

       4
       4
       -
         ; published_date : Ptime.t

     

       5
       5
       -
         ; uuid : string

     

       6
       6
       -
         ; description : string

     

       7
       7
       -
         ; url : string

     

       8
       8
       -
         ; talk : bool

     

       9
       9
       -
         ; paper : string option

     

       10
       10
       -
         ; project : string option

     

       11
       11
       -
         ; tags : string list

     

       12
       12
       -
         }

     

       13
       13
       -
       

     

       14
       14
       -
       type ts = t list

     

       15
       15
       -
       

     

       16
       16
       -
       val compare : t -> t -> int

     

       17
       17
       -
       val url : t -> string

     

       18
       18
       -
       val body : t -> string

     

       19
       19
       -
       val title : t -> string

     

       20
       20
       -
       val uuid : t -> string

     

       21
       21
       -
       val paper : t -> string option

     

       22
       22
       -
       val project : t -> string option

     

       23
       23
       -
       val slug : t -> string

     

       24
       24
       -
       val date : t -> Ptime.date

     

       25
       25
       -
       val datetime : t -> Ptime.t

     

       26
       26
       -
       val talk : t -> bool

     

       27
       27
       -
       val of_md : string -> t

     

       28
       28
       -
       val t_of_yaml : description:string -> Yaml.value -> t

     

       29
       29
       -
       val to_yaml : t -> Yaml.value

     

       30
       30
       -
       val to_file : string -> t -> (unit, [> `Msg of string]) result

     

       31
       31
       -
       val typesense_schema : Ezjsonm.value

     

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

+2 -1

stack/cacheio/cacheio.opam

···

       15
       15
        
         "dune" {>= "3.16"}

     

       16
       16
        
         "eio"

     

       17
       17
        
         "cmdliner" {>= "2.0.0"}

     

       18
       18
       -
         "yojson"

     

       18
       18
       +
         "jsont"

     

       19
       19
       +
         "bytesrw"

     

       19
       20
        
         "ptime"

     

       20
       21
        
         "logs"

     

       21
       22
        
         "fmt"

+2 -1

stack/cacheio/dune-project

···

       24
       24
        
         dune

     

       25
       25
        
         eio

     

       26
       26
        
         (cmdliner (>= 2.0.0))

     

       27
       27
       -
         yojson

     

       27
       27
       +
         jsont

     

       28
       28
       +
         bytesrw

     

       28
       29
        
         ptime

     

       29
       30
        
         logs

     

       30
       31
        
         fmt

+1 -1

stack/cacheio/lib/dune

···

       2
       2
        
        (public_name cacheio)

     

       3
       3
        
        (name cacheio)

     

       4
       4
        
        (modules cacheio flags entry stats range chunk)

     

       5
       5
       -
        (libraries eio eio_main digestif yojson ptime ptime.clock.os logs fmt xdge cstruct))

     

       5
       5
       +
        (libraries eio eio_main digestif jsont jsont.bytesrw ptime ptime.clock.os logs fmt xdge cstruct))

     

       6
       6
        
       

     

       7
       7
        
       (library

     

       8
       8
        
        (public_name cacheio.cmd)

+23 -1

stack/cacheio/lib/entry.ml

···

       45
       45
        
           (match t.ttl with

     

       46
       46
        
            | None -> "never"

     

       47
       47
        
            | Some exp -> Printf.sprintf "%.1f" exp)

     

       48
       48
       -
           Flags.pp t.flags
     

       48
       48
       +
           Flags.pp t.flags

     

       49
       49
       +
       

     

       50
       50
       +
       (* Jsont support *)

     

       51
       51
       +
       

     

       52
       52
       +
       (* Helper codec for int64 *)

     

       53
       53
       +
       let int64_jsont =

     

       54
       54
       +
         let kind = "Int64" in

     

       55
       55
       +
         let doc = "64-bit integer as number" in

     

       56
       56
       +
         let dec n = Int64.of_float n in

     

       57
       57
       +
         let enc i = Int64.to_float i in

     

       58
       58
       +
         Jsont.map ~kind ~doc ~dec ~enc Jsont.number

     

       59
       59
       +
       

     

       60
       60
       +
       let jsont =

     

       61
       61
       +
         let kind = "Entry" in

     

       62
       62
       +
         let doc = "A cache entry" in

     

       63
       63
       +
         let make key size mtime ttl flags = { key; size; mtime; ttl; flags } in

     

       64
       64
       +
         Jsont.Object.map ~kind ~doc make

     

       65
       65
       +
         |> Jsont.Object.mem "key" Jsont.string ~enc:key

     

       66
       66
       +
         |> Jsont.Object.mem "size" int64_jsont ~enc:size

     

       67
       67
       +
         |> Jsont.Object.mem "mtime" Jsont.number ~enc:mtime

     

       68
       68
       +
         |> Jsont.Object.opt_mem "ttl" Jsont.number ~enc:ttl

     

       69
       69
       +
         |> Jsont.Object.mem "flags" Flags.jsont ~enc:flags

     

       70
       70
       +
         |> Jsont.Object.finish

+6 -1

stack/cacheio/lib/entry.mli

···

       53
       53
        
       (** {1 Pretty Printing} *)

     

       54
       54
        
       

     

       55
       55
        
       (** Pretty printer for entries *)

     

       56
       56
       -
       val pp : Format.formatter -> t -> unit
     

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

     

       57
       57
       +
       

     

       58
       58
       +
       (** {1 JSON Support} *)

     

       59
       59
       +
       

     

       60
       60
       +
       (** Jsont codec for cache entries *)

     

       61
       61
       +
       val jsont : t Jsont.t

+31 -1

stack/cacheio/lib/flags.ml

···

       97
       97
        
                 | `Pinned -> "P"

     

       98
       98
        
                 | `Stale -> "S"

     

       99
       99
        
                 | `Temporary -> "T"

     

       100
       100
       -
                 | `Chunk -> "C") flags))
     

       100
       100
       +
                 | `Chunk -> "C") flags))

     

       101
       101
       +
       

     

       102
       102
       +
       (* Jsont support *)

     

       103
       103
       +
       

     

       104
       104
       +
       (* JSON codec for individual flags - using string representation *)

     

       105
       105
       +
       let flag_jsont =

     

       106
       106
       +
         let kind = "Flag" in

     

       107
       107
       +
         let doc = "A cache entry flag" in

     

       108
       108
       +
         let dec s =

     

       109
       109
       +
           match s with

     

       110
       110
       +
           | "pinned" -> `Pinned

     

       111
       111
       +
           | "stale" -> `Stale

     

       112
       112
       +
           | "temporary" -> `Temporary

     

       113
       113
       +
           | "chunk" -> `Chunk

     

       114
       114
       +
           | _ -> Jsont.Error.msg Jsont.Meta.none "Invalid flag value"

     

       115
       115
       +
         in

     

       116
       116
       +
         let enc = function

     

       117
       117
       +
           | `Pinned -> "pinned"

     

       118
       118
       +
           | `Stale -> "stale"

     

       119
       119
       +
           | `Temporary -> "temporary"

     

       120
       120
       +
           | `Chunk -> "chunk"

     

       121
       121
       +
         in

     

       122
       122
       +
         Jsont.map ~kind ~doc ~dec ~enc Jsont.string

     

       123
       123
       +
       

     

       124
       124
       +
       (* JSON codec for flag set *)

     

       125
       125
       +
       let jsont =

     

       126
       126
       +
         let kind = "Flags" in

     

       127
       127
       +
         let doc = "A set of cache entry flags" in

     

       128
       128
       +
         let dec lst = of_list lst in

     

       129
       129
       +
         let enc t = to_list t in

     

       130
       130
       +
         Jsont.map ~kind ~doc ~dec ~enc (Jsont.list flag_jsont)

+6 -1

stack/cacheio/lib/flags.mli

···

       94
       94
        
       val pp_flag : Format.formatter -> flag -> unit

     

       95
       95
        
       

     

       96
       96
        
       (** Pretty printer for flag sets *)

     

       97
       97
       -
       val pp : Format.formatter -> t -> unit
     

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

     

       98
       98
       +
       

     

       99
       99
       +
       (** {1 JSON Support} *)

     

       100
       100
       +
       

     

       101
       101
       +
       (** Jsont codec for flags *)

     

       102
       102
       +
       val jsont : t Jsont.t

+26 -1

stack/cacheio/lib/stats.ml

···

       48
       48
        
           t.expired_count

     

       49
       49
        
           t.pinned_count

     

       50
       50
        
           t.stale_count

     

       51
       51
       -
           t.temporary_count
     

       51
       51
       +
           t.temporary_count

     

       52
       52
       +
       

     

       53
       53
       +
       (* Jsont support *)

     

       54
       54
       +
       

     

       55
       55
       +
       (* Helper codec for int64 *)

     

       56
       56
       +
       let int64_jsont =

     

       57
       57
       +
         let kind = "Int64" in

     

       58
       58
       +
         let doc = "64-bit integer as number" in

     

       59
       59
       +
         let dec n = Int64.of_float n in

     

       60
       60
       +
         let enc i = Int64.to_float i in

     

       61
       61
       +
         Jsont.map ~kind ~doc ~dec ~enc Jsont.number

     

       62
       62
       +
       

     

       63
       63
       +
       let jsont =

     

       64
       64
       +
         let kind = "Stats" in

     

       65
       65
       +
         let doc = "Cache statistics" in

     

       66
       66
       +
         let make total_size entry_count expired_count pinned_count stale_count temporary_count =

     

       67
       67
       +
           { total_size; entry_count; expired_count; pinned_count; stale_count; temporary_count }

     

       68
       68
       +
         in

     

       69
       69
       +
         Jsont.Object.map ~kind ~doc make

     

       70
       70
       +
         |> Jsont.Object.mem "total_size" int64_jsont ~enc:total_size

     

       71
       71
       +
         |> Jsont.Object.mem "entry_count" Jsont.int ~enc:entry_count

     

       72
       72
       +
         |> Jsont.Object.mem "expired_count" Jsont.int ~enc:expired_count

     

       73
       73
       +
         |> Jsont.Object.mem "pinned_count" Jsont.int ~enc:pinned_count

     

       74
       74
       +
         |> Jsont.Object.mem "stale_count" Jsont.int ~enc:stale_count

     

       75
       75
       +
         |> Jsont.Object.mem "temporary_count" Jsont.int ~enc:temporary_count

     

       76
       76
       +
         |> Jsont.Object.finish

+6 -1

stack/cacheio/lib/stats.mli

···

       40
       40
        
       (** {1 Pretty Printing} *)

     

       41
       41
        
       

     

       42
       42
        
       (** Pretty printer for statistics *)

     

       43
       43
       -
       val pp : Format.formatter -> t -> unit
     

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

     

       44
       44
       +
       

     

       45
       45
       +
       (** {1 JSON Support} *)

     

       46
       46
       +
       

     

       47
       47
       +
       (** Jsont codec for cache statistics *)

     

       48
       48
       +
       val jsont : t Jsont.t

+1 -1

stack/immich/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (name immich)

     

       3
       3
        
        (public_name immich)

     

       4
       4
       -
        (libraries eio eio.core requests requests_json_api ezjsonm fmt ptime uri))

     

       4
       4
       +
        (libraries eio eio.core requests requests_json_api jsont jsont.bytesrw fmt ptime uri))

+2 -1

stack/immich/dune-project

···

       13
       13
        
         eio

     

       14
       14
        
         (eio_main (>= 1.0))

     

       15
       15
        
         requests

     

       16
       16
       -
         ezjsonm

     

       16
       16
       +
         jsont

     

       17
       17
       +
         bytesrw

     

       17
       18
        
         fmt

     

       18
       19
        
         ptime

     

       19
       20
        
         uri))

+46 -40

stack/immich/immich.ml

···

       4
       4
        
       

     

       5
       5
        
       (** {1 Types} *)

     

       6
       6
        
       

     

       7
       7
       -
       type 'net t_internal = {

     

       7
       7
       +
       type t = {

     

       8
       8
        
         base_url: string;

     

       9
       9
        
         api_key: string;

     

       10
       10
       -
         requests_session: (float Eio.Time.clock_ty Eio.Resource.t, 'net Eio.Net.ty Eio.Resource.t) Requests.t;

     

       10
       10
       +
         requests_session: Requests.t;

     

       11
       11
        
       }

     

       12
       12
       -
       

     

       13
       13
       -
       type t = [`Generic | `Unix] t_internal

     

       14
       12
        
       

     

       15
       13
        
       type person = {

     

       16
       14
        
         id: string;

     
···

       18
       16
        
         birth_date: string option;

     

       19
       17
        
         thumbnail_path: string;

     

       20
       18
        
         is_hidden: bool;

     

       21
       21
       -
       }

     

       22
       22
       -
       

     

       23
       23
       -
       type people_response = {

     

       24
       24
       -
         total: int;

     

       25
       25
       -
         visible: int;

     

       26
       26
       -
         people: person list;

     

       19
       19
       +
         unknown: Jsont.json;

     

       27
       20
        
       }

     

       28
       21
        
       

     

       29
       22
        
       (** {1 Client Creation} *)

     
···

       33
       26
        
         let requests_session = Requests.set_default_header requests_session "x-api-key" api_key in

     

       34
       27
        
         { base_url; api_key; requests_session }

     

       35
       28
        
       

     

       36
       36
       -
       (** {1 JSON Parsing} *)

     

       29
       29
       +
       (** {1 JSON Codecs} *)

     

       37
       30
        
       

     

       38
       38
       -
       (* Parse a single person from JSON *)

     

       39
       39
       -
       let parse_person json =

     

       40
       40
       -
         let open Ezjsonm in

     

       41
       41
       -
         let id = find json ["id"] |> get_string in

     

       42
       42
       -
         let name = find json ["name"] |> get_string in

     

       43
       43
       -
         let birth_date =

     

       44
       44
       -
           try Some (find json ["birthDate"] |> get_string)

     

       45
       45
       -
           with _ -> None

     

       31
       31
       +
       (* Jsont codec for person *)

     

       32
       32
       +
       let person_jsont =

     

       33
       33
       +
         let make id name birth_date thumbnail_path is_hidden unknown =

     

       34
       34
       +
           { id; name; birth_date; thumbnail_path; is_hidden; unknown }

     

       46
       35
        
         in

     

       47
       47
       -
         let thumbnail_path = find json ["thumbnailPath"] |> get_string in

     

       48
       48
       -
         let is_hidden =

     

       49
       49
       -
           try find json ["isHidden"] |> get_bool

     

       50
       50
       -
           with _ -> false

     

       51
       51
       -
         in

     

       52
       52
       -
         { id; name; birth_date; thumbnail_path; is_hidden }

     

       36
       36
       +
         let id p = p.id in

     

       37
       37
       +
         let name p = p.name in

     

       38
       38
       +
         let birth_date p = p.birth_date in

     

       39
       39
       +
         let thumbnail_path p = p.thumbnail_path in

     

       40
       40
       +
         let is_hidden p = p.is_hidden in

     

       41
       41
       +
         let unknown p = p.unknown in

     

       42
       42
       +
         Jsont.Object.map ~kind:"Person" make

     

       43
       43
       +
         |> Jsont.Object.mem "id" Jsont.string ~enc:id

     

       44
       44
       +
         |> Jsont.Object.mem "name" Jsont.string ~enc:name

     

       45
       45
       +
         |> Jsont.Object.opt_mem "birthDate" Jsont.string ~enc:birth_date

     

       46
       46
       +
         |> Jsont.Object.mem "thumbnailPath" Jsont.string ~enc:thumbnail_path

     

       47
       47
       +
         |> Jsont.Object.mem "isHidden" Jsont.bool ~enc:is_hidden

     

       48
       48
       +
         |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown

     

       49
       49
       +
         |> Jsont.Object.finish

     

       53
       50
        
       

     

       54
       54
       -
       (* Parse people response from JSON *)

     

       55
       55
       -
       let parse_people_response json =

     

       56
       56
       -
         let open Ezjsonm in

     

       57
       57
       -
         let total = find json ["total"] |> get_int in

     

       58
       58
       -
         let visible = find json ["visible"] |> get_int in

     

       59
       59
       -
         let people_json = find json ["people"] in

     

       60
       60
       -
         let people = get_list parse_person people_json in

     

       61
       61
       -
         { total; visible; people }

     

       51
       51
       +
       type people_response = {

     

       52
       52
       +
         total: int;

     

       53
       53
       +
         visible: int;

     

       54
       54
       +
         people: person list;

     

       55
       55
       +
         unknown: Jsont.json;

     

       56
       56
       +
       }

     

       62
       57
        
       

     

       63
       63
       -
       (* Parse a list of people from search results *)

     

       64
       64
       -
       let parse_person_list json =

     

       65
       65
       -
         let open Ezjsonm in

     

       66
       66
       -
         get_list parse_person json

     

       58
       58
       +
       (* Jsont codec for people_response *)

     

       59
       59
       +
       let people_response_jsont =

     

       60
       60
       +
         let make total visible people unknown =

     

       61
       61
       +
           { total; visible; people; unknown }

     

       62
       62
       +
         in

     

       63
       63
       +
         let total r = r.total in

     

       64
       64
       +
         let visible r = r.visible in

     

       65
       65
       +
         let people r = r.people in

     

       66
       66
       +
         let unknown r = r.unknown in

     

       67
       67
       +
         Jsont.Object.map ~kind:"PeopleResponse" make

     

       68
       68
       +
         |> Jsont.Object.mem "total" Jsont.int ~enc:total

     

       69
       69
       +
         |> Jsont.Object.mem "visible" Jsont.int ~enc:visible

     

       70
       70
       +
         |> Jsont.Object.mem "people" (Jsont.list person_jsont) ~enc:people

     

       71
       71
       +
         |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown

     

       72
       72
       +
         |> Jsont.Object.finish

     

       67
       73
        
       

     

       68
       74
        
       (** {1 API Functions} *)

     

       69
       75
        
       

     

       70
       76
        
       let fetch_people { base_url; requests_session; _ } =

     

       71
       77
        
         let open Requests_json_api in

     

       72
       78
        
         let url = base_url / "api/people" in

     

       73
       73
       -
         get_json_exn requests_session url parse_people_response

     

       79
       79
       +
         get_json_exn requests_session url people_response_jsont

     

       74
       80
        
       

     

       75
       81
        
       let fetch_person { base_url; requests_session; _ } ~person_id =

     

       76
       82
        
         let open Requests_json_api in

     

       77
       83
        
         let url = base_url / "api/people" / person_id in

     

       78
       78
       -
         get_json_exn requests_session url parse_person

     

       84
       84
       +
         get_json_exn requests_session url person_jsont

     

       79
       85
        
       

     

       80
       86
        
       let download_thumbnail { base_url; requests_session; _ } ~fs ~person_id ~output_path =

     

       81
       87
        
         try

     
···

       104
       110
        
         let open Requests_json_api in

     

       105
       111
        
         let encoded_name = Uri.pct_encode name in

     

       106
       112
        
         let url = sprintf "%s/api/search/person?name=%s" base_url encoded_name in

     

       107
       107
       -
         get_json_exn requests_session url parse_person_list

     

       113
       113
       +
         get_json_exn requests_session url (Jsont.list person_jsont)

+3 -1

stack/immich/immich.mli

···

       16
       16
        
         birth_date: string option;

     

       17
       17
        
         thumbnail_path: string;

     

       18
       18
        
         is_hidden: bool;

     

       19
       19
       +
         unknown: Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       19
       20
        
       }

     

       20
       21
        
       

     

       21
       22
        
       (** Type for the people API response *)

     
···

       23
       24
        
         total: int;

     

       24
       25
        
         visible: int;

     

       25
       26
        
         people: person list;

     

       27
       27
       +
         unknown: Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       26
       28
        
       }

     

       27
       29
        
       

     

       28
       30
        
       (** {1 Client Creation} *)

     
···

       35
       37
        
           @return An Immich client configured for the specified instance

     

       36
       38
        
       *)

     

       37
       39
        
       val create :

     

       38
       38
       -
         requests_session:(float Eio.Time.clock_ty Eio.Resource.t, [`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t ->

     

       40
       40
       +
         requests_session:Requests.t ->

     

       39
       41
        
         base_url:string ->

     

       40
       42
        
         api_key:string ->

     

       41
       43
        
         t

+2 -1

stack/immich/immich.opam

···

       9
       9
        
         "eio"

     

       10
       10
        
         "eio_main" {>= "1.0"}

     

       11
       11
        
         "requests"

     

       12
       12
       -
         "ezjsonm"

     

       12
       12
       +
         "jsont"

     

       13
       13
       +
         "bytesrw"

     

       13
       14
        
         "fmt"

     

       14
       15
        
         "ptime"

     

       15
       16
        
         "uri"

+42 -37

stack/karakeep/bin/karakeep_cli.ml

···

       27
       27
        
           let bookmarks =

     

       28
       28
        
             List.filter (fun (b : Karakeep.bookmark) ->

     

       29
       29
        
               (match archived with

     

       30
       30
       -
                | Some true -> b.archived

     

       31
       31
       -
                | Some false -> not b.archived

     

       30
       30
       +
                | Some true -> Karakeep.bookmark_archived b

     

       31
       31
       +
                | Some false -> not (Karakeep.bookmark_archived b)

     

       32
       32
        
                | None -> true) &&

     

       33
       33
        
               (match favourited with

     

       34
       34
       -
                | Some true -> b.favourited

     

       35
       35
       -
                | Some false -> not b.favourited

     

       34
       34
       +
                | Some true -> Karakeep.bookmark_favourited b

     

       35
       35
       +
                | Some false -> not (Karakeep.bookmark_favourited b)

     

       36
       36
        
                | None -> true)

     

       37
       37
        
             ) bookmarks

     

       38
       38
        
           in

     
···

       40
       40
        
           Printf.printf "Found %d bookmarks\n\n" (List.length bookmarks);

     

       41
       41
        
       

     

       42
       42
        
           List.iteri (fun i (b : Karakeep.bookmark) ->

     

       43
       43
       -
             Printf.printf "%d. %s\n" (i + 1) b.url;

     

       44
       44
       -
             (match b.title with

     

       43
       43
       +
             Printf.printf "%d. %s\n" (i + 1) (Karakeep.bookmark_url b);

     

       44
       44
       +
             (match Karakeep.bookmark_title b with

     

       45
       45
        
              | Some title -> Printf.printf "   Title: %s\n" title

     

       46
       46
        
              | None -> ());

     

       47
       47
       -
             Printf.printf "   ID: %s\n" b.id;

     

       48
       48
       -
             Printf.printf "   Created: %s\n" (Ptime.to_rfc3339 b.created_at);

     

       49
       49
       -
             if b.tags <> [] then

     

       50
       50
       -
               Printf.printf "   Tags: %s\n" (String.concat ", " b.tags);

     

       51
       51
       -
             if b.archived then Printf.printf "   [ARCHIVED]\n";

     

       52
       52
       -
             if b.favourited then Printf.printf "   [FAVOURITED]\n";

     

       53
       53
       -
             (match b.summary with

     

       47
       47
       +
             Printf.printf "   ID: %s\n" (Karakeep.bookmark_id b);

     

       48
       48
       +
             Printf.printf "   Created: %s\n" (Ptime.to_rfc3339 (Karakeep.bookmark_created_at b));

     

       49
       49
       +
             let tags = Karakeep.bookmark_tags b in

     

       50
       50
       +
             if tags <> [] then

     

       51
       51
       +
               Printf.printf "   Tags: %s\n" (String.concat ", " tags);

     

       52
       52
       +
             if Karakeep.bookmark_archived b then Printf.printf "   [ARCHIVED]\n";

     

       53
       53
       +
             if Karakeep.bookmark_favourited b then Printf.printf "   [FAVOURITED]\n";

     

       54
       54
       +
             (match Karakeep.bookmark_summary b with

     

       54
       55
        
              | Some s when s <> "" ->

     

       55
       56
        
                  let summary = if String.length s > 100 then String.sub s 0 100 ^ "..." else s in

     

       56
       57
        
                  Printf.printf "   Summary: %s\n" summary

     
···

       79
       80
        
           let client = Karakeep.create ~sw ~env ~api_key ~base_url in

     

       80
       81
        
           let bookmark = Karakeep.fetch_bookmark_details client bookmark_id in

     

       81
       82
        
       

     

       82
       82
       -
           Printf.printf "Bookmark: %s\n" bookmark.url;

     

       83
       83
       -
           Printf.printf "ID: %s\n" bookmark.id;

     

       84
       84
       -
           (match bookmark.title with

     

       83
       83
       +
           Printf.printf "Bookmark: %s\n" (Karakeep.bookmark_url bookmark);

     

       84
       84
       +
           Printf.printf "ID: %s\n" (Karakeep.bookmark_id bookmark);

     

       85
       85
       +
           (match Karakeep.bookmark_title bookmark with

     

       85
       86
        
            | Some title -> Printf.printf "Title: %s\n" title

     

       86
       87
        
            | None -> ());

     

       87
       87
       -
           (match bookmark.note with

     

       88
       88
       +
           (match Karakeep.bookmark_note bookmark with

     

       88
       89
        
            | Some note -> Printf.printf "Note: %s\n" note

     

       89
       90
        
            | None -> ());

     

       90
       90
       -
           Printf.printf "Created: %s\n" (Ptime.to_rfc3339 bookmark.created_at);

     

       91
       91
       -
           (match bookmark.updated_at with

     

       91
       91
       +
           Printf.printf "Created: %s\n" (Ptime.to_rfc3339 (Karakeep.bookmark_created_at bookmark));

     

       92
       92
       +
           (match Karakeep.bookmark_updated_at bookmark with

     

       92
       93
        
            | Some t -> Printf.printf "Updated: %s\n" (Ptime.to_rfc3339 t)

     

       93
       94
        
            | None -> ());

     

       94
       95
        
       

     

       95
       95
       -
           if bookmark.tags <> [] then

     

       96
       96
       -
             Printf.printf "Tags: %s\n" (String.concat ", " bookmark.tags);

     

       96
       96
       +
           let tags = Karakeep.bookmark_tags bookmark in

     

       97
       97
       +
           if tags <> [] then

     

       98
       98
       +
             Printf.printf "Tags: %s\n" (String.concat ", " tags);

     

       97
       99
        
       

     

       98
       98
       -
           if bookmark.archived then Printf.printf "Status: ARCHIVED\n";

     

       99
       99
       -
           if bookmark.favourited then Printf.printf "Status: FAVOURITED\n";

     

       100
       100
       +
           if Karakeep.bookmark_archived bookmark then Printf.printf "Status: ARCHIVED\n";

     

       101
       101
       +
           if Karakeep.bookmark_favourited bookmark then Printf.printf "Status: FAVOURITED\n";

     

       100
       102
        
       

     

       101
       101
       -
           (match bookmark.summary with

     

       103
       103
       +
           (match Karakeep.bookmark_summary bookmark with

     

       102
       104
        
            | Some s when s <> "" -> Printf.printf "\nSummary:\n%s\n" s

     

       103
       105
        
            | _ -> ());

     

       104
       106
        
       

     

       105
       105
       -
           if bookmark.content <> [] then begin

     

       107
       107
       +
           let content = Karakeep.bookmark_content bookmark in

     

       108
       108
       +
           if content <> [] then begin

     

       106
       109
        
             Printf.printf "\nContent metadata:\n";

     

       107
       110
        
             List.iter (fun (k, v) ->

     

       108
       111
        
               if v <> "null" && v <> "" then

     

       109
       112
        
                 Printf.printf "  %s: %s\n" k v

     

       110
       110
       -
             ) bookmark.content

     

       113
       113
       +
             ) content

     

       111
       114
        
           end;

     

       112
       115
        
       

     

       113
       113
       -
           if bookmark.assets <> [] then begin

     

       116
       116
       +
           let assets = Karakeep.bookmark_assets bookmark in

     

       117
       117
       +
           if assets <> [] then begin

     

       114
       118
        
             Printf.printf "\nAssets:\n";

     

       115
       119
        
             List.iter (fun (id, asset_type) ->

     

       116
       120
        
               Printf.printf "  %s (%s)\n" id asset_type;

     

       117
       121
        
               Printf.printf "    URL: %s\n" (Karakeep.get_asset_url client id)

     

       118
       118
       -
             ) bookmark.assets

     

       122
       122
       +
             ) assets

     

       119
       123
        
           end;

     

       120
       124
        
       

     

       121
       125
        
           0

     
···

       154
       158
        
           in

     

       155
       159
        
       

     

       156
       160
        
           Printf.printf "✓ Bookmark created successfully!\n";

     

       157
       157
       -
           Printf.printf "ID: %s\n" bookmark.id;

     

       158
       158
       -
           Printf.printf "URL: %s\n" bookmark.url;

     

       159
       159
       -
           (match bookmark.title with

     

       161
       161
       +
           Printf.printf "ID: %s\n" (Karakeep.bookmark_id bookmark);

     

       162
       162
       +
           Printf.printf "URL: %s\n" (Karakeep.bookmark_url bookmark);

     

       163
       163
       +
           (match Karakeep.bookmark_title bookmark with

     

       160
       164
        
            | Some t -> Printf.printf "Title: %s\n" t

     

       161
       165
        
            | None -> ());

     

       162
       162
       -
           if bookmark.tags <> [] then

     

       163
       163
       -
             Printf.printf "Tags: %s\n" (String.concat ", " bookmark.tags);

     

       166
       166
       +
           let tags = Karakeep.bookmark_tags bookmark in

     

       167
       167
       +
           if tags <> [] then

     

       168
       168
       +
             Printf.printf "Tags: %s\n" (String.concat ", " tags);

     

       164
       169
        
           0

     

       165
       170
        
         with exn ->

     

       166
       171
        
           Printf.eprintf "Error: %s\n" (Printexc.to_string exn);

     
···

       197
       202
        
               (if List.length bookmarks = 1 then "" else "s");

     

       198
       203
        
       

     

       199
       204
        
             List.iteri (fun i (b : Karakeep.bookmark) ->

     

       200
       200
       -
               Printf.printf "%d. %s\n" (i + 1) b.url;

     

       201
       201
       -
               (match b.title with

     

       205
       205
       +
               Printf.printf "%d. %s\n" (i + 1) (Karakeep.bookmark_url b);

     

       206
       206
       +
               (match Karakeep.bookmark_title b with

     

       202
       207
        
                | Some title -> Printf.printf "   Title: %s\n" title

     

       203
       208
        
                | None -> ());

     

       204
       204
       -
               Printf.printf "   ID: %s\n" b.id;

     

       205
       205
       -
               Printf.printf "   Tags: %s\n" (String.concat ", " b.tags);

     

       209
       209
       +
               Printf.printf "   ID: %s\n" (Karakeep.bookmark_id b);

     

       210
       210
       +
               Printf.printf "   Tags: %s\n" (String.concat ", " (Karakeep.bookmark_tags b));

     

       206
       211
        
               Printf.printf "\n"

     

       207
       212
        
             ) bookmarks;

     

       208
       213
        
             0

+1 -1

stack/karakeep/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (name karakeep)

     

       3
       3
        
        (public_name karakeep)

     

       4
       4
       -
        (libraries bushel eio eio.core requests requests_json_api ezjsonm fmt ptime uri logs logs.fmt))

     

       4
       4
       +
        (libraries eio eio.core requests requests_json_api jsont jsont.bytesrw fmt ptime uri logs logs.fmt))

-1

stack/karakeep/dune-project

···

       13
       13
        
         eio

     

       14
       14
        
         (eio_main (>= 1.0))

     

       15
       15
        
         requests

     

       16
       16
       -
         ezjsonm

     

       17
       16
        
         fmt

     

       18
       17
        
         ptime

     

       19
       18
        
         uri

+315 -275

stack/karakeep/karakeep.ml

···

       1
       1
        
       (** Karakeep API client implementation (Eio version) *)

     

       2
       2
        
       

     

       3
       3
       -
       module J = Ezjsonm

     

       4
       4
       -
       

     

       5
       3
        
       let src = Logs.Src.create "karakeepe" ~doc:"Karakeep API client"

     

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

     

       7
       5
        
       

     

       6
       6
       +
       (** RFC 3339 timestamp support for JSON *)

     

       7
       7
       +
       module Rfc3339 = struct

     

       8
       8
       +
         let parse s =

     

       9
       9
       +
           Ptime.of_rfc3339 s |> Result.to_option |> Option.map (fun (t, _, _) -> t)

     

       10
       10
       +
       

     

       11
       11
       +
         let format t = Ptime.to_rfc3339 ~frac_s:6 ~tz_offset_s:0 t

     

       12
       12
       +
         let _pp ppf t = Format.pp_print_string ppf (format t)

     

       13
       13
       +
       

     

       14
       14
       +
         let jsont =

     

       15
       15
       +
           let kind = "RFC 3339 timestamp" in

     

       16
       16
       +
           let dec meta s =

     

       17
       17
       +
             match parse s with

     

       18
       18
       +
             | Some t -> t

     

       19
       19
       +
             | None ->

     

       20
       20
       +
                 Jsont.Error.msgf meta "invalid RFC 3339 timestamp: %S" s

     

       21
       21
       +
           in

     

       22
       22
       +
           let enc = Jsont.Base.enc format in

     

       23
       23
       +
           Jsont.Base.string (Jsont.Base.map ~kind ~dec ~enc ())

     

       24
       24
       +
       end

     

       25
       25
       +
       

     

       26
       26
       +
       (** Unknown JSON fields - used when keeping unknown members *)

     

       27
       27
       +
       let json_mems_empty = Jsont.Object ([], Jsont.Meta.none)

     

       28
       28
       +
       

     

       8
       29
        
       (** Type representing a Karakeep client session *)

     

       9
       9
       -
       type 'net t_internal = {

     

       30
       30
       +
       type t = {

     

       10
       31
        
         api_key: string;

     

       11
       32
        
         base_url: string;

     

       12
       12
       -
         http_client: (float Eio.Time.clock_ty Eio.Resource.t, 'net Eio.Net.ty Eio.Resource.t) Requests.t;

     

       33
       33
       +
         http_client: Requests.t;

     

       13
       34
        
       }

     

       14
       14
       -
       

     

       15
       15
       -
       type t = [`Generic | `Unix] t_internal

     

       16
       35
        
       

     

       17
       36
        
       (** Create a new Karakeep client *)

     

       18
       37
        
       let create ~sw ~env ~api_key ~base_url : t =

     

       19
       38
        
         let http_client = Requests.create ~sw env in

     

       20
       39
        
         { api_key; base_url; http_client }

     

       21
       40
        
       

     

       22
       22
       -
       (** Type representing a Karakeep bookmark *)

     

       23
       23
       -
       type bookmark = {

     

       24
       24
       -
         id: string;

     

       25
       25
       -
         title: string option;

     

       26
       26
       -
         url: string;

     

       27
       27
       -
         note: string option;

     

       28
       28
       -
         created_at: Ptime.t;

     

       29
       29
       -
         updated_at: Ptime.t option;

     

       30
       30
       -
         favourited: bool;

     

       31
       31
       -
         archived: bool;

     

       32
       32
       -
         tags: string list;

     

       33
       33
       -
         tagging_status: string option;

     

       34
       34
       -
         summary: string option;

     

       35
       35
       -
         content: (string * string) list;

     

       36
       36
       -
         assets: (string * string) list;

     

       37
       37
       -
       }

     

       41
       41
       +
       (** Tag type for bookmark tags *)

     

       42
       42
       +
       module Tag = struct

     

       43
       43
       +
         type t = {

     

       44
       44
       +
           name: string;

     

       45
       45
       +
           unknown: Jsont.json;

     

       46
       46
       +
         }

     

       38
       47
        
       

     

       39
       39
       -
       (** Type for Karakeep API response containing bookmarks *)

     

       40
       40
       -
       type bookmark_response = {

     

       41
       41
       -
         total: int;

     

       42
       42
       -
         data: bookmark list;

     

       43
       43
       -
         next_cursor: string option;

     

       44
       44
       -
       }

     

       48
       48
       +
         let make name unknown = { name; unknown }

     

       49
       49
       +
         let name t = t.name

     

       50
       50
       +
         let unknown t = t.unknown

     

       45
       51
        
       

     

       46
       46
       -
       (** Parse a date string to Ptime.t, defaulting to epoch if invalid *)

     

       47
       47
       -
       let parse_date str =

     

       48
       48
       -
         match Ptime.of_rfc3339 str with

     

       49
       49
       -
         | Ok (date, _, _) -> date

     

       50
       50
       -
         | Error _ ->

     

       51
       51
       -
             Fmt.epr "Warning: could not parse date '%s'\n" str;

     

       52
       52
       -
             (* Default to epoch time *)

     

       53
       53
       -
             let span_opt = Ptime.Span.of_d_ps (0, 0L) in

     

       54
       54
       -
             match span_opt with

     

       55
       55
       -
             | None -> failwith "Internal error: couldn't create epoch time span"

     

       56
       56
       -
             | Some span ->

     

       57
       57
       -
               match Ptime.of_span span with

     

       58
       58
       -
               | Some t -> t

     

       59
       59
       -
               | None -> failwith "Internal error: couldn't create epoch time"

     

       52
       52
       +
         let jsont =

     

       53
       53
       +
           let kind = "Tag" in

     

       54
       54
       +
           Jsont.Object.map ~kind make

     

       55
       55
       +
           |> Jsont.Object.mem "name" Jsont.string ~enc:name

     

       56
       56
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown

     

       57
       57
       +
           |> Jsont.Object.finish

     

       58
       58
       +
       end

     

       60
       59
        
       

     

       61
       61
       -
       (** Extract a string field from JSON, returns None if not present or not a string *)

     

       62
       62
       -
       let get_string_opt json path =

     

       63
       63
       -
         try Some (J.find json path |> J.get_string)

     

       64
       64
       -
         with _ -> None

     

       60
       60
       +
       (** Content field pair (key-value from content object) *)

     

       61
       61
       +
       module ContentField = struct

     

       62
       62
       +
         type _t = string * string

     

       65
       63
        
       

     

       66
       66
       -
       (** Extract a string list field from JSON, returns empty list if not present *)

     

       67
       67
       -
       let get_string_list json path =

     

       68
       68
       -
         try

     

       69
       69
       -
           let items_json = J.find json path in

     

       70
       70
       -
           J.get_list (fun tag -> J.find tag ["name"] |> J.get_string) items_json

     

       71
       71
       -
         with _ -> []

     

       64
       64
       +
         let _key (k, _) = k

     

       65
       65
       +
         let _value (_, v) = v

     

       72
       66
        
       

     

       73
       73
       -
       (** Extract a boolean field from JSON, with default value *)

     

       74
       74
       -
       let get_bool_def json path default =

     

       75
       75
       -
         try J.find json path |> J.get_bool

     

       76
       76
       -
         with _ -> default

     

       67
       67
       +
         (* Helper to convert Jsont.json to string *)

     

       68
       68
       +
         let json_to_string = function

     

       69
       69
       +
           | Jsont.String (s, _) -> s

     

       70
       70
       +
           | Jsont.Bool (b, _) -> string_of_bool b

     

       71
       71
       +
           | Jsont.Number (n, _) -> string_of_float n

     

       72
       72
       +
           | Jsont.Null _ -> "null"

     

       73
       73
       +
           | _ -> "complex_value"

     

       77
       74
        
       

     

       78
       78
       -
       (** Parse a single bookmark from Karakeep JSON *)

     

       79
       79
       -
       let parse_bookmark json =

     

       80
       80
       -
         let id =

     

       81
       81
       -
           try J.find json ["id"] |> J.get_string

     

       82
       82
       -
           with e ->

     

       83
       83
       -
             Log.err (fun m -> m "Error parsing bookmark ID: %s@.JSON: %s"

     

       84
       84
       -
               (Printexc.to_string e) (J.value_to_string json));

     

       85
       85
       -
             failwith "Unable to parse bookmark ID"

     

       86
       86
       -
         in

     

       75
       75
       +
         (* Decode from JSON object members *)

     

       76
       76
       +
         let of_json_mems mems =

     

       77
       77
       +
           List.map (fun ((k, _meta), v) -> (k, json_to_string v)) mems

     

       78
       78
       +
       

     

       79
       79
       +
         (* Encode to JSON object members *)

     

       80
       80
       +
         let to_json_mems fields =

     

       81
       81
       +
           List.map (fun (k, v) -> ((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))) fields

     

       82
       82
       +
       end

     

       83
       83
       +
       

     

       84
       84
       +
       (** Asset type *)

     

       85
       85
       +
       module Asset = struct

     

       86
       86
       +
         type t = {

     

       87
       87
       +
           id: string;

     

       88
       88
       +
           asset_type: string;

     

       89
       89
       +
           unknown: Jsont.json;

     

       90
       90
       +
         }

     

       91
       91
       +
       

     

       92
       92
       +
         let make id asset_type unknown = { id; asset_type; unknown }

     

       93
       93
       +
         let id t = t.id

     

       94
       94
       +
         let asset_type t = t.asset_type

     

       95
       95
       +
         let unknown t = t.unknown

     

       87
       96
        
       

     

       88
       88
       -
         let title =

     

       89
       89
       -
           try Some (J.find json ["title"] |> J.get_string)

     

       90
       90
       -
           with _ -> None

     

       91
       91
       -
         in

     

       97
       97
       +
         let jsont =

     

       98
       98
       +
           let kind = "Asset" in

     

       99
       99
       +
           Jsont.Object.map ~kind make

     

       100
       100
       +
           |> Jsont.Object.mem "id" Jsont.string ~enc:id

     

       101
       101
       +
           |> Jsont.Object.mem "assetType" Jsont.string ~enc:asset_type

     

       102
       102
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown

     

       103
       103
       +
           |> Jsont.Object.finish

     

       104
       104
       +
       end

     

       92
       105
        
       

     

       93
       93
       -
         let url =

     

       94
       94
       -
           try J.find json ["url"] |> J.get_string

     

       95
       95
       -
           with _ -> try

     

       96
       96
       -
             J.find json ["content"; "url"] |> J.get_string

     

       97
       97
       -
           with _ -> try

     

       98
       98
       -
             J.find json ["content"; "sourceUrl"] |> J.get_string

     

       99
       99
       -
           with _ ->

     

       100
       100
       -
             match J.find_opt json ["content"; "type"] with

     

       101
       101
       -
             | Some (`String "asset") ->

     

       102
       102
       -
                 (try J.find json ["content"; "sourceUrl"] |> J.get_string

     

       103
       103
       -
                  with _ ->

     

       104
       104
       -
                    (match J.find_opt json ["id"] with

     

       105
       105
       -
                     | Some (`String id) -> "karakeep-asset://" ^ id

     

       106
       106
       -
                     | _ -> failwith "No URL or asset ID found in bookmark"))

     

       107
       107
       -
             | _ ->

     

       108
       108
       -
                 Log.err (fun m -> m "No URL found in bookmark@.JSON structure: %s"

     

       109
       109
       -
                   (J.value_to_string json));

     

       110
       110
       -
                 failwith "No URL found in bookmark"

     

       111
       111
       -
         in

     

       106
       106
       +
       (** Karakeep bookmark *)

     

       107
       107
       +
       module Bookmark = struct

     

       108
       108
       +
         type t = {

     

       109
       109
       +
           id: string;

     

       110
       110
       +
           title: string option;

     

       111
       111
       +
           url: string;

     

       112
       112
       +
           note: string option;

     

       113
       113
       +
           created_at: Ptime.t;

     

       114
       114
       +
           updated_at: Ptime.t option;

     

       115
       115
       +
           favourited: bool;

     

       116
       116
       +
           archived: bool;

     

       117
       117
       +
           tags: string list;

     

       118
       118
       +
           tagging_status: string option;

     

       119
       119
       +
           summary: string option;

     

       120
       120
       +
           content: (string * string) list;

     

       121
       121
       +
           assets: (string * string) list;

     

       122
       122
       +
         }

     

       112
       123
        
       

     

       113
       113
       -
         let note = get_string_opt json ["note"] in

     

       124
       124
       +
         let id t = t.id

     

       125
       125
       +
         let title t = t.title

     

       126
       126
       +
         let url t = t.url

     

       127
       127
       +
         let note t = t.note

     

       128
       128
       +
         let created_at t = t.created_at

     

       129
       129
       +
         let updated_at t = t.updated_at

     

       130
       130
       +
         let favourited t = t.favourited

     

       131
       131
       +
         let archived t = t.archived

     

       132
       132
       +
         let tags t = t.tags

     

       133
       133
       +
         let tagging_status t = t.tagging_status

     

       134
       134
       +
         let summary t = t.summary

     

       135
       135
       +
         let content t = t.content

     

       136
       136
       +
         let assets t = t.assets

     

       114
       137
        
       

     

       115
       115
       -
         let created_at =

     

       116
       116
       -
           try J.find json ["createdAt"] |> J.get_string |> parse_date

     

       117
       117
       -
           with _ ->

     

       118
       118
       -
             try J.find json ["created_at"] |> J.get_string |> parse_date

     

       119
       119
       -
             with _ -> failwith "No creation date found"

     

       120
       120
       -
         in

     

       138
       138
       +
         let jsont =

     

       139
       139
       +
           let kind = "Bookmark" in

     

       121
       140
        
       

     

       122
       122
       -
         let updated_at =

     

       123
       123
       -
           try Some (J.find json ["updatedAt"] |> J.get_string |> parse_date)

     

       124
       124
       -
           with _ ->

     

       125
       125
       -
             try Some (J.find json ["modifiedAt"] |> J.get_string |> parse_date)

     

       126
       126
       -
             with _ -> None

     

       127
       127
       -
         in

     

       141
       141
       +
           (* Constructor for decoding *)

     

       142
       142
       +
           let make id title url note created_at updated_at favourited archived

     

       143
       143
       +
               tag_objs tagging_status summary content_obj assets_objs _unknown =

     

       128
       144
        
       

     

       129
       129
       -
         let favourited = get_bool_def json ["favourited"] false in

     

       130
       130
       -
         let archived = get_bool_def json ["archived"] false in

     

       131
       131
       -
         let tags = get_string_list json ["tags"] in

     

       132
       132
       -
         let tagging_status = get_string_opt json ["taggingStatus"] in

     

       133
       133
       -
         let summary = get_string_opt json ["summary"] in

     

       145
       145
       +
             (* Extract tag names from tag objects *)

     

       146
       146
       +
             let tags = match tag_objs with

     

       147
       147
       +
               | Some tags -> List.map Tag.name tags

     

       148
       148
       +
               | None -> []

     

       149
       149
       +
             in

     

       134
       150
        
       

     

       135
       135
       -
         let content =

     

       136
       136
       -
           try

     

       137
       137
       -
             let content_json = J.find json ["content"] in

     

       138
       138
       -
             let rec extract_fields acc = function

     

       139
       139
       -
               | [] -> acc

     

       140
       140
       -
               | (k, v) :: rest ->

     

       141
       141
       -
                   let value = match v with

     

       142
       142
       -
                     | `String s -> s

     

       143
       143
       -
                     | `Bool b -> string_of_bool b

     

       144
       144
       -
                     | `Float f -> string_of_float f

     

       145
       145
       -
                     | `Null -> "null"

     

       146
       146
       -
                     | _ -> "complex_value"

     

       147
       147
       -
                   in

     

       148
       148
       -
                   extract_fields ((k, value) :: acc) rest

     

       151
       151
       +
             (* Extract content fields from JSON object *)

     

       152
       152
       +
             let content = match content_obj with

     

       153
       153
       +
               | Some (Jsont.Object (mems, _)) -> ContentField.of_json_mems mems

     

       154
       154
       +
               | _ -> []

     

       149
       155
        
             in

     

       150
       150
       -
             match content_json with

     

       151
       151
       -
             | `O fields -> extract_fields [] fields

     

       152
       152
       -
             | _ -> []

     

       153
       153
       -
           with _ -> []

     

       154
       154
       -
         in

     

       155
       156
        
       

     

       156
       156
       -
         let assets =

     

       157
       157
       -
           try

     

       158
       158
       -
             let assets_json = J.find json ["assets"] in

     

       159
       159
       -
             J.get_list (fun asset_json ->

     

       160
       160
       -
               let id = J.find asset_json ["id"] |> J.get_string in

     

       161
       161
       -
               let asset_type =

     

       162
       162
       -
                 try J.find asset_json ["assetType"] |> J.get_string

     

       163
       163
       -
                 with _ -> "unknown"

     

       164
       164
       -
               in

     

       165
       165
       -
               (id, asset_type)

     

       166
       166
       -
             ) assets_json

     

       167
       167
       -
           with _ -> []

     

       168
       168
       -
         in

     

       157
       157
       +
             (* Extract asset tuples *)

     

       158
       158
       +
             let assets = match assets_objs with

     

       159
       159
       +
               | Some asset_list -> List.map (fun a -> (Asset.id a, Asset.asset_type a)) asset_list

     

       160
       160
       +
               | None -> []

     

       161
       161
       +
             in

     

       169
       162
        
       

     

       170
       170
       -
         { id; title; url; note; created_at; updated_at; favourited; archived; tags;

     

       171
       171
       -
           tagging_status; summary; content; assets }

     

       163
       163
       +
             (* Handle URL extraction from content if main URL is missing *)

     

       164
       164
       +
             let url = match url with

     

       165
       165
       +
               | Some u -> u

     

       166
       166
       +
               | None ->

     

       167
       167
       +
                   (* Try to find URL in content *)

     

       168
       168
       +
                   (match List.assoc_opt "url" content with

     

       169
       169
       +
                    | Some u -> u

     

       170
       170
       +
                    | None ->

     

       171
       171
       +
                        (match List.assoc_opt "sourceUrl" content with

     

       172
       172
       +
                         | Some u -> u

     

       173
       173
       +
                         | None ->

     

       174
       174
       +
                             (* Check if it's an asset type *)

     

       175
       175
       +
                             (match List.assoc_opt "type" content with

     

       176
       176
       +
                              | Some "asset" ->

     

       177
       177
       +
                                  (match List.assoc_opt "sourceUrl" content with

     

       178
       178
       +
                                   | Some u -> u

     

       179
       179
       +
                                   | None -> "karakeep-asset://" ^ id)

     

       180
       180
       +
                              | _ -> "unknown://no-url")))

     

       181
       181
       +
             in

     

       182
       182
       +
       

     

       183
       183
       +
             {

     

       184
       184
       +
               id;

     

       185
       185
       +
               title;

     

       186
       186
       +
               url;

     

       187
       187
       +
               note;

     

       188
       188
       +
               created_at;

     

       189
       189
       +
               updated_at;

     

       190
       190
       +
               favourited = Option.value ~default:false favourited;

     

       191
       191
       +
               archived = Option.value ~default:false archived;

     

       192
       192
       +
               tags;

     

       193
       193
       +
               tagging_status;

     

       194
       194
       +
               summary;

     

       195
       195
       +
               content;

     

       196
       196
       +
               assets;

     

       197
       197
       +
             }

     

       198
       198
       +
           in

     

       199
       199
       +
       

     

       200
       200
       +
           Jsont.Object.map ~kind make

     

       201
       201
       +
           |> Jsont.Object.mem "id" Jsont.string ~enc:id

     

       202
       202
       +
           |> Jsont.Object.opt_mem "title" Jsont.string ~enc:title

     

       203
       203
       +
           |> Jsont.Object.opt_mem "url" Jsont.string ~enc:(fun t -> Some t.url)

     

       204
       204
       +
           |> Jsont.Object.opt_mem "note" Jsont.string ~enc:note

     

       205
       205
       +
           |> Jsont.Object.mem "createdAt" Rfc3339.jsont ~enc:created_at

     

       206
       206
       +
           |> Jsont.Object.opt_mem "updatedAt" Rfc3339.jsont ~enc:updated_at

     

       207
       207
       +
           |> Jsont.Object.opt_mem "favourited" Jsont.bool ~enc:(fun t -> Some t.favourited)

     

       208
       208
       +
           |> Jsont.Object.opt_mem "archived" Jsont.bool ~enc:(fun t -> Some t.archived)

     

       209
       209
       +
           |> Jsont.Object.opt_mem "tags" (Jsont.list Tag.jsont)

     

       210
       210
       +
               ~enc:(fun t -> if t.tags = [] then None else

     

       211
       211
       +
                     Some (List.map (fun name -> Tag.make name json_mems_empty) t.tags))

     

       212
       212
       +
           |> Jsont.Object.opt_mem "taggingStatus" Jsont.string ~enc:tagging_status

     

       213
       213
       +
           |> Jsont.Object.opt_mem "summary" Jsont.string ~enc:summary

     

       214
       214
       +
           |> Jsont.Object.opt_mem "content" Jsont.json

     

       215
       215
       +
               ~enc:(fun t -> if t.content = [] then None else

     

       216
       216
       +
                     Some (Jsont.Object (ContentField.to_json_mems t.content, Jsont.Meta.none)))

     

       217
       217
       +
           |> Jsont.Object.opt_mem "assets" (Jsont.list Asset.jsont)

     

       218
       218
       +
               ~enc:(fun t -> if t.assets = [] then None else

     

       219
       219
       +
                     Some (List.map (fun (id, asset_type) ->

     

       220
       220
       +
                       Asset.make id asset_type json_mems_empty) t.assets))

     

       221
       221
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> json_mems_empty)

     

       222
       222
       +
           |> Jsont.Object.finish

     

       223
       223
       +
       end

     

       224
       224
       +
       

     

       225
       225
       +
       (* Compatibility type aliases and accessors *)

     

       226
       226
       +
       type bookmark = Bookmark.t

     

       227
       227
       +
       let bookmark_id = Bookmark.id

     

       228
       228
       +
       let bookmark_title = Bookmark.title

     

       229
       229
       +
       let bookmark_url = Bookmark.url

     

       230
       230
       +
       let bookmark_note = Bookmark.note

     

       231
       231
       +
       let bookmark_created_at = Bookmark.created_at

     

       232
       232
       +
       let bookmark_updated_at = Bookmark.updated_at

     

       233
       233
       +
       let bookmark_favourited = Bookmark.favourited

     

       234
       234
       +
       let bookmark_archived = Bookmark.archived

     

       235
       235
       +
       let bookmark_tags = Bookmark.tags

     

       236
       236
       +
       let bookmark_tagging_status = Bookmark.tagging_status

     

       237
       237
       +
       let bookmark_summary = Bookmark.summary

     

       238
       238
       +
       let bookmark_content = Bookmark.content

     

       239
       239
       +
       let bookmark_assets = Bookmark.assets

     

       240
       240
       +
       

     

       241
       241
       +
       (** Karakeep API response containing bookmarks *)

     

       242
       242
       +
       module BookmarkResponse = struct

     

       243
       243
       +
         type t = {

     

       244
       244
       +
           total: int;

     

       245
       245
       +
           data: bookmark list;

     

       246
       246
       +
           next_cursor: string option;

     

       247
       247
       +
         }

     

       248
       248
       +
       

     

       249
       249
       +
         let make total data next_cursor = { total; data; next_cursor }

     

       250
       250
       +
         let total t = t.total

     

       251
       251
       +
         let data t = t.data

     

       252
       252
       +
         let next_cursor t = t.next_cursor

     

       253
       253
       +
       

     

       254
       254
       +
         (* Format 1: {total, data, nextCursor} *)

     

       255
       255
       +
         let format1_jsont =

     

       256
       256
       +
           let kind = "BookmarkResponse" in

     

       257
       257
       +
           let make total data next_cursor _unknown =

     

       258
       258
       +
             { total; data; next_cursor }

     

       259
       259
       +
           in

     

       260
       260
       +
           Jsont.Object.map ~kind make

     

       261
       261
       +
           |> Jsont.Object.mem "total" Jsont.int ~enc:total

     

       262
       262
       +
           |> Jsont.Object.mem "data" (Jsont.list Bookmark.jsont) ~enc:data

     

       263
       263
       +
           |> Jsont.Object.opt_mem "nextCursor" Jsont.string ~enc:next_cursor

     

       264
       264
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> json_mems_empty)

     

       265
       265
       +
           |> Jsont.Object.finish

     

       266
       266
       +
       

     

       267
       267
       +
         (* Format 2: {bookmarks, nextCursor} *)

     

       268
       268
       +
         let format2_jsont =

     

       269
       269
       +
           let kind = "BookmarkResponse" in

     

       270
       270
       +
           let make data next_cursor _unknown =

     

       271
       271
       +
             { total = List.length data; data; next_cursor }

     

       272
       272
       +
           in

     

       273
       273
       +
           Jsont.Object.map ~kind make

     

       274
       274
       +
           |> Jsont.Object.mem "bookmarks" (Jsont.list Bookmark.jsont) ~enc:data

     

       275
       275
       +
           |> Jsont.Object.opt_mem "nextCursor" Jsont.string ~enc:next_cursor

     

       276
       276
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> json_mems_empty)

     

       277
       277
       +
           |> Jsont.Object.finish

     

       278
       278
       +
       end

     

       279
       279
       +
       

     

       280
       280
       +
       (* Compatibility type aliases and accessors *)

     

       281
       281
       +
       type bookmark_response = BookmarkResponse.t

     

       282
       282
       +
       let response_total = BookmarkResponse.total

     

       283
       283
       +
       let response_data = BookmarkResponse.data

     

       284
       284
       +
       let response_next_cursor = BookmarkResponse.next_cursor

     

       172
       285
        
       

     

       173
       286
        
       (** Parse a Karakeep bookmark response - handles multiple API response formats *)

     

       174
       174
       -
       let parse_bookmark_response json =

     

       175
       175
       -
         Log.debug (fun m -> m "Parsing API response: %s" (J.value_to_string json));

     

       287
       287
       +
       let parse_bookmark_response json_str =

     

       288
       288
       +
         Log.debug (fun m -> m "Parsing API response (%d bytes)" (String.length json_str));

     

       176
       289
        
       

     

       177
       290
        
         (* Try format 1: {total: int, data: [...], nextCursor?: string} *)

     

       178
       291
        
         let try_format1 () =

     

       179
       292
        
           Log.debug (fun m -> m "Trying format 1: {total, data, nextCursor}");

     

       180
       180
       -
           let total = J.find json ["total"] |> J.get_int in

     

       181
       181
       -
           let bookmarks_json = J.find json ["data"] in

     

       182
       182
       -
           let data = J.get_list parse_bookmark bookmarks_json in

     

       183
       183
       -
           let next_cursor =

     

       184
       184
       -
             try Some (J.find json ["nextCursor"] |> J.get_string)

     

       185
       185
       -
             with _ -> None

     

       186
       186
       -
           in

     

       187
       187
       -
           Log.debug (fun m -> m "Successfully parsed format 1: %d bookmarks" (List.length data));

     

       188
       188
       -
           { total; data; next_cursor }

     

       293
       293
       +
           match Jsont_bytesrw.decode_string' BookmarkResponse.format1_jsont json_str with

     

       294
       294
       +
           | Ok response ->

     

       295
       295
       +
               Log.debug (fun m -> m "Successfully parsed format 1: %d bookmarks" (List.length response.data));

     

       296
       296
       +
               response

     

       297
       297
       +
           | Error e ->

     

       298
       298
       +
               Log.debug (fun m -> m "Format 1 failed: %s" (Jsont.Error.to_string e));

     

       299
       299
       +
               raise Not_found

     

       189
       300
        
         in

     

       190
       301
        
       

     

       191
       191
       -
         (* Try format 2: {bookmarks: [...], nextCursor?: string} - no total field *)

     

       302
       302
       +
         (* Try format 2: {bookmarks: [...], nextCursor?: string} *)

     

       192
       303
        
         let try_format2 () =

     

       193
       304
        
           Log.debug (fun m -> m "Trying format 2: {bookmarks, nextCursor}");

     

       194
       194
       -
           let bookmarks_json = J.find json ["bookmarks"] in

     

       195
       195
       -
           let data = J.get_list parse_bookmark bookmarks_json in

     

       196
       196
       -
           let next_cursor =

     

       197
       197
       -
             try Some (J.find json ["nextCursor"] |> J.get_string)

     

       198
       198
       -
             with _ -> None

     

       199
       199
       -
           in

     

       200
       200
       -
           (* Calculate total from data length when total field is missing *)

     

       201
       201
       -
           let total = List.length data in

     

       202
       202
       -
           Log.debug (fun m -> m "Successfully parsed format 2: %d bookmarks" total);

     

       203
       203
       -
           { total; data; next_cursor }

     

       305
       305
       +
           match Jsont_bytesrw.decode_string' BookmarkResponse.format2_jsont json_str with

     

       306
       306
       +
           | Ok response ->

     

       307
       307
       +
               Log.debug (fun m -> m "Successfully parsed format 2: %d bookmarks" (List.length response.data));

     

       308
       308
       +
               response

     

       309
       309
       +
           | Error e ->

     

       310
       310
       +
               Log.debug (fun m -> m "Format 2 failed: %s" (Jsont.Error.to_string e));

     

       311
       311
       +
               raise Not_found

     

       204
       312
        
         in

     

       205
       313
        
       

     

       206
       206
       -
         (* Try format 3: API error response {error: string, message?: string} *)

     

       207
       207
       -
         let try_error_format () =

     

       208
       208
       -
           Log.debug (fun m -> m "Checking for API error response");

     

       209
       209
       -
           let error = J.find json ["error"] |> J.get_string in

     

       210
       210
       -
           let message =

     

       211
       211
       -
             try J.find json ["message"] |> J.get_string

     

       212
       212
       -
             with _ -> "Unknown error"

     

       213
       213
       -
           in

     

       214
       214
       -
           Log.err (fun m -> m "API returned error: %s - %s" error message);

     

       215
       215
       -
           { total = 0; data = []; next_cursor = None }

     

       216
       216
       -
         in

     

       217
       217
       -
       

     

       218
       218
       -
         (* Try format 4: Plain array at root level *)

     

       314
       314
       +
         (* Try format 3: Plain array at root level *)

     

       219
       315
        
         let try_array_format () =

     

       220
       220
       -
           Log.debug (fun m -> m "Trying format 4: array at root");

     

       221
       221
       -
           match json with

     

       222
       222
       -
           | `A _ ->

     

       223
       223
       -
               let data = J.get_list parse_bookmark json in

     

       316
       316
       +
           Log.debug (fun m -> m "Trying format 3: array at root");

     

       317
       317
       +
           let array_jsont = Jsont.list Bookmark.jsont in

     

       318
       318
       +
           match Jsont_bytesrw.decode_string' array_jsont json_str with

     

       319
       319
       +
           | Ok data ->

     

       224
       320
        
               Log.debug (fun m -> m "Successfully parsed array format: %d bookmarks" (List.length data));

     

       225
       225
       -
               { total = List.length data; data; next_cursor = None }

     

       226
       226
       -
           | _ -> raise Not_found

     

       321
       321
       +
               BookmarkResponse.make (List.length data) data None

     

       322
       322
       +
           | Error e ->

     

       323
       323
       +
               Log.debug (fun m -> m "Array format failed: %s" (Jsont.Error.to_string e));

     

       324
       324
       +
               raise Not_found

     

       227
       325
        
         in

     

       228
       326
        
       

     

       229
       327
        
         (* Try each format in order *)

     

       230
       328
        
         try try_format1 ()

     

       231
       231
       -
         with _ -> (

     

       329
       329
       +
         with Not_found -> (

     

       232
       330
        
           try try_format2 ()

     

       233
       233
       -
           with _ -> (

     

       234
       234
       -
             try try_error_format ()

     

       235
       235
       -
             with _ -> (

     

       236
       236
       -
               try try_array_format ()

     

       237
       237
       -
               with _ ->

     

       238
       238
       -
                 Log.err (fun m -> m "Failed to parse response in any known format");

     

       239
       239
       -
                 Log.debug (fun m -> m "JSON keys: %s"

     

       240
       240
       -
                   (match json with

     

       241
       241
       -
                    | `O fields -> String.concat ", " (List.map fst fields)

     

       242
       242
       -
                    | _ -> "not an object"));

     

       243
       243
       -
                 { total = 0; data = []; next_cursor = None }

     

       244
       244
       -
             )

     

       331
       331
       +
           with Not_found -> (

     

       332
       332
       +
             try try_array_format ()

     

       333
       333
       +
             with Not_found ->

     

       334
       334
       +
               Log.err (fun m -> m "Failed to parse response in any known format");

     

       335
       335
       +
               Log.debug (fun m -> m "Response preview: %s"

     

       336
       336
       +
                 (if String.length json_str > 200 then String.sub json_str 0 200 ^ "..." else json_str));

     

       337
       337
       +
               BookmarkResponse.make 0 [] None

     

       245
       338
        
           )

     

       246
       339
        
         )

     

       247
       340
        
       

     
···

       277
       370
        
           match Requests_json_api.check_ok response with

     

       278
       371
        
           | Ok body_str ->

     

       279
       372
        
               Log.debug (fun m -> m "Received %d bytes of response data" (String.length body_str));

     

       280
       280
       -
               (try

     

       281
       281
       -
                 let json = J.from_string body_str in

     

       282
       282
       -
                 parse_bookmark_response json

     

       283
       283
       -
               with e ->

     

       284
       284
       -
                 Log.err (fun m -> m "JSON parsing error: %s" (Printexc.to_string e));

     

       285
       285
       -
                 Log.debug (fun m -> m "Response body (first 200 chars): %s"

     

       286
       286
       -
                   (if String.length body_str > 200 then String.sub body_str 0 200 ^ "..." else body_str));

     

       287
       287
       -
                 raise e)

     

       373
       373
       +
               parse_bookmark_response body_str

     

       288
       374
        
           | Error (status_code, _) ->

     

       289
       375
        
               Log.err (fun m -> m "HTTP error %d" status_code);

     

       290
       376
        
               failwith (Fmt.str "HTTP error: %d" status_code)

     
···

       325
       411
        
               | _ -> all_bookmarks

     

       326
       412
        
             in

     

       327
       413
        
       

     

       328
       328
       -
             (* Determine if more pages are available:

     

       329
       329
       -
                - If next_cursor is present, there are definitely more pages

     

       330
       330
       -
                - If no next_cursor and we got fewer items than page_size, we're done

     

       331
       331
       -
                - If no next_cursor and total is reliable (> current count), there may be more *)

     

       414
       414
       +
             (* Determine if more pages are available *)

     

       332
       415
        
             let more_available =

     

       333
       416
        
               match response.next_cursor with

     

       334
       417
        
               | Some _ ->

     
···

       338
       421
        
                   let current_count = List.length all_bookmarks in

     

       339
       422
        
                   let got_full_page = List.length response.data = page_size in

     

       340
       423
        
                   let total_indicates_more = response.total > current_count in

     

       341
       341
       -
                   (* If we got a full page and total indicates more, continue *)

     

       342
       424
        
                   let has_more = got_full_page && total_indicates_more in

     

       343
       425
        
                   if has_more then

     

       344
       426
        
                     Log.debug (fun m -> m "More pages likely available (%d fetched < %d total)"

     
···

       380
       462
        
         let response = Requests.get client.http_client ~headers url in

     

       381
       463
        
         match check_ok response with

     

       382
       464
        
         | Ok body_str ->

     

       383
       383
       -
             let json = J.from_string body_str in

     

       384
       384
       -
             parse_bookmark json

     

       465
       465
       +
             (match Jsont_bytesrw.decode_string' Bookmark.jsont body_str with

     

       466
       466
       +
              | Ok bookmark -> bookmark

     

       467
       467
       +
              | Error e ->

     

       468
       468
       +
                  failwith (Fmt.str "Failed to parse bookmark: %s" (Jsont.Error.to_string e)))

     

       385
       469
        
         | Error (status_code, _) ->

     

       386
       470
        
             failwith (Fmt.str "HTTP error: %d" status_code)

     

       387
       471
        
       

     
···

       405
       489
        
       

     

       406
       490
        
       (** Create a new bookmark in Karakeep with optional tags *)

     

       407
       491
        
       let create_bookmark client ~url ?title ?note ?tags ?(favourited=false) ?(archived=false) () =

     

       492
       492
       +
         let meta = Jsont.Meta.none in

     

       408
       493
        
         let body_obj = [

     

       409
       409
       -
           ("type", `String "link");

     

       410
       410
       -
           ("url", `String url);

     

       411
       411
       -
           ("favourited", `Bool favourited);

     

       412
       412
       -
           ("archived", `Bool archived);

     

       494
       494
       +
           (("type", meta), Jsont.String ("link", meta));

     

       495
       495
       +
           (("url", meta), Jsont.String (url, meta));

     

       496
       496
       +
           (("favourited", meta), Jsont.Bool (favourited, meta));

     

       497
       497
       +
           (("archived", meta), Jsont.Bool (archived, meta));

     

       413
       498
        
         ] in

     

       414
       499
        
       

     

       415
       500
        
         let body_obj = match title with

     

       416
       416
       -
           | Some title_str -> ("title", `String title_str) :: body_obj

     

       501
       501
       +
           | Some title_str -> (("title", meta), Jsont.String (title_str, meta)) :: body_obj

     

       417
       502
        
           | None -> body_obj

     

       418
       503
        
         in

     

       419
       504
        
       

     

       420
       505
        
         let body_obj = match note with

     

       421
       421
       -
           | Some note_str -> ("note", `String note_str) :: body_obj

     

       506
       506
       +
           | Some note_str -> (("note", meta), Jsont.String (note_str, meta)) :: body_obj

     

       422
       507
        
           | None -> body_obj

     

       423
       508
        
         in

     

       424
       509
        
       

     

       425
       425
       -
         let body_json = `O body_obj in

     

       426
       426
       -
         let body_str = J.to_string body_json in

     

       510
       510
       +
         let body_json = Jsont.Object (body_obj, meta) in

     

       511
       511
       +
         let body_str = match Jsont_bytesrw.encode_string' Jsont.json body_json with

     

       512
       512
       +
           | Ok s -> s

     

       513
       513
       +
           | Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))

     

       514
       514
       +
         in

     

       427
       515
        
       

     

       428
       516
        
         let headers = Requests.Headers.empty

     

       429
       517
        
           |> Requests.Headers.set "Authorization" ("Bearer " ^ client.api_key)

     
···

       438
       526
        
         let status_code = Requests.Response.status_code response in

     

       439
       527
        
         if status_code = 201 || status_code = 200 then begin

     

       440
       528
        
           let body_str = read_body response in

     

       441
       441
       -
           let json = J.from_string body_str in

     

       442
       442
       -
           let bookmark = parse_bookmark json in

     

       529
       529
       +
           let bookmark = match Jsont_bytesrw.decode_string' Bookmark.jsont body_str with

     

       530
       530
       +
             | Ok b -> b

     

       531
       531
       +
             | Error e -> failwith (Fmt.str "Failed to parse created bookmark: %s" (Jsont.Error.to_string e))

     

       532
       532
       +
           in

     

       443
       533
        
       

     

       444
       534
        
           match tags with

     

       445
       535
        
           | Some tag_list when tag_list <> [] ->

     

       446
       536
        
               let tag_objects = List.map (fun tag_name ->

     

       447
       447
       -
                 `O [("tagName", `String tag_name)]

     

       537
       537
       +
                 Jsont.Object ([(("tagName", meta), Jsont.String (tag_name, meta))], meta)

     

       448
       538
        
               ) tag_list in

     

       449
       539
        
       

     

       450
       450
       -
               let tags_body = `O [("tags", `A tag_objects)] in

     

       451
       451
       -
               let tags_body_str = J.to_string tags_body in

     

       540
       540
       +
               let tags_body = Jsont.Object ([(("tags", meta), Jsont.Array (tag_objects, meta))], meta) in

     

       541
       541
       +
               let tags_body_str = match Jsont_bytesrw.encode_string' Jsont.json tags_body with

     

       542
       542
       +
                 | Ok s -> s

     

       543
       543
       +
                 | Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))

     

       544
       544
       +
               in

     

       452
       545
        
       

     

       453
       546
        
               let tags_url = client.base_url / "api/v1/bookmarks" / bookmark.id / "tags" in

     

       454
       547
        
               let tags_body = Requests.Body.of_string Requests.Mime.json tags_body_str in

     
···

       464
       557
        
           let error_body = read_body response in

     

       465
       558
        
           failwith (Fmt.str "Failed to create bookmark. HTTP error: %d. Details: %s" status_code error_body)

     

       466
       559
        
         end

     

       467
       467
       -
       

     

       468
       468
       -
       (** Convert a Karakeep bookmark to Bushel.Link.t compatible structure *)

     

       469
       469
       -
       let to_bushel_link ?base_url bookmark =

     

       470
       470
       -
         let description =

     

       471
       471
       -
           match bookmark.title with

     

       472
       472
       -
           | Some title when title <> "" -> title

     

       473
       473
       -
           | _ ->

     

       474
       474
       -
               let content_title = List.assoc_opt "title" bookmark.content in

     

       475
       475
       -
               match content_title with

     

       476
       476
       -
               | Some title when title <> "" && title <> "null" -> title

     

       477
       477
       -
               | _ -> bookmark.url

     

       478
       478
       -
         in

     

       479
       479
       -
         let date = Ptime.to_date bookmark.created_at in

     

       480
       480
       -
       

     

       481
       481
       -
         let metadata =

     

       482
       482
       -
           (match bookmark.summary with Some s -> [("summary", s)] | None -> []) @

     

       483
       483
       -
           (List.filter_map (fun (id, asset_type) ->

     

       484
       484
       -
             match asset_type with

     

       485
       485
       -
             | "screenshot" | "bannerImage" -> Some (asset_type, id)

     

       486
       486
       -
             | _ -> None

     

       487
       487
       -
           ) bookmark.assets) @

     

       488
       488
       -
           (List.filter_map (fun (k, v) ->

     

       489
       489
       -
             if k = "favicon" && v <> "" && v <> "null" then Some ("favicon", v) else None

     

       490
       490
       -
           ) bookmark.content)

     

       491
       491
       -
         in

     

       492
       492
       -
       

     

       493
       493
       -
         let karakeep =

     

       494
       494
       -
           match base_url with

     

       495
       495
       -
           | Some url ->

     

       496
       496
       -
               Some {

     

       497
       497
       -
                 Bushel.Link.remote_url = url;

     

       498
       498
       -
                 id = bookmark.id;

     

       499
       499
       -
                 tags = bookmark.tags;

     

       500
       500
       -
                 metadata = metadata;

     

       501
       501
       -
               }

     

       502
       502
       -
           | None -> None

     

       503
       503
       -
         in

     

       504
       504
       -
       

     

       505
       505
       -
         let bushel_slugs =

     

       506
       506
       -
           List.filter_map (fun tag ->

     

       507
       507
       -
             if String.starts_with ~prefix:"bushel:" tag then

     

       508
       508
       -
               Some (String.sub tag 7 (String.length tag - 7))

     

       509
       509
       -
             else

     

       510
       510
       -
               None

     

       511
       511
       -
           ) bookmark.tags

     

       512
       512
       -
         in

     

       513
       513
       -
       

     

       514
       514
       -
         let bushel =

     

       515
       515
       -
           if bushel_slugs = [] then None

     

       516
       516
       -
           else Some { Bushel.Link.slugs = bushel_slugs; tags = [] }

     

       517
       517
       -
         in

     

       518
       518
       -
       

     

       519
       519
       -
         { Bushel.Link.url = bookmark.url; date; description; karakeep; bushel }

+23 -28

stack/karakeep/karakeep.mli

···

       19
       19
        
         t

     

       20
       20
        
       

     

       21
       21
        
       (** Type representing a Karakeep bookmark *)

     

       22
       22
       -
       type bookmark = {

     

       23
       23
       -
         id: string;

     

       24
       24
       -
         title: string option;

     

       25
       25
       -
         url: string;

     

       26
       26
       -
         note: string option;

     

       27
       27
       -
         created_at: Ptime.t;

     

       28
       28
       -
         updated_at: Ptime.t option;

     

       29
       29
       -
         favourited: bool;

     

       30
       30
       -
         archived: bool;

     

       31
       31
       -
         tags: string list;

     

       32
       32
       -
         tagging_status: string option;

     

       33
       33
       -
         summary: string option;

     

       34
       34
       -
         content: (string * string) list;

     

       35
       35
       -
         assets: (string * string) list;

     

       36
       36
       -
       }

     

       22
       22
       +
       type bookmark

     

       23
       23
       +
       

     

       24
       24
       +
       (** Bookmark accessors *)

     

       25
       25
       +
       val bookmark_id : bookmark -> string

     

       26
       26
       +
       val bookmark_title : bookmark -> string option

     

       27
       27
       +
       val bookmark_url : bookmark -> string

     

       28
       28
       +
       val bookmark_note : bookmark -> string option

     

       29
       29
       +
       val bookmark_created_at : bookmark -> Ptime.t

     

       30
       30
       +
       val bookmark_updated_at : bookmark -> Ptime.t option

     

       31
       31
       +
       val bookmark_favourited : bookmark -> bool

     

       32
       32
       +
       val bookmark_archived : bookmark -> bool

     

       33
       33
       +
       val bookmark_tags : bookmark -> string list

     

       34
       34
       +
       val bookmark_tagging_status : bookmark -> string option

     

       35
       35
       +
       val bookmark_summary : bookmark -> string option

     

       36
       36
       +
       val bookmark_content : bookmark -> (string * string) list

     

       37
       37
       +
       val bookmark_assets : bookmark -> (string * string) list

     

       37
       38
        
       

     

       38
       39
        
       (** Type for Karakeep API response containing bookmarks *)

     

       39
       39
       -
       type bookmark_response = {

     

       40
       40
       -
         total: int;

     

       41
       41
       -
         data: bookmark list;

     

       42
       42
       -
         next_cursor: string option;

     

       43
       43
       -
       }

     

       40
       40
       +
       type bookmark_response

     

       44
       41
        
       

     

       45
       45
       -
       (** Parse a single bookmark from Karakeep JSON *)

     

       46
       46
       -
       val parse_bookmark : Ezjsonm.value -> bookmark

     

       42
       42
       +
       (** Bookmark response accessors *)

     

       43
       43
       +
       val response_total : bookmark_response -> int

     

       44
       44
       +
       val response_data : bookmark_response -> bookmark list

     

       45
       45
       +
       val response_next_cursor : bookmark_response -> string option

     

       47
       46
        
       

     

       48
       48
       -
       (** Parse a Karakeep bookmark response *)

     

       49
       49
       -
       val parse_bookmark_response : Ezjsonm.value -> bookmark_response

     

       47
       47
       +
       (** Parse a Karakeep bookmark response from a JSON string *)

     

       48
       48
       +
       val parse_bookmark_response : string -> bookmark_response

     

       50
       49
        
       

     

       51
       50
        
       (** Fetch bookmarks from a Karakeep instance with pagination support

     

       52
       51
        
           @param client Karakeep client instance

     
···

       92
       91
        
         t ->

     

       93
       92
        
         string ->

     

       94
       93
        
         bookmark

     

       95
       95
       -
       

     

       96
       96
       -
       (** Convert a Karakeep bookmark to Bushel.Link.t compatible structure

     

       97
       97
       -
           @param base_url Optional base URL of the Karakeep instance (for karakeep_id) *)

     

       98
       98
       -
       val to_bushel_link : ?base_url:string -> bookmark -> Bushel.Link.t

     

       99
       94
        
       

     

       100
       95
        
       (** Fetch an asset from the Karakeep server as a binary string

     

       101
       96
        
           @param client Karakeep client instance

-1

stack/karakeep/karakeep.opam

···

       10
       10
        
         "eio"

     

       11
       11
        
         "eio_main" {>= "1.0"}

     

       12
       12
        
         "requests"

     

       13
       13
       -
         "ezjsonm"

     

       14
       13
        
         "fmt"

     

       15
       14
        
         "ptime"

     

       16
       15
        
         "uri"

+8 -4

stack/peertubee/bin/peertubee_cli.ml

···

       36
       36
        
                  Printf.printf "   Description: %s\n" desc_short

     

       37
       37
        
              | None -> ());

     

       38
       38
        
             Printf.printf "   Published: %s\n" (Ptime.to_rfc3339 v.published_at);

     

       39
       39
       -
             if v.tags <> [] then

     

       40
       40
       -
               Printf.printf "   Tags: %s\n" (String.concat ", " v.tags);

     

       39
       39
       +
             (match v.tags with

     

       40
       40
       +
              | Some tags when tags <> [] ->

     

       41
       41
       +
                  Printf.printf "   Tags: %s\n" (String.concat ", " tags)

     

       42
       42
       +
              | _ -> ());

     

       41
       43
        
             Printf.printf "\n"

     

       42
       44
        
           ) videos;

     

       43
       45
        
           0

     
···

       73
       75
        
           (match video.originally_published_at with

     

       74
       76
        
            | Some t -> Printf.printf "Originally published: %s\n" (Ptime.to_rfc3339 t)

     

       75
       77
        
            | None -> ());

     

       76
       76
       -
           if video.tags <> [] then

     

       77
       77
       -
             Printf.printf "Tags: %s\n" (String.concat ", " video.tags);

     

       78
       78
       +
           (match video.tags with

     

       79
       79
       +
            | Some tags when tags <> [] ->

     

       80
       80
       +
                Printf.printf "Tags: %s\n" (String.concat ", " tags)

     

       81
       81
       +
            | _ -> ());

     

       78
       82
        
           (match Peertubee.thumbnail_url client video with

     

       79
       83
        
            | Some url -> Printf.printf "Thumbnail: %s\n" url

     

       80
       84
        
            | None -> ());

+1 -1

stack/peertubee/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (name peertubee)

     

       3
       3
        
        (public_name peertubee)

     

       4
       4
       -
        (libraries ezjsonm eio eio.core requests requests_json_api ptime fmt))

     

       4
       4
       +
        (libraries jsont jsont.bytesrw eio eio.core requests requests_json_api ptime fmt))

-1

stack/peertubee/dune-project

···

       13
       13
        
         eio

     

       14
       14
        
         (eio_main (>= 1.0))

     

       15
       15
        
         requests

     

       16
       16
       -
         ezjsonm

     

       17
       16
        
         fmt

     

       18
       17
        
         ptime))

+87 -59

stack/peertubee/peertubee.ml

···

       1
       1
        
       (** PeerTube API client implementation (Eio version) *)

     

       2
       2
        
       

     

       3
       3
       -
       module J = Ezjsonm

     

       4
       4
       -
       

     

       5
       3
        
       (** Type representing a PeerTube client *)

     

       6
       6
       -
       type 'net t_internal = {

     

       4
       4
       +
       type t = {

     

       7
       5
        
         base_url: string;

     

       8
       8
       -
         requests_session: (float Eio.Time.clock_ty Eio.Resource.t, 'net Eio.Net.ty Eio.Resource.t) Requests.t;

     

       6
       6
       +
         requests_session: Requests.t;

     

       9
       7
        
       }

     

       10
       10
       -
       

     

       11
       11
       -
       type t = [`Generic | `Unix] t_internal

     

       12
       8
        
       

     

       13
       9
        
       (** Create a new PeerTube client *)

     

       14
       10
        
       let create ~requests_session ~base_url : t =

     
···

       25
       21
        
         published_at: Ptime.t;

     

       26
       22
        
         originally_published_at: Ptime.t option;

     

       27
       23
        
         thumbnail_path: string option;

     

       28
       28
       -
         tags: string list;

     

       24
       24
       +
         tags: string list option;

     

       25
       25
       +
         unknown: Jsont.json;

     

       29
       26
        
       }

     

       30
       27
        
       

     

       31
       28
        
       (** Type for PeerTube API response containing videos *)

     

       32
       29
        
       type video_response = {

     

       33
       30
        
         total: int;

     

       34
       31
        
         data: video list;

     

       32
       32
       +
         unknown: Jsont.json;

     

       35
       33
        
       }

     

       36
       34
        
       

     

       37
       37
       -
       (** Parse a date string to Ptime.t, defaulting to epoch if invalid *)

     

       38
       38
       -
       let parse_date str =

     

       39
       39
       -
         match Ptime.of_rfc3339 str with

     

       40
       40
       -
         | Ok (date, _, _) -> date

     

       41
       41
       -
         | Error _ ->

     

       42
       42
       -
             Fmt.epr "Warning: could not parse date '%s'\n" str;

     

       43
       43
       -
             (* Default to epoch time *)

     

       44
       44
       -
             let span_opt = Ptime.Span.of_d_ps (0, 0L) in

     

       45
       45
       -
             match span_opt with

     

       46
       46
       -
             | None -> failwith "Internal error: couldn't create epoch time span"

     

       47
       47
       -
             | Some span ->

     

       48
       48
       -
               match Ptime.of_span span with

     

       49
       49
       -
               | Some t -> t

     

       50
       50
       -
               | None -> failwith "Internal error: couldn't create epoch time"

     

       35
       35
       +
       (** Accessor functions for video *)

     

       36
       36
       +
       let video_id (v : video) = v.id

     

       37
       37
       +
       let video_uuid (v : video) = v.uuid

     

       38
       38
       +
       let video_name (v : video) = v.name

     

       39
       39
       +
       let video_description (v : video) = v.description

     

       40
       40
       +
       let video_url (v : video) = v.url

     

       41
       41
       +
       let video_embed_path (v : video) = v.embed_path

     

       42
       42
       +
       let video_published_at (v : video) = v.published_at

     

       43
       43
       +
       let video_originally_published_at (v : video) = v.originally_published_at

     

       44
       44
       +
       let video_thumbnail_path (v : video) = v.thumbnail_path

     

       45
       45
       +
       let video_tags (v : video) = v.tags

     

       46
       46
       +
       let video_unknown (v : video) = v.unknown

     

       51
       47
        
       

     

       52
       52
       -
       (** Extract a string field from JSON, returns None if not present or not a string *)

     

       53
       53
       -
       let get_string_opt json path =

     

       54
       54
       -
         try Some (J.find json path |> J.get_string)

     

       55
       55
       -
         with _ -> None

     

       48
       48
       +
       (** Accessor functions for video_response *)

     

       49
       49
       +
       let video_response_total (vr : video_response) = vr.total

     

       50
       50
       +
       let video_response_data (vr : video_response) = vr.data

     

       51
       51
       +
       let video_response_unknown (vr : video_response) = vr.unknown

     

       56
       52
        
       

     

       57
       57
       -
       (** Extract a string list field from JSON, returns empty list if not present *)

     

       58
       58
       -
       let get_string_list json path =

     

       59
       59
       -
         try

     

       60
       60
       -
           let tags_json = J.find json path in

     

       61
       61
       -
           J.get_list J.get_string tags_json

     

       62
       62
       -
         with _ -> []

     

       53
       53
       +
       (** RFC3339 timestamp codec *)

     

       54
       54
       +
       module Rfc3339 = struct

     

       55
       55
       +
         let parse s =

     

       56
       56
       +
           Ptime.of_rfc3339 s |> Result.to_option |> Option.map (fun (t, _, _) -> t)

     

       63
       57
        
       

     

       64
       64
       -
       (** Parse a single video from PeerTube JSON *)

     

       65
       65
       -
       let parse_video json =

     

       66
       66
       -
         let id = J.find json ["id"] |> J.get_int in

     

       67
       67
       -
         let uuid = J.find json ["uuid"] |> J.get_string in

     

       68
       68
       -
         let name = J.find json ["name"] |> J.get_string in

     

       69
       69
       -
         let description = get_string_opt json ["description"] in

     

       70
       70
       -
         let url = J.find json ["url"] |> J.get_string in

     

       71
       71
       -
         let embed_path = J.find json ["embedPath"] |> J.get_string in

     

       58
       58
       +
         let format t = Ptime.to_rfc3339 ~frac_s:6 ~tz_offset_s:0 t

     

       59
       59
       +
         let pp ppf t = Format.pp_print_string ppf (format t)

     

       72
       60
        
       

     

       73
       73
       -
         (* Parse dates *)

     

       74
       74
       -
         let published_at =

     

       75
       75
       -
           J.find json ["publishedAt"] |> J.get_string |> parse_date

     

       61
       61
       +
         let jsont =

     

       62
       62
       +
           let kind = "RFC 3339 timestamp" in

     

       63
       63
       +
           let doc = "An RFC 3339 date-time string" in

     

       64
       64
       +
           let dec s =

     

       65
       65
       +
             match parse s with

     

       66
       66
       +
             | Some t -> t

     

       67
       67
       +
             | None ->

     

       68
       68
       +
                 Jsont.Error.msgf Jsont.Meta.none "%s: invalid RFC 3339 timestamp: %S"

     

       69
       69
       +
                   kind s

     

       70
       70
       +
           in

     

       71
       71
       +
           Jsont.map ~kind ~doc ~dec ~enc:format Jsont.string

     

       72
       72
       +
       end

     

       73
       73
       +
       

     

       74
       74
       +
       (** Jsont codec for video *)

     

       75
       75
       +
       let video_jsont : video Jsont.t =

     

       76
       76
       +
         let kind = "PeerTube Video" in

     

       77
       77
       +
         let doc = "A PeerTube video object" in

     

       78
       78
       +
       

     

       79
       79
       +
         let make_video id uuid name description url embed_path published_at

     

       80
       80
       +
                        originally_published_at thumbnail_path tags unknown : video =

     

       81
       81
       +
           { id; uuid; name; description; url; embed_path; published_at;

     

       82
       82
       +
             originally_published_at; thumbnail_path; tags; unknown }

     

       76
       83
        
         in

     

       77
       84
        
       

     

       78
       78
       -
         let originally_published_at =

     

       79
       79
       -
           match get_string_opt json ["originallyPublishedAt"] with

     

       80
       80
       -
           | Some date -> Some (parse_date date)

     

       81
       81
       -
           | None -> None

     

       85
       85
       +
         Jsont.Object.map ~kind ~doc make_video

     

       86
       86
       +
         |> Jsont.Object.mem "id" Jsont.int ~enc:video_id

     

       87
       87
       +
         |> Jsont.Object.mem "uuid" Jsont.string ~enc:video_uuid

     

       88
       88
       +
         |> Jsont.Object.mem "name" Jsont.string ~enc:video_name

     

       89
       89
       +
         |> Jsont.Object.opt_mem "description" Jsont.string ~enc:video_description

     

       90
       90
       +
         |> Jsont.Object.mem "url" Jsont.string ~enc:video_url

     

       91
       91
       +
         |> Jsont.Object.mem "embedPath" Jsont.string ~enc:video_embed_path

     

       92
       92
       +
         |> Jsont.Object.mem "publishedAt" Rfc3339.jsont ~enc:video_published_at

     

       93
       93
       +
         |> Jsont.Object.opt_mem "originallyPublishedAt" Rfc3339.jsont ~enc:video_originally_published_at

     

       94
       94
       +
         |> Jsont.Object.opt_mem "thumbnailPath" Jsont.string ~enc:video_thumbnail_path

     

       95
       95
       +
         |> Jsont.Object.opt_mem "tags" (Jsont.list Jsont.string) ~enc:video_tags

     

       96
       96
       +
         |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:video_unknown

     

       97
       97
       +
         |> Jsont.Object.finish

     

       98
       98
       +
       

     

       99
       99
       +
       (** Jsont codec for video_response *)

     

       100
       100
       +
       let video_response_jsont =

     

       101
       101
       +
         let kind = "PeerTube Video Response" in

     

       102
       102
       +
         let doc = "A PeerTube API response containing videos" in

     

       103
       103
       +
       

     

       104
       104
       +
         let make_response total data unknown =

     

       105
       105
       +
           { total; data; unknown }

     

       82
       106
        
         in

     

       83
       107
        
       

     

       84
       84
       -
         let thumbnail_path = get_string_opt json ["thumbnailPath"] in

     

       85
       85
       -
         let tags = get_string_list json ["tags"] in

     

       108
       108
       +
         Jsont.Object.map ~kind ~doc make_response

     

       109
       109
       +
         |> Jsont.Object.mem "total" Jsont.int ~enc:video_response_total

     

       110
       110
       +
         |> Jsont.Object.mem "data" (Jsont.list video_jsont) ~enc:video_response_data

     

       111
       111
       +
         |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:video_response_unknown

     

       112
       112
       +
         |> Jsont.Object.finish

     

       86
       113
        
       

     

       87
       87
       -
         { id; uuid; name; description; url; embed_path;

     

       88
       88
       -
           published_at; originally_published_at;

     

       89
       89
       -
           thumbnail_path; tags }

     

       114
       114
       +
       (** Parse a single video from JSON string *)

     

       115
       115
       +
       let parse_video_string s =

     

       116
       116
       +
         match Jsont_bytesrw.decode_string' video_jsont s with

     

       117
       117
       +
         | Ok video -> video

     

       118
       118
       +
         | Error err -> failwith (Jsont.Error.to_string err)

     

       90
       119
        
       

     

       91
       91
       -
       (** Parse a PeerTube video response *)

     

       92
       92
       -
       let parse_video_response json =

     

       93
       93
       -
         let total = J.find json ["total"] |> J.get_int in

     

       94
       94
       -
         let videos_json = J.find json ["data"] in

     

       95
       95
       -
         let data = J.get_list parse_video videos_json in

     

       96
       96
       -
         { total; data }

     

       120
       120
       +
       (** Parse a video response from JSON string *)

     

       121
       121
       +
       let parse_video_response_string s =

     

       122
       122
       +
         match Jsont_bytesrw.decode_string' video_response_jsont s with

     

       123
       123
       +
         | Ok response -> response

     

       124
       124
       +
         | Error err -> failwith (Jsont.Error.to_string err)

     

       97
       125
        
       

     

       98
       126
        
       (** Fetch videos from a PeerTube instance channel with pagination support

     

       99
       127
        
           @param count Number of videos to fetch per page

     
···

       105
       133
        
         let open Requests_json_api in

     

       106
       134
        
         let url = Printf.sprintf "%s/api/v1/video-channels/%s/videos?count=%d&start=%d"

     

       107
       135
        
                     client.base_url channel count start in

     

       108
       108
       -
         get_json_exn client.requests_session url parse_video_response

     

       136
       136
       +
         get_json_exn client.requests_session url video_response_jsont

     

       109
       137
        
       

     

       110
       138
        
       (** Fetch all videos from a PeerTube instance channel using pagination

     

       111
       139
        
           @param page_size Number of videos to fetch per page

     
···

       140
       168
        
       let fetch_video_details client uuid =

     

       141
       169
        
         let open Requests_json_api in

     

       142
       170
        
         let url = client.base_url / "api/v1/videos" / uuid in

     

       143
       143
       -
         get_json_exn client.requests_session url parse_video

     

       171
       171
       +
         get_json_exn client.requests_session url video_jsont

     

       144
       172
        
       

     

       145
       173
        
       (** Convert a PeerTube video to Bushel.Video.t compatible structure *)

     

       146
       174
        
       let to_bushel_video video =

+34 -6

stack/peertubee/peertubee.mli

···

       8
       8
        
           @param base_url Base URL of the PeerTube instance

     

       9
       9
        
           @return A PeerTube client configured for the specified instance *)

     

       10
       10
        
       val create :

     

       11
       11
       -
         requests_session:(float Eio.Time.clock_ty Eio.Resource.t, [`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t ->

     

       11
       11
       +
         requests_session:Requests.t ->

     

       12
       12
        
         base_url:string ->

     

       13
       13
        
         t

     

       14
       14
        
       

     
···

       23
       23
        
         published_at: Ptime.t;

     

       24
       24
        
         originally_published_at: Ptime.t option;

     

       25
       25
        
         thumbnail_path: string option;

     

       26
       26
       -
         tags: string list;

     

       26
       26
       +
         tags: string list option;

     

       27
       27
       +
         unknown: Jsont.json;

     

       27
       28
        
       }

     

       28
       29
        
       

     

       29
       30
        
       (** Type for PeerTube API response containing videos *)

     

       30
       31
        
       type video_response = {

     

       31
       32
        
         total: int;

     

       32
       33
        
         data: video list;

     

       34
       34
       +
         unknown: Jsont.json;

     

       33
       35
        
       }

     

       34
       36
        
       

     

       35
       35
       -
       (** Parse a single video from PeerTube JSON *)

     

       36
       36
       -
       val parse_video : Ezjsonm.value -> video

     

       37
       37
       +
       (** Accessor functions for video *)

     

       38
       38
       +
       val video_id : video -> int

     

       39
       39
       +
       val video_uuid : video -> string

     

       40
       40
       +
       val video_name : video -> string

     

       41
       41
       +
       val video_description : video -> string option

     

       42
       42
       +
       val video_url : video -> string

     

       43
       43
       +
       val video_embed_path : video -> string

     

       44
       44
       +
       val video_published_at : video -> Ptime.t

     

       45
       45
       +
       val video_originally_published_at : video -> Ptime.t option

     

       46
       46
       +
       val video_thumbnail_path : video -> string option

     

       47
       47
       +
       val video_tags : video -> string list option

     

       48
       48
       +
       val video_unknown : video -> Jsont.json

     

       37
       49
        
       

     

       38
       38
       -
       (** Parse a PeerTube video response *)

     

       39
       39
       -
       val parse_video_response : Ezjsonm.value -> video_response

     

       50
       50
       +
       (** Accessor functions for video_response *)

     

       51
       51
       +
       val video_response_total : video_response -> int

     

       52
       52
       +
       val video_response_data : video_response -> video list

     

       53
       53
       +
       val video_response_unknown : video_response -> Jsont.json

     

       54
       54
       +
       

     

       55
       55
       +
       (** RFC3339 timestamp handling *)

     

       56
       56
       +
       module Rfc3339 : sig

     

       57
       57
       +
         val parse : string -> Ptime.t option

     

       58
       58
       +
         val format : Ptime.t -> string

     

       59
       59
       +
         val pp : Format.formatter -> Ptime.t -> unit

     

       60
       60
       +
         val jsont : Ptime.t Jsont.t

     

       61
       61
       +
       end

     

       62
       62
       +
       

     

       63
       63
       +
       (** Parse a single video from JSON string *)

     

       64
       64
       +
       val parse_video_string : string -> video

     

       65
       65
       +
       

     

       66
       66
       +
       (** Parse a PeerTube video response from JSON string *)

     

       67
       67
       +
       val parse_video_response_string : string -> video_response

     

       40
       68
        
       

     

       41
       69
        
       (** Fetch videos from a PeerTube instance channel with pagination support

     

       42
       70
        
           @param client The PeerTube client

-1

stack/peertubee/peertubee.opam

···

       10
       10
        
         "eio"

     

       11
       11
        
         "eio_main" {>= "1.0"}

     

       12
       12
        
         "requests"

     

       13
       13
       -
         "ezjsonm"

     

       14
       13
        
         "fmt"

     

       15
       14
        
         "ptime"

     

       16
       15
        
         "odoc" {with-doc}

+1 -1

stack/requests/bin/dune

···

       1
       1
        
       (executables

     

       2
       2
        
        (public_names ocurl)

     

       3
       3
        
        (names ocurl)

     

       4
       4
       -
        (libraries requests eio_main cmdliner logs logs.cli logs.fmt fmt.cli fmt.tty yojson))

     

       4
       4
       +
        (libraries requests eio_main cmdliner logs logs.cli logs.fmt fmt.cli fmt.tty jsont jsont.bytesrw))

+17 -16

stack/requests/bin/ocurl.ml

···

       51
       51
        
         let doc = "Show progress bar for downloads" in

     

       52
       52
        
         Arg.(value & flag & info ["progress-bar"] ~doc)

     

       53
       53
        
       

     

       54
       54
       -
       let enable_cache =

     

       55
       55
       -
         let doc = "Enable HTTP response caching for GET and HEAD requests" in

     

       56
       56
       -
         let env_info = Cmdliner.Cmd.Env.info "OCURL_ENABLE_CACHE" in

     

       57
       57
       -
         Arg.(value & flag & info ["enable-cache"] ~env:env_info ~doc)

     

       58
       58
       -
       

     

       59
       54
        
       (* Logging setup *)

     

       60
       55
        
       (* Setup logging using Logs_cli for standard logging options *)

     

       61
       56
        
       let setup_log =

     
···

       191
       186
        
               if String.length body_str > 0 &&

     

       192
       187
        
                  (body_str.[0] = '{' || body_str.[0] = '[') then

     

       193
       188
        
                 try

     

       194
       194
       -
                   let json = Yojson.Safe.from_string body_str in

     

       195
       195
       -
                   if not quiet then Fmt.pr "[%s]:@." url_str;

     

       196
       196
       -
                   Fmt.pr "%a@." (Yojson.Safe.pretty_print ~std:true) json

     

       189
       189
       +
                   match Jsont_bytesrw.decode_string' Jsont.json body_str with

     

       190
       190
       +
                   | Ok json ->

     

       191
       191
       +
                       (match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Jsont.json json with

     

       192
       192
       +
                       | Ok pretty ->

     

       193
       193
       +
                           if not quiet then Fmt.pr "[%s]:@." url_str;

     

       194
       194
       +
                           print_string pretty

     

       195
       195
       +
                       | Error _ ->

     

       196
       196
       +
                           if not quiet then Fmt.pr "[%s]:@." url_str;

     

       197
       197
       +
                           print_string body_str)

     

       198
       198
       +
                   | Error _ ->

     

       199
       199
       +
                       if not quiet then Fmt.pr "[%s]:@." url_str;

     

       200
       200
       +
                       print_string body_str

     

       197
       201
        
                 with _ ->

     

       198
       202
        
                   if not quiet then Fmt.pr "[%s]:@." url_str;

     

       199
       203
        
                   print_string body_str

     
···

       214
       218
        
             Error (url_str, exn)

     

       215
       219
        
       

     

       216
       220
        
       (* Main function using Requests with concurrent fetching *)

     

       217
       217
       -
       let run_request env sw persist_cookies verify_tls enable_cache timeout follow_redirects max_redirects

     

       221
       221
       +
       let run_request env sw persist_cookies verify_tls timeout follow_redirects max_redirects

     

       218
       222
        
           method_ urls headers data json_data output include_headers

     

       219
       223
        
           auth _show_progress () =

     

       220
       224
        
       

     
···

       225
       229
        
       

     

       226
       230
        
         (* Create requests instance with configuration *)

     

       227
       231
        
         let timeout_obj = Option.map (fun t -> Requests.Timeout.create ~total:t ()) timeout in

     

       228
       228
       -
         let req = Requests.create ~sw ~xdg ~persist_cookies ~verify_tls ~enable_cache

     

       232
       232
       +
         let req = Requests.create ~sw ~xdg ~persist_cookies ~verify_tls

     

       229
       233
        
           ~follow_redirects ~max_redirects ?timeout:timeout_obj env in

     

       230
       234
        
       

     

       231
       235
        
         (* Set authentication if provided *)

     
···

       306
       310
        
       

     

       307
       311
        
       (* Main entry point *)

     

       308
       312
        
       let main method_ urls headers data json_data output include_headers

     

       309
       309
       -
           auth show_progress persist_cookies verify_tls enable_cache

     

       313
       313
       +
           auth show_progress persist_cookies verify_tls

     

       310
       314
        
           timeout follow_redirects max_redirects () =

     

       311
       315
        
       

     

       312
       316
        
         Eio_main.run @@ fun env ->

     

       313
       317
        
         Mirage_crypto_rng_unix.use_default ();

     

       314
       318
        
         Switch.run @@ fun sw ->

     

       315
       319
        
       

     

       316
       316
       -
         run_request env sw persist_cookies verify_tls enable_cache timeout follow_redirects max_redirects

     

       320
       320
       +
         run_request env sw persist_cookies verify_tls timeout follow_redirects max_redirects

     

       317
       321
        
           method_ urls headers data json_data output include_headers auth

     

       318
       322
        
           show_progress ()

     

       319
       323
        
       

     
···

       342
       346
        
           `P "Custom headers:";

     

       343
       347
        
           `Pre "  $(tname) -H 'Accept: application/json' -H 'X-Api-Key: secret' https://api.example.com";

     

       344
       348
        
           `P "With persistent cookies:";

     

       345
       345
       -
           `Pre "  $(tname) --persist-cookies --cache-dir ~/.ocurl https://example.com";

     

       346
       346
       -
           `P "Enable response caching:";

     

       347
       347
       -
           `Pre "  $(tname) --enable-cache https://api.example.com";

     

       349
       349
       +
           `Pre "  $(tname) --persist-cookies https://example.com";

     

       348
       350
        
           `P "Disable TLS verification (insecure):";

     

       349
       351
        
           `Pre "  $(tname) --no-verify-tls https://self-signed.example.com";

     

       350
       352
        
           `S "LOGGING OPTIONS";

     
···

       374
       376
        
                 show_progress $

     

       375
       377
        
                 Requests.Cmd.persist_cookies_term app_name $

     

       376
       378
        
                 Requests.Cmd.verify_tls_term app_name $

     

       377
       377
       -
                 enable_cache $

     

       378
       379
        
                 Requests.Cmd.timeout_term app_name $

     

       379
       380
        
                 Requests.Cmd.follow_redirects_term app_name $

     

       380
       381
        
                 Requests.Cmd.max_redirects_term app_name $

-1

stack/requests/dune-project

···

       25
       25
        
         ca-certs

     

       26
       26
        
         mirage-crypto-rng-eio

     

       27
       27
        
         uri

     

       28
       28
       -
         yojson

     

       29
       28
        
         digestif

     

       30
       29
        
         base64

     

       31
       30
        
         logs))

+28 -150

stack/requests/lib/body.ml

···

       43
       43
        
           (Eio.Path.native_exn file) (Mime.to_string mime));

     

       44
       44
        
         File { file; mime }

     

       45
       45
        
       

     

       46
       46
       -
       type json =

     

       47
       47
       -
         [ `Null | `Bool of bool | `Float of float | `String of string

     

       48
       48
       -
         | `A of json list | `O of (string * json) list ]

     

       49
       49
       -
       

     

       50
       50
       -
       let json json_value =

     

       51
       51
       -
         (* Encode json value to a JSON string *)

     

       52
       52
       -
         let buffer = Buffer.create 1024 in

     

       53
       53
       -
         let encoder = Jsonm.encoder ~minify:true (`Buffer buffer) in

     

       54
       54
       -
       

     

       55
       55
       -
         let enc e l =

     

       56
       56
       -
           match Jsonm.encode e (`Lexeme l) with

     

       57
       57
       -
           | `Ok -> ()

     

       58
       58
       -
           | `Partial -> failwith "Unexpected partial with buffer destination"

     

       46
       46
       +
       (* For simple JSON encoding, we just take a Jsont.json value and encode it *)

     

       47
       47
       +
       let json (json_value : Jsont.json) =

     

       48
       48
       +
         let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with

     

       49
       49
       +
           | Ok s -> s

     

       50
       50
       +
           | Error e ->

     

       51
       51
       +
               let msg = Jsont.Error.to_string e in

     

       52
       52
       +
               failwith (Printf.sprintf "Failed to encode JSON: %s" msg)

     

       59
       53
        
         in

     

       54
       54
       +
         String { content; mime = Mime.json }

     

       60
       55
        
       

     

       61
       61
       -
         let rec encode_value v k e =

     

       62
       62
       -
           match v with

     

       63
       63
       -
           | `A vs -> encode_array vs k e

     

       64
       64
       -
           | `O ms -> encode_object ms k e

     

       65
       65
       -
           | `Null | `Bool _ | `Float _ | `String _ as v -> enc e v; k e

     

       66
       66
       -
         and encode_array vs k e =

     

       67
       67
       -
           enc e `As;

     

       68
       68
       -
           encode_array_values vs k e

     

       69
       69
       -
         and encode_array_values vs k e =

     

       70
       70
       -
           match vs with

     

       71
       71
       -
           | v :: vs' -> encode_value v (encode_array_values vs' k) e

     

       72
       72
       -
           | [] -> enc e `Ae; k e

     

       73
       73
       -
         and encode_object ms k e =

     

       74
       74
       -
           enc e `Os;

     

       75
       75
       -
           encode_object_members ms k e

     

       76
       76
       -
         and encode_object_members ms k e =

     

       77
       77
       -
           match ms with

     

       78
       78
       -
           | (n, v) :: ms' ->

     

       79
       79
       -
               enc e (`Name n);

     

       80
       80
       -
               encode_value v (encode_object_members ms' k) e

     

       81
       81
       -
           | [] -> enc e `Oe; k e

     

       82
       82
       -
         in

     

       83
       83
       -
       

     

       84
       84
       -
         let finish e =

     

       85
       85
       -
           match Jsonm.encode e `End with

     

       86
       86
       -
           | `Ok -> ()

     

       87
       87
       -
           | `Partial -> failwith "Unexpected partial at end"

     

       88
       88
       -
         in

     

       89
       89
       -
       

     

       90
       90
       -
         encode_value json_value finish encoder;

     

       91
       91
       -
       

     

       92
       92
       -
         String { content = Buffer.contents buffer; mime = Mime.json }

     

       93
       93
       -
       

     

       56
       56
       +
       (* JSON streaming using jsont - we encode the value to string and stream it *)

     

       94
       57
        
       module Json_stream_source = struct

     

       95
       95
       -
         type encode_state =

     

       96
       96
       -
           | Ready              (* Ready to encode new lexemes *)

     

       97
       97
       -
           | NeedAwait          (* Need to send `Await after previous `Partial *)

     

       98
       98
       -
           | Finished           (* All done *)

     

       99
       99
       -
       

     

       100
       58
        
         type t = {

     

       101
       101
       -
           encoder : Jsonm.encoder;

     

       102
       102
       -
           mutable buffer : bytes;

     

       103
       103
       -
           mutable buffer_offset : int;

     

       104
       104
       -
           mutable buffer_len : int;

     

       105
       105
       -
           mutable pending_lexemes : Jsonm.lexeme Queue.t;

     

       106
       106
       -
           mutable encode_state : encode_state;

     

       107
       107
       -
           mutable end_signaled : bool;

     

       108
       108
       -
           writer : (Jsonm.lexeme -> unit) -> unit;

     

       59
       59
       +
           mutable content : string;

     

       60
       60
       +
           mutable offset : int;

     

       109
       61
        
         }

     

       110
       62
        
       

     

       111
       111
       -
         let rec single_read t dst =

     

       112
       112
       -
           if t.encode_state = Finished && t.buffer_offset >= t.buffer_len then

     

       63
       63
       +
         let single_read t dst =

     

       64
       64
       +
           if t.offset >= String.length t.content then

     

       113
       65
        
             raise End_of_file

     

       114
       114
       -
           else if t.buffer_offset < t.buffer_len then begin

     

       115
       115
       -
             (* We have data in buffer to copy *)

     

       116
       116
       -
             let available = t.buffer_len - t.buffer_offset in

     

       66
       66
       +
           else begin

     

       67
       67
       +
             let available = String.length t.content - t.offset in

     

       117
       68
        
             let to_copy = min (Cstruct.length dst) available in

     

       118
       118
       -
             Cstruct.blit_from_bytes t.buffer t.buffer_offset dst 0 to_copy;

     

       119
       119
       -
             t.buffer_offset <- t.buffer_offset + to_copy;

     

       69
       69
       +
             Cstruct.blit_from_string t.content t.offset dst 0 to_copy;

     

       70
       70
       +
             t.offset <- t.offset + to_copy;

     

       120
       71
        
             to_copy

     

       121
       121
       -
           end else begin

     

       122
       122
       -
             (* Buffer empty, need to generate more data *)

     

       123
       123
       -
             t.buffer_offset <- 0;

     

       124
       124
       -
             t.buffer_len <- 0;

     

       125
       125
       -
             Jsonm.Manual.dst t.encoder t.buffer 0 (Bytes.length t.buffer);

     

       126
       126
       -
       

     

       127
       127
       -
             let rec process_encoding () =

     

       128
       128
       -
               match t.encode_state with

     

       129
       129
       -
               | NeedAwait ->

     

       130
       130
       -
                   (* Send `Await after previous `Partial *)

     

       131
       131
       -
                   (match Jsonm.encode t.encoder `Await with

     

       132
       132
       -
                    | `Ok ->

     

       133
       133
       -
                        t.encode_state <- Ready;

     

       134
       134
       -
                        process_encoding ()

     

       135
       135
       -
                    | `Partial ->

     

       136
       136
       -
                        t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)

     

       137
       137
       -
               | Ready when not (Queue.is_empty t.pending_lexemes) ->

     

       138
       138
       -
                   (* Encode next lexeme *)

     

       139
       139
       -
                   let lexeme = Queue.take t.pending_lexemes in

     

       140
       140
       -
                   (match Jsonm.encode t.encoder (`Lexeme lexeme) with

     

       141
       141
       -
                    | `Ok ->

     

       142
       142
       -
                        (* Successfully encoded, continue with next *)

     

       143
       143
       -
                        process_encoding ()

     

       144
       144
       -
                    | `Partial ->

     

       145
       145
       -
                        (* Buffer full, need to flush and await

     

       146
       146
       -
                           Note: The lexeme is partially encoded in the encoder's internal state,

     

       147
       147
       -
                           we don't need to re-queue it. After `Await, the encoder continues. *)

     

       148
       148
       -
                        t.encode_state <- NeedAwait;

     

       149
       149
       -
                        t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)

     

       150
       150
       -
               | Ready when Queue.is_empty t.pending_lexemes && not t.end_signaled ->

     

       151
       151
       -
                   (* All lexemes done, signal end *)

     

       152
       152
       -
                   t.end_signaled <- true;

     

       153
       153
       -
                   (match Jsonm.encode t.encoder `End with

     

       154
       154
       -
                    | `Ok ->

     

       155
       155
       -
                        t.encode_state <- Finished;

     

       156
       156
       -
                        t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder

     

       157
       157
       -
                    | `Partial ->

     

       158
       158
       -
                        t.encode_state <- NeedAwait;

     

       159
       159
       -
                        t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)

     

       160
       160
       -
               | Ready when t.end_signaled ->

     

       161
       161
       -
                   (* Continue trying to finish *)

     

       162
       162
       -
                   (match Jsonm.encode t.encoder `End with

     

       163
       163
       -
                    | `Ok ->

     

       164
       164
       -
                        t.encode_state <- Finished;

     

       165
       165
       -
                        t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder

     

       166
       166
       -
                    | `Partial ->

     

       167
       167
       -
                        t.encode_state <- NeedAwait;

     

       168
       168
       -
                        t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)

     

       169
       169
       -
               | Finished ->

     

       170
       170
       -
                   (* All done *)

     

       171
       171
       -
                   ()

     

       172
       172
       -
               | _ -> ()

     

       173
       173
       -
             in

     

       174
       174
       -
             process_encoding ();

     

       175
       175
       -
       

     

       176
       176
       -
             if t.buffer_len > 0 then

     

       177
       177
       -
               single_read t dst

     

       178
       178
       -
             else if t.encode_state = Finished then

     

       179
       179
       -
               raise End_of_file

     

       180
       180
       -
             else

     

       181
       181
       -
               (* This shouldn't happen - we should always produce some data or be finished *)

     

       182
       182
       -
               raise End_of_file

     

       183
       72
        
           end

     

       184
       73
        
       

     

       185
       74
        
         let read_methods = []

     

       186
       75
        
       end

     

       187
       76
        
       

     

       188
       188
       -
       let json_stream_source_create writer =

     

       189
       189
       -
         let buffer_size = 4096 in

     

       190
       190
       -
         let buffer = Bytes.create buffer_size in

     

       191
       191
       -
         let encoder = Jsonm.encoder ~minify:true (`Manual) in

     

       192
       192
       -
         let pending_lexemes = Queue.create () in

     

       193
       193
       -
       

     

       194
       194
       -
         (* Call the writer to populate the queue *)

     

       195
       195
       -
         let encode_lexeme lexeme = Queue.add lexeme pending_lexemes in

     

       196
       196
       -
         writer encode_lexeme;

     

       197
       197
       -
       

     

       198
       198
       -
         let t = {

     

       199
       199
       -
           Json_stream_source.encoder;

     

       200
       200
       -
           buffer;

     

       201
       201
       -
           buffer_offset = 0;

     

       202
       202
       -
           buffer_len = 0;

     

       203
       203
       -
           pending_lexemes;

     

       204
       204
       -
           encode_state = Ready;

     

       205
       205
       -
           end_signaled = false;

     

       206
       206
       -
           writer;

     

       207
       207
       -
         } in

     

       77
       77
       +
       let json_stream_source_create json_value =

     

       78
       78
       +
         (* Encode the entire JSON value to string with minified format *)

     

       79
       79
       +
         let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with

     

       80
       80
       +
           | Ok s -> s

     

       81
       81
       +
           | Error e ->

     

       82
       82
       +
               let msg = Jsont.Error.to_string e in

     

       83
       83
       +
               failwith (Printf.sprintf "Failed to encode JSON stream: %s" msg)

     

       84
       84
       +
         in

     

       85
       85
       +
         let t = { Json_stream_source.content; offset = 0 } in

     

       208
       86
        
         let ops = Eio.Flow.Pi.source (module Json_stream_source) in

     

       209
       87
        
         Eio.Resource.T (t, ops)

     

       210
       88
        
       

     

       211
       211
       -
       let json_stream writer =

     

       212
       212
       -
         let source = json_stream_source_create writer in

     

       89
       89
       +
       let json_stream json_value =

     

       90
       90
       +
         let source = json_stream_source_create json_value in

     

       213
       91
        
         Stream { source; mime = Mime.json; length = None }

     

       214
       92
        
       

     

       215
       93
        
       let text content =

+14 -31

stack/requests/lib/body.mli

···

       58
       58
        
       

     

       59
       59
        
       (** {1 Convenience Constructors} *)

     

       60
       60
        
       

     

       61
       61
       -
       type json =

     

       62
       62
       -
         [ `Null | `Bool of bool | `Float of float | `String of string

     

       63
       63
       -
         | `A of json list | `O of (string * json) list ]

     

       64
       64
       -
       (** JSON value representation, compatible with Jsonm's json type. *)

     

       65
       65
       -
       

     

       66
       66
       -
       val json : json -> t

     

       67
       67
       -
       (** [json value] creates a JSON body from a json value.

     

       61
       61
       +
       val json : Jsont.json -> t

     

       62
       62
       +
       (** [json value] creates a JSON body from a Jsont.json value.

     

       68
       63
        
           The value is encoded to a JSON string with Content-Type: application/json.

     

       69
       64
        
       

     

       70
       65
        
           Example:

     

       71
       66
        
           {[

     

       72
       72
       -
             let body = Body.json (`O [

     

       73
       73
       -
               ("status", `String "success");

     

       74
       74
       -
               ("count", `Float 42.);

     

       75
       75
       -
               ("items", `A [`String "first"; `String "second"])

     

       76
       76
       -
             ])

     

       67
       67
       +
             let body = Body.json (Jsont.Object ([

     

       68
       68
       +
               ("status", Jsont.String "success");

     

       69
       69
       +
               ("count", Jsont.Number 42.);

     

       70
       70
       +
               ("items", Jsont.Array ([Jsont.String "first"; Jsont.String "second"], Jsont.Meta.none))

     

       71
       71
       +
             ], Jsont.Meta.none))

     

       77
       72
        
           ]}

     

       78
       73
        
       *)

     

       79
       74
        
       

     

       80
       80
       -
       val json_stream : ((Jsonm.lexeme -> unit) -> unit) -> t

     

       81
       81
       -
       (** [json_stream writer] creates a streaming JSON body using jsonm.

     

       82
       82
       -
           The [writer] function is called with a callback that accepts jsonm lexemes

     

       83
       83
       -
           to encode. The body will be streamed as the lexemes are produced.

     

       75
       75
       +
       val json_stream : Jsont.json -> t

     

       76
       76
       +
       (** [json_stream json_value] creates a streaming JSON body from a Jsont.json value.

     

       77
       77
       +
           The JSON value will be encoded to a minified JSON string and streamed.

     

       84
       78
        
       

     

       85
       79
        
           Example:

     

       86
       80
        
           {[

     

       87
       87
       -
             let body = Body.json_stream (fun encode ->

     

       88
       88
       -
               encode `Os;  (* Start object *)

     

       89
       89
       -
               encode (`Name "users");

     

       90
       90
       -
               encode `As;  (* Start array *)

     

       91
       91
       -
               List.iter (fun user ->

     

       92
       92
       -
                 encode `Os;

     

       93
       93
       -
                 encode (`Name "id");

     

       94
       94
       -
                 encode (`Float (float_of_int user.id));

     

       95
       95
       -
                 encode (`Name "name");

     

       96
       96
       -
                 encode (`String user.name);

     

       97
       97
       -
                 encode `Oe  (* End object *)

     

       98
       98
       -
               ) users;

     

       99
       99
       -
               encode `Ae;  (* End array *)

     

       100
       100
       -
               encode `Oe   (* End object *)

     

       101
       101
       -
             )

     

       81
       81
       +
             let large_data = Jsont.Object ([

     

       82
       82
       +
               ("users", Jsont.Array ([...], Jsont.Meta.none))

     

       83
       83
       +
             ], Jsont.Meta.none) in

     

       84
       84
       +
             let body = Body.json_stream large_data

     

       102
       85
        
           ]}

     

       103
       86
        
       *)

     

       104
       87

-420

stack/requests/lib/cache.ml

···

       1
       1
       -
       let src = Logs.Src.create "requests.cache" ~doc:"HTTP cache with cacheio"

     

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

     

       3
       3
       -
       

     

       4
       4
       -
       type cached_response = {

     

       5
       5
       -
         status : Cohttp.Code.status_code;

     

       6
       6
       -
         headers : Cohttp.Header.t;

     

       7
       7
       -
         body : string;

     

       8
       8
       -
       }

     

       9
       9
       -
       

     

       10
       10
       -
       type t = {

     

       11
       11
       -
         sw : Eio.Switch.t;

     

       12
       12
       -
         enabled : bool;

     

       13
       13
       -
         cache_get_requests : bool;

     

       14
       14
       -
         cache_range_requests : bool;

     

       15
       15
       -
         cacheio : Cacheio.t option;

     

       16
       16
       -
         memory_cache : (string, cached_response * float) Hashtbl.t;

     

       17
       17
       -
       }

     

       18
       18
       -
       

     

       19
       19
       -
       let create ~sw ~enabled ?(cache_get_requests=true) ?(cache_range_requests=true) ~cache_dir () =

     

       20
       20
       -
         let cacheio =

     

       21
       21
       -
           match cache_dir with

     

       22
       22
       -
           | Some dir when enabled ->

     

       23
       23
       -
               (try

     

       24
       24
       -
                 Some (Cacheio.create ~base_dir:dir)

     

       25
       25
       -
               with e ->

     

       26
       26
       -
                 Log.warn (fun m -> m "Failed to create cacheio backend: %s. Using memory cache only."

     

       27
       27
       -
                   (Printexc.to_string e));

     

       28
       28
       -
                 None)

     

       29
       29
       -
           | _ -> None

     

       30
       30
       -
         in

     

       31
       31
       -
         { sw; enabled; cache_get_requests; cache_range_requests; cacheio;

     

       32
       32
       -
           memory_cache = Hashtbl.create 100 }

     

       33
       33
       -
       

     

       34
       34
       -
       let make_cache_key ~method_ ~url ~headers =

     

       35
       35
       -
         let method_str = match method_ with

     

       36
       36
       -
           | `GET -> "GET" | `HEAD -> "HEAD"

     

       37
       37
       -
           | _ -> "OTHER"

     

       38
       38
       -
         in

     

       39
       39
       -
         let url_str = Uri.to_string url in

     

       40
       40
       -
         let range_str = match Cohttp.Header.get headers "range" with

     

       41
       41
       -
           | Some r -> "_range:" ^ r

     

       42
       42
       -
           | None -> ""

     

       43
       43
       -
         in

     

       44
       44
       -
         Printf.sprintf "%s_%s%s" method_str url_str range_str

     

       45
       45
       -
       

     

       46
       46
       -
       let is_cacheable ~method_ ~status ~headers =

     

       47
       47
       -
         match method_ with

     

       48
       48
       -
         | `GET | `HEAD ->

     

       49
       49
       -
             let code = Cohttp.Code.code_of_status status in

     

       50
       50
       -
             if code >= 200 && code < 300 then

     

       51
       51
       -
               match Cohttp.Header.get headers "cache-control" with

     

       52
       52
       -
               | Some cc ->

     

       53
       53
       -
                   let cc_lower = String.lowercase_ascii cc in

     

       54
       54
       -
                   let rec contains s sub pos =

     

       55
       55
       -
                     if pos + String.length sub > String.length s then false

     

       56
       56
       -
                     else if String.sub s pos (String.length sub) = sub then true

     

       57
       57
       -
                     else contains s sub (pos + 1)

     

       58
       58
       -
                   in

     

       59
       59
       -
                   not (contains cc_lower "no-store" 0 ||

     

       60
       60
       -
                        contains cc_lower "no-cache" 0 ||

     

       61
       61
       -
                        contains cc_lower "private" 0)

     

       62
       62
       -
               | None -> true

     

       63
       63
       -
             else

     

       64
       64
       -
               code = 301 || code = 308

     

       65
       65
       -
         | _ -> false

     

       66
       66
       -
       

     

       67
       67
       -
       let parse_max_age headers =

     

       68
       68
       -
         match Cohttp.Header.get headers "cache-control" with

     

       69
       69
       -
         | Some cc ->

     

       70
       70
       -
             let parts = String.split_on_char ',' cc |> List.map String.trim in

     

       71
       71
       -
             List.find_map (fun part ->

     

       72
       72
       -
               let prefix = "max-age=" in

     

       73
       73
       -
               if String.starts_with ~prefix part then

     

       74
       74
       -
                 let value = String.sub part (String.length prefix)

     

       75
       75
       -
                               (String.length part - String.length prefix) in

     

       76
       76
       -
                 try Some (float_of_string value) with _ -> None

     

       77
       77
       -
               else None

     

       78
       78
       -
             ) parts

     

       79
       79
       -
         | None -> None

     

       80
       80
       -
       

     

       81
       81
       -
       let serialize_metadata ~status ~headers =

     

       82
       82
       -
         let status_code = Cohttp.Code.code_of_status status in

     

       83
       83
       -
         let headers_assoc = Cohttp.Header.to_list headers in

     

       84
       84
       -
         let json = `Assoc [

     

       85
       85
       -
           ("status_code", `Int status_code);

     

       86
       86
       -
           ("headers", `Assoc (List.map (fun (k, v) -> (k, `String v)) headers_assoc));

     

       87
       87
       -
         ] in

     

       88
       88
       -
         Yojson.Basic.to_string json

     

       89
       89
       -
       

     

       90
       90
       -
       let deserialize_metadata json_str =

     

       91
       91
       -
         try

     

       92
       92
       -
           let open Yojson.Basic.Util in

     

       93
       93
       -
           let json = Yojson.Basic.from_string json_str in

     

       94
       94
       -
           let status_code = json |> member "status_code" |> to_int in

     

       95
       95
       -
           let status = Cohttp.Code.status_of_code status_code in

     

       96
       96
       -
           let headers_json = json |> member "headers" |> to_assoc in

     

       97
       97
       -
           let headers = headers_json

     

       98
       98
       -
             |> List.map (fun (k, v) -> (k, to_string v))

     

       99
       99
       -
             |> Cohttp.Header.of_list in

     

       100
       100
       -
           Some (status, headers)

     

       101
       101
       -
         with _ -> None

     

       102
       102
       -
       

     

       103
       103
       -
       let get t ~method_ ~url ~headers =

     

       104
       104
       -
         if not t.enabled then None

     

       105
       105
       -
         else if method_ = `GET && not t.cache_get_requests then None

     

       106
       106
       -
         else

     

       107
       107
       -
           let key = make_cache_key ~method_ ~url ~headers in

     

       108
       108
       -
       

     

       109
       109
       -
           (* Try cacheio first *)

     

       110
       110
       -
           match t.cacheio with

     

       111
       111
       -
           | Some cache ->

     

       112
       112
       -
               (* Check for metadata entry *)

     

       113
       113
       -
               let metadata_key = key ^ ".meta" in

     

       114
       114
       -
               let body_key = key ^ ".body" in

     

       115
       115
       -
       

     

       116
       116
       -
               if Cacheio.exists cache ~key:metadata_key && Cacheio.exists cache ~key:body_key then

     

       117
       117
       -
                 Eio.Switch.run @@ fun sw ->

     

       118
       118
       -
                 (* Read metadata *)

     

       119
       119
       -
                 let metadata_opt = match Cacheio.get cache ~key:metadata_key ~sw with

     

       120
       120
       -
                   | Some source ->

     

       121
       121
       -
                       let buf = Buffer.create 256 in

     

       122
       122
       -
                       Eio.Flow.copy source (Eio.Flow.buffer_sink buf);

     

       123
       123
       -
                       deserialize_metadata (Buffer.contents buf)

     

       124
       124
       -
                   | None -> None

     

       125
       125
       -
                 in

     

       126
       126
       -
       

     

       127
       127
       -
                 (match metadata_opt with

     

       128
       128
       -
                  | Some (status, resp_headers) ->

     

       129
       129
       -
                      (* Read body *)

     

       130
       130
       -
                      (match Cacheio.get cache ~key:body_key ~sw with

     

       131
       131
       -
                       | Some source ->

     

       132
       132
       -
                           let buf = Buffer.create 4096 in

     

       133
       133
       -
                           Eio.Flow.copy source (Eio.Flow.buffer_sink buf);

     

       134
       134
       -
                           let body = Buffer.contents buf in

     

       135
       135
       -
                           Log.debug (fun m -> m "Cache hit for %s" (Uri.to_string url));

     

       136
       136
       -
                           Some { status; headers = resp_headers; body }

     

       137
       137
       -
                       | None ->

     

       138
       138
       -
                           Log.debug (fun m -> m "Cache body missing for %s" (Uri.to_string url));

     

       139
       139
       -
                           None)

     

       140
       140
       -
                  | None ->

     

       141
       141
       -
                      Log.debug (fun m -> m "Cache metadata missing for %s" (Uri.to_string url));

     

       142
       142
       -
                      None)

     

       143
       143
       -
               else

     

       144
       144
       -
                 (Log.debug (fun m -> m "Cache miss for %s" (Uri.to_string url));

     

       145
       145
       -
                  None)

     

       146
       146
       -
           | None ->

     

       147
       147
       -
               (* Fall back to memory cache *)

     

       148
       148
       -
               match Hashtbl.find_opt t.memory_cache key with

     

       149
       149
       -
               | Some (response, expiry) when expiry > Unix.gettimeofday () ->

     

       150
       150
       -
                   Log.debug (fun m -> m "Memory cache hit for %s" (Uri.to_string url));

     

       151
       151
       -
                   Some response

     

       152
       152
       -
               | _ ->

     

       153
       153
       -
                   Log.debug (fun m -> m "Cache miss for %s" (Uri.to_string url));

     

       154
       154
       -
                   None

     

       155
       155
       -
       

     

       156
       156
       -
       let get_stream t ~method_ ~url ~headers ~sw =

     

       157
       157
       -
         if not t.enabled then None

     

       158
       158
       -
         else if method_ = `GET && not t.cache_get_requests then None

     

       159
       159
       -
         else

     

       160
       160
       -
           let key = make_cache_key ~method_ ~url ~headers in

     

       161
       161
       -
       

     

       162
       162
       -
           match t.cacheio with

     

       163
       163
       -
           | Some cache ->

     

       164
       164
       -
               let metadata_key = key ^ ".meta" in

     

       165
       165
       -
               let body_key = key ^ ".body" in

     

       166
       166
       -
       

     

       167
       167
       -
               if Cacheio.exists cache ~key:metadata_key && Cacheio.exists cache ~key:body_key then

     

       168
       168
       -
                 (* Read metadata first *)

     

       169
       169
       -
                 let metadata_opt =

     

       170
       170
       -
                   match Cacheio.get cache ~key:metadata_key ~sw with

     

       171
       171
       -
                   | Some source ->

     

       172
       172
       -
                       let buf = Buffer.create 256 in

     

       173
       173
       -
                       Eio.Flow.copy source (Eio.Flow.buffer_sink buf);

     

       174
       174
       -
                       deserialize_metadata (Buffer.contents buf)

     

       175
       175
       -
                   | None -> None

     

       176
       176
       -
                 in

     

       177
       177
       -
       

     

       178
       178
       -
                 (match metadata_opt with

     

       179
       179
       -
                  | Some (status, resp_headers) ->

     

       180
       180
       -
                      (* Return body stream directly *)

     

       181
       181
       -
                      (match Cacheio.get cache ~key:body_key ~sw with

     

       182
       182
       -
                       | Some source ->

     

       183
       183
       -
                           Log.debug (fun m -> m "Streaming cache hit for %s" (Uri.to_string url));

     

       184
       184
       -
                           Some (status, resp_headers, source)

     

       185
       185
       -
                       | None -> None)

     

       186
       186
       -
                  | None -> None)

     

       187
       187
       -
               else None

     

       188
       188
       -
           | None -> None

     

       189
       189
       -
       

     

       190
       190
       -
       let put t ~method_ ~url ~request_headers ~status ~headers ~body =

     

       191
       191
       -
         if not t.enabled then ()

     

       192
       192
       -
         else if is_cacheable ~method_ ~status ~headers then

     

       193
       193
       -
           let key = make_cache_key ~method_ ~url ~headers:request_headers in

     

       194
       194
       -
           let ttl = parse_max_age headers in

     

       195
       195
       -
       

     

       196
       196
       -
           Log.debug (fun m -> m "Caching response for %s (ttl: %s)"

     

       197
       197
       -
             (Uri.to_string url)

     

       198
       198
       -
             (match ttl with Some t -> Printf.sprintf "%.0fs" t | None -> "3600s"));

     

       199
       199
       -
       

     

       200
       200
       -
           (match t.cacheio with

     

       201
       201
       -
            | Some cache ->

     

       202
       202
       -
                Eio.Switch.run @@ fun _sw ->

     

       203
       203
       -
                let metadata_key = key ^ ".meta" in

     

       204
       204
       -
                let metadata = serialize_metadata ~status ~headers in

     

       205
       205
       -
                let metadata_source = Eio.Flow.string_source metadata in

     

       206
       206
       -
                Cacheio.put cache ~key:metadata_key ~source:metadata_source ~ttl ();

     

       207
       207
       -
       

     

       208
       208
       -
                let body_key = key ^ ".body" in

     

       209
       209
       -
                let body_source = Eio.Flow.string_source body in

     

       210
       210
       -
                Cacheio.put cache ~key:body_key ~source:body_source ~ttl ()

     

       211
       211
       -
            | None -> ());

     

       212
       212
       -
       

     

       213
       213
       -
           let cached_resp = { status; headers; body } in

     

       214
       214
       -
           let expiry = Unix.gettimeofday () +. Option.value ttl ~default:3600.0 in

     

       215
       215
       -
           Hashtbl.replace t.memory_cache key (cached_resp, expiry)

     

       216
       216
       -
       

     

       217
       217
       -
       let put_stream t ~method_ ~url ~request_headers ~status ~headers ~body_source ~ttl =

     

       218
       218
       -
         if not t.enabled then ()

     

       219
       219
       -
         else if is_cacheable ~method_ ~status ~headers then

     

       220
       220
       -
           let key = make_cache_key ~method_ ~url ~headers:request_headers in

     

       221
       221
       -
       

     

       222
       222
       -
           Log.debug (fun m -> m "Caching streamed response for %s (ttl: %s)"

     

       223
       223
       -
             (Uri.to_string url)

     

       224
       224
       -
             (match ttl with Some t -> Printf.sprintf "%.0fs" t | None -> "3600s"));

     

       225
       225
       -
       

     

       226
       226
       -
           match t.cacheio with

     

       227
       227
       -
           | Some cache ->

     

       228
       228
       -
               Eio.Switch.run @@ fun _sw ->

     

       229
       229
       -
       

     

       230
       230
       -
               (* Store metadata *)

     

       231
       231
       -
               let metadata_key = key ^ ".meta" in

     

       232
       232
       -
               let metadata = serialize_metadata ~status ~headers in

     

       233
       233
       -
               let metadata_source = Eio.Flow.string_source metadata in

     

       234
       234
       -
               Cacheio.put cache ~key:metadata_key ~source:metadata_source ~ttl ();

     

       235
       235
       -
       

     

       236
       236
       -
               (* Store body directly from source *)

     

       237
       237
       -
               let body_key = key ^ ".body" in

     

       238
       238
       -
               Cacheio.put cache ~key:body_key ~source:body_source ~ttl ()

     

       239
       239
       -
           | None -> ()

     

       240
       240
       -
       

     

       241
       241
       -
       module Range = struct

     

       242
       242
       -
         type t = {

     

       243
       243
       -
           start : int64;

     

       244
       244
       -
           end_ : int64 option;  (* None means to end of file *)

     

       245
       245
       -
         }

     

       246
       246
       -
       

     

       247
       247
       -
         let of_header header =

     

       248
       248
       -
           (* Parse Range: bytes=start-end *)

     

       249
       249
       -
           let prefix = "bytes=" in

     

       250
       250
       -
           let prefix_len = String.length prefix in

     

       251
       251
       -
           if String.length header >= prefix_len &&

     

       252
       252
       -
              String.sub header 0 prefix_len = prefix then

     

       253
       253
       -
             let range_str = String.sub header prefix_len (String.length header - prefix_len) in

     

       254
       254
       -
             match String.split_on_char '-' range_str with

     

       255
       255
       -
             | [start; ""] ->

     

       256
       256
       -
                 (* bytes=N- means from N to end *)

     

       257
       257
       -
                 (try Some { start = Int64.of_string start; end_ = None }

     

       258
       258
       -
                  with _ -> None)

     

       259
       259
       -
             | [start; end_] ->

     

       260
       260
       -
                 (* bytes=N-M *)

     

       261
       261
       -
                 (try Some {

     

       262
       262
       -
                   start = Int64.of_string start;

     

       263
       263
       -
                   end_ = Some (Int64.of_string end_)

     

       264
       264
       -
                 }

     

       265
       265
       -
                  with _ -> None)

     

       266
       266
       -
             | _ -> None

     

       267
       267
       -
           else None

     

       268
       268
       -
       

     

       269
       269
       -
         let to_header t =

     

       270
       270
       -
           match t.end_ with

     

       271
       271
       -
           | None -> Printf.sprintf "bytes=%Ld-" t.start

     

       272
       272
       -
           | Some e -> Printf.sprintf "bytes=%Ld-%Ld" t.start e

     

       273
       273
       -
       

     

       274
       274
       -
         let to_cacheio_range t ~total_size =

     

       275
       275
       -
           let end_ = match t.end_ with

     

       276
       276
       -
             | None -> Int64.pred total_size

     

       277
       277
       -
             | Some e -> min e (Int64.pred total_size)

     

       278
       278
       -
           in

     

       279
       279
       -
           (* Convert to Cacheio.Range.t *)

     

       280
       280
       -
           Cacheio.Range.create ~start:t.start ~end_

     

       281
       281
       -
       end

     

       282
       282
       -
       

     

       283
       283
       -
       let download_range t ~sw ~url ~range ~on_chunk =

     

       284
       284
       -
         let range_header = Range.to_header range in

     

       285
       285
       -
         Log.debug (fun m -> m "Range request for %s: %s"

     

       286
       286
       -
           (Uri.to_string url) range_header);

     

       287
       287
       -
       

     

       288
       288
       -
         match t.cacheio with

     

       289
       289
       -
         | Some cache ->

     

       290
       290
       -
             let key = Uri.to_string url in

     

       291
       291
       -
             let cacheio_range = Range.to_cacheio_range range ~total_size:Int64.max_int in

     

       292
       292
       -
       

     

       293
       293
       -
             (match Cacheio.get_range cache ~key ~range:cacheio_range ~sw with

     

       294
       294
       -
              | `Complete source ->

     

       295
       295
       -
                  let rec read_chunks () =

     

       296
       296
       -
                    let chunk = Cstruct.create 8192 in

     

       297
       297
       -
                    try

     

       298
       298
       -
                      let n = Eio.Flow.single_read source chunk in

     

       299
       299
       -
                      if n > 0 then begin

     

       300
       300
       -
                        on_chunk (Cstruct.to_string ~off:0 ~len:n chunk);

     

       301
       301
       -
                        read_chunks ()

     

       302
       302
       -
                      end

     

       303
       303
       -
                    with End_of_file -> ()

     

       304
       304
       -
                  in

     

       305
       305
       -
                  read_chunks ();

     

       306
       306
       -
                  Some true

     

       307
       307
       -
              | `Chunks chunk_sources ->

     

       308
       308
       -
                  List.iter (fun (_range, source) ->

     

       309
       309
       -
                    let rec read_chunk () =

     

       310
       310
       -
                      let chunk = Cstruct.create 8192 in

     

       311
       311
       -
                      try

     

       312
       312
       -
                        let n = Eio.Flow.single_read source chunk in

     

       313
       313
       -
                        if n > 0 then begin

     

       314
       314
       -
                          on_chunk (Cstruct.to_string ~off:0 ~len:n chunk);

     

       315
       315
       -
                          read_chunk ()

     

       316
       316
       -
                        end

     

       317
       317
       -
                      with End_of_file -> ()

     

       318
       318
       -
                    in

     

       319
       319
       -
                    read_chunk ()

     

       320
       320
       -
                  ) chunk_sources;

     

       321
       321
       -
                  Some true

     

       322
       322
       -
              | `Not_found -> None)

     

       323
       323
       -
         | None -> None

     

       324
       324
       -
       

     

       325
       325
       -
       let put_chunk t ~url ~range ~data =

     

       326
       326
       -
         if not t.enabled || not t.cache_range_requests then ()

     

       327
       327
       -
         else

     

       328
       328
       -
           match t.cacheio with

     

       329
       329
       -
           | Some cache ->

     

       330
       330
       -
               let key = Uri.to_string url in

     

       331
       331
       -
               let cacheio_range = Range.to_cacheio_range range ~total_size:Int64.max_int in

     

       332
       332
       -
               Eio.Switch.run @@ fun _sw ->

     

       333
       333
       -
               let source = Eio.Flow.string_source data in

     

       334
       334
       -
               Cacheio.put_chunk cache ~key ~range:cacheio_range ~source ()

     

       335
       335
       -
           | None ->

     

       336
       336
       -
               Log.debug (fun m -> m "Cannot cache chunk for %s: no cacheio backend"

     

       337
       337
       -
                 (Uri.to_string url))

     

       338
       338
       -
       

     

       339
       339
       -
       let has_complete t ~url ~total_size =

     

       340
       340
       -
         if not t.enabled then false

     

       341
       341
       -
         else

     

       342
       342
       -
           match t.cacheio with

     

       343
       343
       -
           | Some cache ->

     

       344
       344
       -
               let key = Uri.to_string url in

     

       345
       345
       -
               Cacheio.has_complete_chunks cache ~key ~total_size

     

       346
       346
       -
           | None -> false

     

       347
       347
       -
       

     

       348
       348
       -
       let missing_ranges t ~url ~total_size =

     

       349
       349
       -
         if not t.enabled then

     

       350
       350
       -
           [{ Range.start = 0L; end_ = Some (Int64.pred total_size) }]

     

       351
       351
       -
         else

     

       352
       352
       -
           match t.cacheio with

     

       353
       353
       -
           | Some cache ->

     

       354
       354
       -
               let key = Uri.to_string url in

     

       355
       355
       -
               let cacheio_ranges = Cacheio.missing_ranges cache ~key ~total_size in

     

       356
       356
       -
               List.map (fun r ->

     

       357
       357
       -
                 { Range.start = Cacheio.Range.start r;

     

       358
       358
       -
                   end_ = Some (Cacheio.Range.end_ r) }

     

       359
       359
       -
               ) cacheio_ranges

     

       360
       360
       -
           | None ->

     

       361
       361
       -
               [{ Range.start = 0L; end_ = Some (Int64.pred total_size) }]

     

       362
       362
       -
       

     

       363
       363
       -
       let coalesce_chunks t ~url =

     

       364
       364
       -
         if not t.enabled then false

     

       365
       365
       -
         else

     

       366
       366
       -
           match t.cacheio with

     

       367
       367
       -
           | Some cache ->

     

       368
       368
       -
               let key = Uri.to_string url in

     

       369
       369
       -
               let promise = Cacheio.coalesce_chunks cache ~key ~verify:true () in

     

       370
       370
       -
               (match Eio.Promise.await promise with

     

       371
       371
       -
                | Ok () ->

     

       372
       372
       -
                    Log.info (fun m -> m "Successfully coalesced chunks for %s" key);

     

       373
       373
       -
                    true

     

       374
       374
       -
                | Error exn ->

     

       375
       375
       -
                    Log.warn (fun m -> m "Failed to coalesce chunks for %s: %s"

     

       376
       376
       -
                      key (Printexc.to_string exn));

     

       377
       377
       -
                    false)

     

       378
       378
       -
           | None -> false

     

       379
       379
       -
       

     

       380
       380
       -
       let evict t ~url =

     

       381
       381
       -
         if not t.enabled then ()

     

       382
       382
       -
         else

     

       383
       383
       -
           let key = make_cache_key ~method_:`GET ~url ~headers:(Cohttp.Header.init ()) in

     

       384
       384
       -
           (match t.cacheio with

     

       385
       385
       -
            | Some cache ->

     

       386
       386
       -
                Cacheio.delete cache ~key:(key ^ ".meta");

     

       387
       387
       -
                Cacheio.delete cache ~key:(key ^ ".body")

     

       388
       388
       -
            | None -> ());

     

       389
       389
       -
           Log.debug (fun m -> m "Evicting cache for %s" (Uri.to_string url));

     

       390
       390
       -
           Hashtbl.remove t.memory_cache key

     

       391
       391
       -
       

     

       392
       392
       -
       let clear t =

     

       393
       393
       -
         Log.info (fun m -> m "Clearing entire cache");

     

       394
       394
       -
         (match t.cacheio with

     

       395
       395
       -
          | Some cache -> Cacheio.clear cache

     

       396
       396
       -
          | None -> ());

     

       397
       397
       -
         Hashtbl.clear t.memory_cache

     

       398
       398
       -
       

     

       399
       399
       -
       let stats t =

     

       400
       400
       -
         let cacheio_stats =

     

       401
       401
       -
           match t.cacheio with

     

       402
       402
       -
           | Some cache ->

     

       403
       403
       -
               let stats = Cacheio.stats cache in

     

       404
       404
       -
               `Assoc [

     

       405
       405
       -
                 ("total_entries", `Int (Cacheio.Stats.entry_count stats));

     

       406
       406
       -
                 ("total_bytes", `Int (Int64.to_int (Cacheio.Stats.total_size stats)));

     

       407
       407
       -
                 ("expired_entries", `Int (Cacheio.Stats.expired_count stats));

     

       408
       408
       -
                 ("pinned_entries", `Int (Cacheio.Stats.pinned_count stats));

     

       409
       409
       -
                 ("temporary_entries", `Int (Cacheio.Stats.temporary_count stats));

     

       410
       410
       -
               ]

     

       411
       411
       -
           | None -> `Assoc []

     

       412
       412
       -
         in

     

       413
       413
       -
         `Assoc [

     

       414
       414
       -
           ("memory_cache_entries", `Int (Hashtbl.length t.memory_cache));

     

       415
       415
       -
           ("cache_backend", `String (if Option.is_some t.cacheio then "cacheio" else "memory"));

     

       416
       416
       -
           ("enabled", `Bool t.enabled);

     

       417
       417
       -
           ("cache_get_requests", `Bool t.cache_get_requests);

     

       418
       418
       -
           ("cache_range_requests", `Bool t.cache_range_requests);

     

       419
       419
       -
           ("cacheio_stats", cacheio_stats);

     

       420
       420
       -
         ]

+2 -4

stack/requests/lib/dune

···

       8
       8
        
         cohttp

     

       9
       9
        
         cohttp-eio

     

       10
       10
        
         uri

     

       11
       11
       -
         jsonm

     

       12
       12
       -
         yojson

     

       13
       13
       -
         ezjsonm

     

       11
       11
       +
         jsont

     

       12
       12
       +
         jsont.bytesrw

     

       14
       13
        
         base64

     

       15
       15
       -
         cacheio

     

       16
       14
        
         cookeio

     

       17
       15
        
         xdge

     

       18
       16
        
         logs

+41 -76

stack/requests/lib/requests.ml

···

       14
       14
        
       module Status = Status

     

       15
       15
        
       module Error = Error

     

       16
       16
        
       module Retry = Retry

     

       17
       17
       -
       module Cache = Cache

     

       18
       17
        
       

     

       19
       18
        
       (* Note: RNG initialization should be done by the application using

     

       20
       19
        
          Mirage_crypto_rng_unix.initialize before calling Eio_main.run.

     
···

       23
       22
        
       

     

       24
       23
        
       (* Main API - Session functionality with connection pooling *)

     

       25
       24
        
       

     

       26
       26
       -
       type ('clock, 'net) t = {

     

       25
       25
       +
       (* Internal session type with existential type parameters *)

     

       26
       26
       +
       type ('clock, 'net) session = {

     

       27
       27
        
         sw : Eio.Switch.t;

     

       28
       28
        
         clock : 'clock;

     

       29
       29
        
         net : 'net;

     
···

       41
       41
        
         retry : Retry.config option;

     

       42
       42
        
         persist_cookies : bool;

     

       43
       43
        
         xdg : Xdge.t option;

     

       44
       44
       -
         cache : Cache.t option;

     

       45
       44
        
       

     

       46
       45
        
         (* Statistics - mutable for tracking across all derived sessions *)

     

       47
       46
        
         mutable requests_made : int;

     
···

       49
       48
        
         mutable retries_count : int;

     

       50
       49
        
       }

     

       51
       50
        
       

     

       51
       51
       +
       (* Public type that hides the existential type parameters.

     

       52
       52
       +
          We constrain the existentials to ensure they satisfy the requirements

     

       53
       53
       +
          of the internal functions. *)

     

       54
       54
       +
       type t = T : ([> float Eio.Time.clock_ty] Eio.Resource.t,

     

       55
       55
       +
                      [> [> `Generic] Eio.Net.ty] Eio.Resource.t) session -> t

     

       56
       56
       +
       

     

       52
       57
        
       let create

     

       53
       58
        
           ~sw

     

       54
       59
        
           ?http_pool

     
···

       66
       71
        
           ?(connection_lifetime = 300.0)

     

       67
       72
        
           ?retry

     

       68
       73
        
           ?(persist_cookies = false)

     

       69
       69
       -
           ?(enable_cache = false)

     

       70
       74
        
           ?xdg

     

       71
       75
        
           env =

     

       72
       76
        
       

     

       73
       77
        
         let clock = env#clock in

     

       74
       78
        
         let net = env#net in

     

       75
       79
        
       

     

       76
       76
       -
         let xdg = match xdg, persist_cookies || enable_cache with

     

       80
       80
       +
         let xdg = match xdg, persist_cookies with

     

       77
       81
        
           | Some x, _ -> Some x

     

       78
       82
        
           | None, true -> Some (Xdge.create env#fs "requests")

     

       79
       83
        
           | None, false -> None

     
···

       135
       139
        
               Cookeio.create ()

     

       136
       140
        
         in

     

       137
       141
        
       

     

       138
       138
       -
         let cache = match enable_cache, xdg with

     

       139
       139
       -
           | true, Some xdg_ctx ->

     

       140
       140
       -
               let cache_dir = Xdge.cache_dir xdg_ctx in

     

       141
       141
       -
               Some (Cache.create ~sw ~enabled:true ~cache_dir:(Some cache_dir) ())

     

       142
       142
       -
           | true, None ->

     

       143
       143
       -
               (* Memory-only cache when no XDG available *)

     

       144
       144
       -
               Some (Cache.create ~sw ~enabled:true ~cache_dir:None ())

     

       145
       145
       -
           | false, _ -> None

     

       146
       146
       -
         in

     

       147
       147
       -
       

     

       148
       148
       -
         {

     

       142
       142
       +
         T {

     

       149
       143
        
           sw;

     

       150
       144
        
           clock;

     

       151
       145
        
           net;

     
···

       163
       157
        
           retry;

     

       164
       158
        
           persist_cookies;

     

       165
       159
        
           xdg;

     

       166
       166
       -
           cache;

     

       167
       160
        
           requests_made = 0;

     

       168
       161
        
           total_time = 0.0;

     

       169
       162
        
           retries_count = 0;

     

       170
       163
        
         }

     

       171
       164
        
       

     

       172
       172
       -
       let set_default_header t key value =

     

       173
       173
       -
         { t with default_headers = Headers.set key value t.default_headers }

     

       165
       165
       +
       let set_default_header (T t) key value =

     

       166
       166
       +
         T { t with default_headers = Headers.set key value t.default_headers }

     

       174
       167
        
       

     

       175
       175
       -
       let remove_default_header t key =

     

       176
       176
       -
         { t with default_headers = Headers.remove key t.default_headers }

     

       168
       168
       +
       let remove_default_header (T t) key =

     

       169
       169
       +
         T { t with default_headers = Headers.remove key t.default_headers }

     

       177
       170
        
       

     

       178
       178
       -
       let set_auth t auth =

     

       171
       171
       +
       let set_auth (T t) auth =

     

       179
       172
        
         Log.debug (fun m -> m "Setting authentication method");

     

       180
       180
       -
         { t with auth = Some auth }

     

       173
       173
       +
         T { t with auth = Some auth }

     

       181
       174
        
       

     

       182
       182
       -
       let clear_auth t =

     

       175
       175
       +
       let clear_auth (T t) =

     

       183
       176
        
         Log.debug (fun m -> m "Clearing authentication");

     

       184
       184
       -
         { t with auth = None }

     

       177
       177
       +
         T { t with auth = None }

     

       185
       178
        
       

     

       186
       186
       -
       let set_timeout t timeout =

     

       179
       179
       +
       let set_timeout (T t) timeout =

     

       187
       180
        
         Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout);

     

       188
       188
       -
         { t with timeout }

     

       181
       181
       +
         T { t with timeout }

     

       189
       182
        
       

     

       190
       190
       -
       let set_retry t config =

     

       183
       183
       +
       let set_retry (T t) config =

     

       191
       184
        
         Log.debug (fun m -> m "Setting retry config: max_retries=%d" config.Retry.max_retries);

     

       192
       192
       -
         { t with retry = Some config }

     

       185
       185
       +
         T { t with retry = Some config }

     

       193
       186
        
       

     

       194
       194
       -
       let cookies t = t.cookie_jar

     

       195
       195
       -
       let clear_cookies t = Cookeio.clear t.cookie_jar

     

       187
       187
       +
       let cookies (T t) = t.cookie_jar

     

       188
       188
       +
       let clear_cookies (T t) = Cookeio.clear t.cookie_jar

     

       196
       189
        
       

     

       197
       190
        
       (* Internal request function using connection pools *)

     

       198
       191
        
       let make_request_internal t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =

     
···

       254
       247
        
           | Some b -> Body.Private.to_string b

     

       255
       248
        
         in

     

       256
       249
        
       

     

       257
       257
       -
         (* Check cache for GET and HEAD requests when body is not present *)

     

       258
       258
       -
         let cached_response = match t.cache, method_, body with

     

       259
       259
       -
           | Some cache, (`GET | `HEAD), None ->

     

       260
       260
       -
               Log.debug (fun m -> m "Checking cache for %s request to %s" method_str url);

     

       261
       261
       -
               let headers_cohttp = Cohttp.Header.of_list (Headers.to_list headers) in

     

       262
       262
       -
               Cache.get cache ~method_ ~url:uri ~headers:headers_cohttp

     

       263
       263
       -
           | _ -> None

     

       264
       264
       -
         in

     

       265
       265
       -
       

     

       266
       266
       -
         let response = match cached_response with

     

       267
       267
       -
           | Some cached ->

     

       268
       268
       -
               Log.info (fun m -> m "Cache HIT for %s request to %s" method_str url);

     

       269
       269
       -
               (* Convert cached response to Response.t *)

     

       270
       270
       -
               let status = Cohttp.Code.code_of_status cached.Cache.status in

     

       271
       271
       -
               let resp_headers = Headers.of_list (Cohttp.Header.to_list cached.Cache.headers) in

     

       272
       272
       -
               let body_flow = Eio.Flow.string_source cached.Cache.body in

     

       273
       273
       -
               Response.Private.make ~sw:t.sw ~status ~headers:resp_headers ~body:body_flow ~url ~elapsed:0.0

     

       274
       274
       -
           | None ->

     

       275
       275
       -
               Log.info (fun m -> m "Cache MISS or not applicable for %s request to %s" method_str url);

     

       250
       250
       +
         let response =

     

       276
       251
        
       

     

       277
       252
        
               (* Execute request with redirect handling *)

     

       278
       253
        
               let rec make_with_redirects url_to_fetch redirects_left =

     
···

       354
       329
        
               let elapsed = Unix.gettimeofday () -. start_time in

     

       355
       330
        
               Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);

     

       356
       331
        
       

     

       357
       357
       -
               (* Store in cache if successful and caching enabled *)

     

       358
       358
       -
               (match t.cache with

     

       359
       359
       -
                | Some cache when final_status >= 200 && final_status < 300 ->

     

       360
       360
       -
                    Log.debug (fun m -> m "Storing response in cache for %s" url);

     

       361
       361
       -
                    let status = Cohttp.Code.status_of_code final_status in

     

       362
       362
       -
                    let resp_headers_cohttp = Cohttp.Header.of_list (Headers.to_list final_headers) in

     

       363
       363
       -
                    let headers_cohttp = Cohttp.Header.of_list (Headers.to_list headers) in

     

       364
       364
       -
                    Cache.put cache ~method_ ~url:uri ~request_headers:headers_cohttp

     

       365
       365
       -
                      ~status ~headers:resp_headers_cohttp ~body:final_body_str

     

       366
       366
       -
                | _ -> ());

     

       367
       367
       -
       

     

       368
       332
        
               (* Create a flow from the body string *)

     

       369
       333
        
               let body_flow = Eio.Flow.string_source final_body_str in

     

       370
       334
        
       

     
···

       403
       367
        
         response

     

       404
       368
        
       

     

       405
       369
        
       (* Public request function - executes synchronously *)

     

       406
       406
       -
       let request t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =

     

       370
       370
       +
       let request (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =

     

       371
       371
       +
         (* Keep t in scope to preserve existential types *)

     

       407
       372
        
         make_request_internal t ?headers ?body ?auth ?timeout

     

       408
       373
        
           ?follow_redirects ?max_redirects ~method_ url

     

       409
       374
        
       

     

       410
       375
        
       (* Convenience methods *)

     

       411
       411
       -
       let get t ?headers ?auth ?timeout ?params url =

     

       376
       376
       +
       let get (T t) ?headers ?auth ?timeout ?params url =

     

       412
       377
        
         let url = match params with

     

       413
       378
        
           | Some p ->

     

       414
       379
        
               let uri = Uri.of_string url in

     
···

       416
       381
        
               Uri.to_string uri

     

       417
       382
        
           | None -> url

     

       418
       383
        
         in

     

       419
       419
       -
         request t ?headers ?auth ?timeout ~method_:`GET url

     

       384
       384
       +
         make_request_internal t ?headers ?auth ?timeout ~method_:`GET url

     

       420
       385
        
       

     

       421
       421
       -
       let post t ?headers ?body ?auth ?timeout url =

     

       422
       422
       -
         request t ?headers ?body ?auth ?timeout ~method_:`POST url

     

       386
       386
       +
       let post (T t) ?headers ?body ?auth ?timeout url =

     

       387
       387
       +
         make_request_internal t ?headers ?body ?auth ?timeout ~method_:`POST url

     

       423
       388
        
       

     

       424
       424
       -
       let put t ?headers ?body ?auth ?timeout url =

     

       425
       425
       -
         request t ?headers ?body ?auth ?timeout ~method_:`PUT url

     

       389
       389
       +
       let put (T t) ?headers ?body ?auth ?timeout url =

     

       390
       390
       +
         make_request_internal t ?headers ?body ?auth ?timeout ~method_:`PUT url

     

       426
       391
        
       

     

       427
       427
       -
       let patch t ?headers ?body ?auth ?timeout url =

     

       428
       428
       -
         request t ?headers ?body ?auth ?timeout ~method_:`PATCH url

     

       392
       392
       +
       let patch (T t) ?headers ?body ?auth ?timeout url =

     

       393
       393
       +
         make_request_internal t ?headers ?body ?auth ?timeout ~method_:`PATCH url

     

       429
       394
        
       

     

       430
       430
       -
       let delete t ?headers ?auth ?timeout url =

     

       431
       431
       -
         request t ?headers ?auth ?timeout ~method_:`DELETE url

     

       395
       395
       +
       let delete (T t) ?headers ?auth ?timeout url =

     

       396
       396
       +
         make_request_internal t ?headers ?auth ?timeout ~method_:`DELETE url

     

       432
       397
        
       

     

       433
       433
       -
       let head t ?headers ?auth ?timeout url =

     

       434
       434
       -
         request t ?headers ?auth ?timeout ~method_:`HEAD url

     

       398
       398
       +
       let head (T t) ?headers ?auth ?timeout url =

     

       399
       399
       +
         make_request_internal t ?headers ?auth ?timeout ~method_:`HEAD url

     

       435
       400
        
       

     

       436
       436
       -
       let options t ?headers ?auth ?timeout url =

     

       437
       437
       -
         request t ?headers ?auth ?timeout ~method_:`OPTIONS url

     

       401
       401
       +
       let options (T t) ?headers ?auth ?timeout url =

     

       402
       402
       +
         make_request_internal t ?headers ?auth ?timeout ~method_:`OPTIONS url

     

       438
       403
        
       

     

       439
       404
        
       (* Cmdliner integration module *)

     

       440
       405
        
       module Cmd = struct

+37 -29

stack/requests/lib/requests.mli

···

       132
       132
        
           Use Eio.Fiber.both or Eio.Fiber.all for concurrent execution.

     

       133
       133
        
       *)

     

       134
       134
        
       

     

       135
       135
       -
       type ('clock, 'net) t

     

       135
       135
       +
       type t

     

       136
       136
        
       (** A stateful HTTP client that maintains cookies, auth, configuration, and

     

       137
       137
       -
           connection pools across requests. *)

     

       137
       137
       +
           connection pools across requests. The internal clock and network types are

     

       138
       138
       +
           hidden from external users. *)

     

       138
       139
        
       

     

       139
       140
        
       (** {2 Creation and Configuration} *)

     

       140
       141
        
       

     

       141
       142
        
       val create :

     

       142
       143
        
         sw:Eio.Switch.t ->

     

       143
       143
       -
         ?http_pool:('clock Eio.Time.clock, 'net Eio.Net.t) Conpool.t ->

     

       144
       144
       -
         ?https_pool:('clock Eio.Time.clock, 'net Eio.Net.t) Conpool.t ->

     

       144
       144
       +
         ?http_pool:(([> float Eio.Time.clock_ty] as 'clock) Eio.Resource.t,

     

       145
       145
       +
                     ([> [> `Generic] Eio.Net.ty] as 'net) Eio.Resource.t) Conpool.t ->

     

       146
       146
       +
         ?https_pool:('clock Eio.Resource.t, 'net Eio.Resource.t) Conpool.t ->

     

       145
       147
        
         ?cookie_jar:Cookeio.jar ->

     

       146
       148
        
         ?default_headers:Headers.t ->

     

       147
       149
        
         ?auth:Auth.t ->

     
···

       155
       157
        
         ?connection_lifetime:float ->

     

       156
       158
        
         ?retry:Retry.config ->

     

       157
       159
        
         ?persist_cookies:bool ->

     

       158
       158
       -
         ?enable_cache:bool ->

     

       159
       160
        
         ?xdg:Xdge.t ->

     

       160
       161
        
         < clock: 'clock Eio.Resource.t; net: 'net Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->

     

       161
       161
       -
         ('clock Eio.Resource.t, 'net Eio.Resource.t) t

     

       162
       162
       +
         t

     

       162
       163
        
       (** Create a new requests instance with persistent state and connection pooling.

     

       163
       164
        
           All resources are bound to the provided switch and will be cleaned up automatically.

     

       164
       165
        
       

     
···

       178
       179
        
           @param connection_lifetime Max lifetime of any pooled connection (default: 300s)

     

       179
       180
        
           @param retry Retry configuration for failed requests

     

       180
       181
        
           @param persist_cookies Whether to persist cookies to disk (default: false)

     

       181
       181
       -
           @param enable_cache Whether to enable HTTP caching (default: false)

     

       182
       182
       -
           @param xdg XDG directory context for cookies/cache (required if persist_cookies or enable_cache)

     

       182
       182
       +
           @param xdg XDG directory context for cookies (required if persist_cookies=true)

     

       183
       183
       +
       

     

       184
       184
       +
           {b Note:} HTTP caching has been disabled for simplicity. See CACHEIO.md for integration notes

     

       185
       185
       +
           if you need to restore caching functionality in the future.

     

       183
       186
        
       *)

     

       184
       187
        
       

     

       185
       188
        
       (** {2 Configuration Management} *)

     

       186
       189
        
       

     

       187
       187
       -
       val set_default_header : ('clock, 'net) t -> string -> string -> ('clock, 'net) t

     

       190
       190
       +
       val set_default_header : t -> string -> string -> t

     

       188
       191
        
       (** Add or update a default header. Returns a new session with the updated header.

     

       189
       192
        
           The original session's connection pools are shared. *)

     

       190
       193
        
       

     

       191
       191
       -
       val remove_default_header : ('clock, 'net) t -> string -> ('clock, 'net) t

     

       194
       194
       +
       val remove_default_header : t -> string -> t

     

       192
       195
        
       (** Remove a default header. Returns a new session without the header. *)

     

       193
       196
        
       

     

       194
       194
       -
       val set_auth : ('clock, 'net) t -> Auth.t -> ('clock, 'net) t

     

       197
       197
       +
       val set_auth : t -> Auth.t -> t

     

       195
       198
        
       (** Set default authentication. Returns a new session with auth configured. *)

     

       196
       199
        
       

     

       197
       197
       -
       val clear_auth : ('clock, 'net) t -> ('clock, 'net) t

     

       200
       200
       +
       val clear_auth : t -> t

     

       198
       201
        
       (** Clear authentication. Returns a new session without auth. *)

     

       199
       202
        
       

     

       200
       200
       -
       val set_timeout : ('clock, 'net) t -> Timeout.t -> ('clock, 'net) t

     

       203
       203
       +
       val set_timeout : t -> Timeout.t -> t

     

       201
       204
        
       (** Set default timeout. Returns a new session with the timeout configured. *)

     

       202
       205
        
       

     

       203
       203
       -
       val set_retry : ('clock, 'net) t -> Retry.config -> ('clock, 'net) t

     

       206
       206
       +
       val set_retry : t -> Retry.config -> t

     

       204
       207
        
       (** Set retry configuration. Returns a new session with retry configured. *)

     

       205
       208
        
       

     

       206
       209
        
       (** {2 Request Methods}

     
···

       281
       284
        
       *)

     

       282
       285
        
       

     

       283
       286
        
       val request :

     

       284
       284
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       287
       287
       +
         t ->

     

       285
       288
        
         ?headers:Headers.t ->

     

       286
       289
        
         ?body:Body.t ->

     

       287
       290
        
         ?auth:Auth.t ->

     
···

       294
       297
        
       (** Make a concurrent HTTP request *)

     

       295
       298
        
       

     

       296
       299
        
       val get :

     

       297
       297
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       300
       300
       +
         t ->

     

       298
       301
        
         ?headers:Headers.t ->

     

       299
       302
        
         ?auth:Auth.t ->

     

       300
       303
        
         ?timeout:Timeout.t ->

     
···

       304
       307
        
       (** Concurrent GET request *)

     

       305
       308
        
       

     

       306
       309
        
       val post :

     

       307
       307
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       310
       310
       +
         t ->

     

       308
       311
        
         ?headers:Headers.t ->

     

       309
       312
        
         ?body:Body.t ->

     

       310
       313
        
         ?auth:Auth.t ->

     
···

       314
       317
        
       (** Concurrent POST request *)

     

       315
       318
        
       

     

       316
       319
        
       val put :

     

       317
       317
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       320
       320
       +
         t ->

     

       318
       321
        
         ?headers:Headers.t ->

     

       319
       322
        
         ?body:Body.t ->

     

       320
       323
        
         ?auth:Auth.t ->

     
···

       324
       327
        
       (** Concurrent PUT request *)

     

       325
       328
        
       

     

       326
       329
        
       val patch :

     

       327
       327
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       330
       330
       +
         t ->

     

       328
       331
        
         ?headers:Headers.t ->

     

       329
       332
        
         ?body:Body.t ->

     

       330
       333
        
         ?auth:Auth.t ->

     
···

       334
       337
        
       (** Concurrent PATCH request *)

     

       335
       338
        
       

     

       336
       339
        
       val delete :

     

       337
       337
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       340
       340
       +
         t ->

     

       338
       341
        
         ?headers:Headers.t ->

     

       339
       342
        
         ?auth:Auth.t ->

     

       340
       343
        
         ?timeout:Timeout.t ->

     
···

       343
       346
        
       (** Concurrent DELETE request *)

     

       344
       347
        
       

     

       345
       348
        
       val head :

     

       346
       346
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       349
       349
       +
         t ->

     

       347
       350
        
         ?headers:Headers.t ->

     

       348
       351
        
         ?auth:Auth.t ->

     

       349
       352
        
         ?timeout:Timeout.t ->

     
···

       352
       355
        
       (** Concurrent HEAD request *)

     

       353
       356
        
       

     

       354
       357
        
       val options :

     

       355
       355
       -
         (_ Eio.Time.clock, _ Eio.Net.t) t ->

     

       358
       358
       +
         t ->

     

       356
       359
        
         ?headers:Headers.t ->

     

       357
       360
        
         ?auth:Auth.t ->

     

       358
       361
        
         ?timeout:Timeout.t ->

     
···

       362
       365
        
       

     

       363
       366
        
       (** {2 Cookie Management} *)

     

       364
       367
        
       

     

       365
       365
       -
       val cookies : ('clock, 'net) t -> Cookeio.jar

     

       368
       368
       +
       val cookies : t -> Cookeio.jar

     

       366
       369
        
       (** Get the cookie jar for direct manipulation *)

     

       367
       370
        
       

     

       368
       368
       -
       val clear_cookies : ('clock, 'net) t -> unit

     

       371
       371
       +
       val clear_cookies : t -> unit

     

       369
       372
        
       (** Clear all cookies *)

     

       370
       373
        
       

     

       371
       374
        
       (** {1 Cmdliner Integration} *)

     
···

       390
       393
        
           user_agent : string option;  (** User-Agent header *)

     

       391
       394
        
         }

     

       392
       395
        
       

     

       393
       393
       -
         val create : config -> < clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t; net: ([> [>`Generic] Eio.Net.ty ] as 'net) Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > -> Eio.Switch.t -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t

     

       396
       396
       +
         val create : config ->

     

       397
       397
       +
           < clock: [> float Eio.Time.clock_ty] Eio.Resource.t;

     

       398
       398
       +
             net: [> [> `Generic] Eio.Net.ty] Eio.Resource.t;

     

       399
       399
       +
             fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->

     

       400
       400
       +
           Eio.Switch.t -> t

     

       394
       401
        
         (** [create config env sw] creates a requests instance from command-line configuration *)

     

       395
       402
        
       

     

       396
       403
        
         (** {2 Individual Terms} *)

     
···

       453
       460
        
               Cmd.eval cmd

     

       454
       461
        
             ]} *)

     

       455
       462
        
       

     

       456
       456
       -
         val requests_term : string -> < clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t; net: ([> [>`Generic] Eio.Net.ty ] as 'net) Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > -> Eio.Switch.t -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t Cmdliner.Term.t

     

       463
       463
       +
         val requests_term : string ->

     

       464
       464
       +
           < clock: [> float Eio.Time.clock_ty] Eio.Resource.t;

     

       465
       465
       +
             net: [> [> `Generic] Eio.Net.ty] Eio.Resource.t;

     

       466
       466
       +
             fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->

     

       467
       467
       +
           Eio.Switch.t -> t Cmdliner.Term.t

     

       457
       468
        
         (** [requests_term app_name env sw] creates a term that directly produces a requests instance.

     

       458
       469
        
       

     

       459
       470
        
             This is a convenience function that combines configuration parsing

     
···

       569
       580
        
       

     

       570
       581
        
       (** Timeout configuration for requests *)

     

       571
       582
        
       module Timeout = Timeout

     

       572
       572
       -
       

     

       573
       573
       -
       (** HTTP caching with cache control and range request support *)

     

       574
       574
       -
       module Cache = Cache

     

       575
       583
        
       

     

       576
       584
        
       (** {2 Logging} *)

     

       577
       585

-1

stack/requests/requests.opam

···

       17
       17
        
         "ca-certs"

     

       18
       18
        
         "mirage-crypto-rng-eio"

     

       19
       19
        
         "uri"

     

       20
       20
       -
         "yojson"

     

       21
       20
        
         "digestif"

     

       22
       21
        
         "base64"

     

       23
       22
        
         "logs"

-18

stack/requests/test/dune

···

       1
       1
       -
       (test

     

       2
       2
       -
        (name test_requests)

     

       3
       3
       -
        (libraries

     

       4
       4
       -
         requests

     

       5
       5
       -
         alcotest

     

       6
       6
       -
         eio

     

       7
       7
       -
         eio_main

     

       8
       8
       -
         cohttp

     

       9
       9
       -
         cohttp-eio

     

       10
       10
       -
         uri

     

       11
       11
       -
         yojson

     

       12
       12
       -
         logs

     

       13
       13
       -
         str)

     

       14
       14
       -
        (deps

     

       15
       15
       -
         (package requests)))(executable

     

       16
       16
       -
        (name test_connection_pool)

     

       17
       17
       -
        (modules test_connection_pool)

     

       18
       18
       -
        (libraries requests eio_main logs logs.fmt conpool))

-52

stack/requests/test/test_connection_pool.ml

···

       1
       1
       -
       (** Test stateless One API - each request opens a fresh connection *)

     

       2
       2
       -
       

     

       3
       3
       -
       open Eio.Std

     

       4
       4
       -
       

     

       5
       5
       -
       let test_one_stateless () =

     

       6
       6
       -
         (* Initialize RNG for TLS *)

     

       7
       7
       -
         Mirage_crypto_rng_unix.use_default ();

     

       8
       8
       -
       

     

       9
       9
       -
         Eio_main.run @@ fun env ->

     

       10
       10
       -
         Switch.run @@ fun sw ->

     

       11
       11
       -
       

     

       12
       12
       -
         (* Configure logging to see One request activity *)

     

       13
       13
       -
         Logs.set_reporter (Logs_fmt.reporter ());

     

       14
       14
       -
         Logs.set_level (Some Logs.Info);

     

       15
       15
       -
         Logs.Src.set_level Requests.One.src (Some Logs.Info);

     

       16
       16
       -
       

     

       17
       17
       -
         traceln "=== Testing One Stateless API ===\n";

     

       18
       18
       -
         traceln "The One API creates fresh connections for each request (no pooling)\n";

     

       19
       19
       -
       

     

       20
       20
       -
         (* Make multiple requests to the same host using stateless One API *)

     

       21
       21
       -
         let start_time = Unix.gettimeofday () in

     

       22
       22
       -
       

     

       23
       23
       -
         for i = 1 to 10 do

     

       24
       24
       -
           traceln "Request %d:" i;

     

       25
       25
       -
           let response = Requests.One.get ~sw

     

       26
       26
       -
             ~clock:env#clock ~net:env#net

     

       27
       27
       -
             "http://example.com"

     

       28
       28
       -
           in

     

       29
       29
       -
       

     

       30
       30
       -
           traceln "  Status: %d" (Requests.Response.status_code response);

     

       31
       31
       -
           traceln "  Content-Length: %s"

     

       32
       32
       -
             (match Requests.Response.content_length response with

     

       33
       33
       -
              | Some len -> Int64.to_string len

     

       34
       34
       -
              | None -> "unknown");

     

       35
       35
       -
       

     

       36
       36
       -
           (* Connection is fresh for each request - no pooling *)

     

       37
       37
       -
           traceln ""

     

       38
       38
       -
         done;

     

       39
       39
       -
       

     

       40
       40
       -
         let elapsed = Unix.gettimeofday () -. start_time in

     

       41
       41
       -
         traceln "All 10 requests completed in %.2f seconds" elapsed;

     

       42
       42
       -
         traceln "Average: %.2f seconds per request" (elapsed /. 10.0);

     

       43
       43
       -
       

     

       44
       44
       -
         traceln "\n=== Test completed successfully ==="

     

       45
       45
       -
       

     

       46
       46
       -
       let () =

     

       47
       47
       -
         try

     

       48
       48
       -
           test_one_stateless ()

     

       49
       49
       -
         with e ->

     

       50
       50
       -
           traceln "Test failed with exception: %s" (Printexc.to_string e);

     

       51
       51
       -
           Printexc.print_backtrace stdout;

     

       52
       52
       -
           exit 1

-899

stack/requests/test/test_requests.ml

···

       1
       1
       -
       open Eio_main

     

       2
       2
       -
       

     

       3
       3
       -
       let port = ref 8088

     

       4
       4
       -
       

     

       5
       5
       -
       let get_free_port () =

     

       6
       6
       -
         let p = !port in

     

       7
       7
       -
         incr port;

     

       8
       8
       -
         p

     

       9
       9
       -
       

     

       10
       10
       -
       let string_contains s sub =

     

       11
       11
       -
         try

     

       12
       12
       -
           let _ = Str.search_forward (Str.regexp_string sub) s 0 in

     

       13
       13
       -
           true

     

       14
       14
       -
         with Not_found -> false

     

       15
       15
       -
       

     

       16
       16
       -
       module Test_server = struct

     

       17
       17
       -
         open Cohttp_eio

     

       18
       18
       -
       

     

       19
       19
       -
         let make_server ~port handler env =

     

       20
       20
       -
           let server_socket =

     

       21
       21
       -
             Eio.Net.listen env#net ~sw:env#sw ~backlog:128 ~reuse_addr:true

     

       22
       22
       -
               (`Tcp (Eio.Net.Ipaddr.V4.loopback, port))

     

       23
       23
       -
           in

     

       24
       24
       -
           let callback _conn req body =

     

       25
       25
       -
             let (resp, body_content) = handler ~request:req ~body in

     

       26
       26
       -
             Server.respond_string () ~status:(Http.Response.status resp)

     

       27
       27
       -
               ~headers:(Http.Response.headers resp)

     

       28
       28
       -
               ~body:body_content

     

       29
       29
       -
           in

     

       30
       30
       -
           let server = Server.make ~callback () in

     

       31
       31
       -
           Server.run server_socket server ~on_error:(fun exn ->

     

       32
       32
       -
             Logs.err (fun m -> m "Server error: %s" (Printexc.to_string exn))

     

       33
       33
       -
           )

     

       34
       34
       -
       

     

       35
       35
       -
         let echo_handler ~request ~body =

     

       36
       36
       -
           let uri = Http.Request.resource request in

     

       37
       37
       -
           let meth = Http.Request.meth request in

     

       38
       38
       -
           let headers = Http.Request.headers request in

     

       39
       39
       -
           let body_str = Eio.Flow.read_all body in

     

       40
       40
       -
       

     

       41
       41
       -
           let response_body =

     

       42
       42
       -
             `Assoc [

     

       43
       43
       -
               "method", `String (Cohttp.Code.string_of_method meth);

     

       44
       44
       -
               "uri", `String uri;

     

       45
       45
       -
               "headers", `Assoc (

     

       46
       46
       -
                 Cohttp.Header.to_lines headers

     

       47
       47
       -
                 |> List.map (fun line ->

     

       48
       48
       -
                   match String.split_on_char ':' line with

     

       49
       49
       -
                   | [k; v] -> (String.trim k, `String (String.trim v))

     

       50
       50
       -
                   | _ -> ("", `String line)

     

       51
       51
       -
                 )

     

       52
       52
       -
               );

     

       53
       53
       -
               "body", `String body_str;

     

       54
       54
       -
             ]

     

       55
       55
       -
             |> Yojson.Basic.to_string

     

       56
       56
       -
           in

     

       57
       57
       -
       

     

       58
       58
       -
           let resp = Http.Response.make ~status:`OK () in

     

       59
       59
       -
           let resp_headers = Cohttp.Header.add_unless_exists

     

       60
       60
       -
             (Http.Response.headers resp) "content-type" "application/json"

     

       61
       61
       -
           in

     

       62
       62
       -
           ({ resp with headers = resp_headers }, response_body)

     

       63
       63
       -
       

     

       64
       64
       -
         let status_handler status_code ~request:_ ~body:_ =

     

       65
       65
       -
           let status = Cohttp.Code.status_of_code status_code in

     

       66
       66
       -
           let resp = Http.Response.make ~status () in

     

       67
       67
       -
           (resp, "")

     

       68
       68
       -
       

     

       69
       69
       -
         let redirect_handler target_path ~request:_ ~body:_ =

     

       70
       70
       -
           let resp = Http.Response.make ~status:`Moved_permanently () in

     

       71
       71
       -
           let headers = Cohttp.Header.add

     

       72
       72
       -
             (Http.Response.headers resp) "location" target_path

     

       73
       73
       -
           in

     

       74
       74
       -
           ({ resp with headers },  "")

     

       75
       75
       -
       

     

       76
       76
       -
         let cookie_handler ~request ~body:_ =

     

       77
       77
       -
           let headers = Http.Request.headers request in

     

       78
       78
       -
           let cookies =

     

       79
       79
       -
             match Cohttp.Header.get headers "cookie" with

     

       80
       80
       -
             | Some cookie_str -> cookie_str

     

       81
       81
       -
             | None -> "no cookies"

     

       82
       82
       -
           in

     

       83
       83
       -
       

     

       84
       84
       -
           let resp = Http.Response.make ~status:`OK () in

     

       85
       85
       -
           let resp_headers =

     

       86
       86
       -
             Http.Response.headers resp

     

       87
       87
       -
             |> (fun h -> Cohttp.Header.add h "set-cookie" "test_cookie=test_value; Path=/")

     

       88
       88
       -
             |> (fun h -> Cohttp.Header.add h "set-cookie" "session=abc123; Path=/; HttpOnly")

     

       89
       89
       -
           in

     

       90
       90
       -
           ({ resp with headers = resp_headers },

     

       91
       91
       -
        cookies)

     

       92
       92
       -
       

     

       93
       93
       -
         let auth_handler ~request ~body:_ =

     

       94
       94
       -
           let headers = Http.Request.headers request in

     

       95
       95
       -
           let auth_result =

     

       96
       96
       -
             match Cohttp.Header.get headers "authorization" with

     

       97
       97
       -
             | Some auth ->

     

       98
       98
       -
                 if String.starts_with ~prefix:"Bearer " auth then

     

       99
       99
       -
                   let token = String.sub auth 7 (String.length auth - 7) in

     

       100
       100
       -
                   if token = "valid_token" then "authorized"

     

       101
       101
       -
                   else "invalid token"

     

       102
       102
       -
                 else if String.starts_with ~prefix:"Basic " auth then

     

       103
       103
       -
                   "basic auth received"

     

       104
       104
       -
                 else "unknown auth"

     

       105
       105
       -
             | None -> "no auth"

     

       106
       106
       -
           in

     

       107
       107
       -
       

     

       108
       108
       -
           let status =

     

       109
       109
       -
             if auth_result = "authorized" || auth_result = "basic auth received"

     

       110
       110
       -
             then `OK

     

       111
       111
       -
             else `Unauthorized

     

       112
       112
       -
           in

     

       113
       113
       -
           let resp = Http.Response.make ~status () in

     

       114
       114
       -
           (resp, auth_result)

     

       115
       115
       -
       

     

       116
       116
       -
         let json_handler ~request:_ ~body =

     

       117
       117
       -
           let body_str = Eio.Flow.read_all body in

     

       118
       118
       -
           let json =

     

       119
       119
       -
             try

     

       120
       120
       -
               let parsed = Yojson.Basic.from_string body_str in

     

       121
       121
       -
               `Assoc [

     

       122
       122
       -
                 "received", parsed;

     

       123
       123
       -
                 "echo", `Bool true;

     

       124
       124
       -
               ]

     

       125
       125
       -
             with _ ->

     

       126
       126
       -
               `Assoc [

     

       127
       127
       -
                 "error", `String "invalid json";

     

       128
       128
       -
                 "received", `String body_str;

     

       129
       129
       -
               ]

     

       130
       130
       -
           in

     

       131
       131
       -
       

     

       132
       132
       -
           let resp = Http.Response.make ~status:`OK () in

     

       133
       133
       -
           let resp_headers = Cohttp.Header.add_unless_exists

     

       134
       134
       -
             (Http.Response.headers resp) "content-type" "application/json"

     

       135
       135
       -
           in

     

       136
       136
       -
           ({ resp with headers = resp_headers },

     

       137
       137
       -
        Yojson.Basic.to_string json)

     

       138
       138
       -
       

     

       139
       139
       -
         let timeout_handler clock delay ~request:_ ~body:_ =

     

       140
       140
       -
           Eio.Time.sleep clock delay;

     

       141
       141
       -
           let resp = Http.Response.make ~status:`OK () in

     

       142
       142
       -
           (resp,"delayed response")

     

       143
       143
       -
       

     

       144
       144
       -
         let chunked_handler _clock chunks ~request:_ ~body:_ =

     

       145
       145
       -
           let resp = Http.Response.make ~status:`OK () in

     

       146
       146
       -
           let body_str = String.concat "" chunks in

     

       147
       147
       -
           (resp,body_str)

     

       148
       148
       -
       

     

       149
       149
       -
         let large_response_handler size ~request:_ ~body:_ =

     

       150
       150
       -
           let data = String.make size 'X' in

     

       151
       151
       -
           let resp = Http.Response.make ~status:`OK () in

     

       152
       152
       -
           (resp,data)

     

       153
       153
       -
       

     

       154
       154
       -
         let multipart_handler ~request ~body =

     

       155
       155
       -
           let headers = Http.Request.headers request in

     

       156
       156
       -
           let content_type = Cohttp.Header.get headers "content-type" in

     

       157
       157
       -
           let body_str = Eio.Flow.read_all body in

     

       158
       158
       -
       

     

       159
       159
       -
           let result =

     

       160
       160
       -
             match content_type with

     

       161
       161
       -
             | Some ct when String.starts_with ~prefix:"multipart/form-data" ct ->

     

       162
       162
       -
                 Printf.sprintf "Multipart received: %d bytes" (String.length body_str)

     

       163
       163
       -
             | _ -> "Not multipart"

     

       164
       164
       -
           in

     

       165
       165
       -
       

     

       166
       166
       -
           let resp = Http.Response.make ~status:`OK () in

     

       167
       167
       -
           (resp,result)

     

       168
       168
       -
       

     

       169
       169
       -
         let router clock ~request ~body =

     

       170
       170
       -
           let uri = Http.Request.resource request in

     

       171
       171
       -
           match uri with

     

       172
       172
       -
           | "/" | "/echo" -> echo_handler ~request ~body

     

       173
       173
       -
           | "/status/200" -> status_handler 200 ~request ~body

     

       174
       174
       -
           | "/status/404" -> status_handler 404 ~request ~body

     

       175
       175
       -
           | "/status/500" -> status_handler 500 ~request ~body

     

       176
       176
       -
           | "/redirect" -> redirect_handler "/redirected" ~request ~body

     

       177
       177
       -
           | "/redirected" ->

     

       178
       178
       -
               let resp = Http.Response.make ~status:`OK () in

     

       179
       179
       -
               (resp,"redirect successful")

     

       180
       180
       -
           | "/cookies" -> cookie_handler ~request ~body

     

       181
       181
       -
           | "/auth" -> auth_handler ~request ~body

     

       182
       182
       -
           | "/json" -> json_handler ~request ~body

     

       183
       183
       -
           | "/timeout" -> timeout_handler clock 2.0 ~request ~body

     

       184
       184
       -
           | "/chunked" ->

     

       185
       185
       -
               chunked_handler clock ["chunk1"; "chunk2"; "chunk3"] ~request ~body

     

       186
       186
       -
           | "/large" -> large_response_handler 10000 ~request ~body

     

       187
       187
       -
           | "/multipart" -> multipart_handler ~request ~body

     

       188
       188
       -
           | _ -> status_handler 404 ~request ~body

     

       189
       189
       -
       

     

       190
       190
       -
         let start_server ~port env =

     

       191
       191
       -
           Eio.Fiber.fork ~sw:env#sw (fun () ->

     

       192
       192
       -
             make_server ~port (router env#clock) env

     

       193
       193
       -
           );

     

       194
       194
       -
           Eio.Time.sleep env#clock 0.1

     

       195
       195
       -
       end

     

       196
       196
       -
       

     

       197
       197
       -
       let test_get_request () =

     

       198
       198
       -
         run @@ fun env ->

     

       199
       199
       -
         Eio.Switch.run @@ fun sw ->

     

       200
       200
       -
         let port = get_free_port () in

     

       201
       201
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       202
       202
       -
       

     

       203
       203
       -
         let test_env = object

     

       204
       204
       -
           method clock = env#clock

     

       205
       205
       -
           method net = env#net

     

       206
       206
       -
           method sw = sw

     

       207
       207
       -
         end in

     

       208
       208
       -
         Test_server.start_server ~port test_env;

     

       209
       209
       -
       

     

       210
       210
       -
         let req = Requests.create ~sw env in

     

       211
       211
       -
         let response = Requests.get req (base_url ^ "/echo") in

     

       212
       212
       -
       

     

       213
       213
       -
         Alcotest.(check int) "GET status" 200 (Requests.Response.status_code response);

     

       214
       214
       -
       

     

       215
       215
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       216
       216
       -
         let json = Yojson.Basic.from_string body_str in

     

       217
       217
       -
         let method_str =

     

       218
       218
       -
           json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string

     

       219
       219
       -
         in

     

       220
       220
       -
       

     

       221
       221
       -
         Alcotest.(check string) "GET method" "GET" method_str

     

       222
       222
       -
       

     

       223
       223
       -
       let test_post_request () =

     

       224
       224
       -
         run @@ fun env ->

     

       225
       225
       -
         Eio.Switch.run @@ fun sw ->

     

       226
       226
       -
         let port = get_free_port () in

     

       227
       227
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       228
       228
       -
       

     

       229
       229
       -
         let test_env = object

     

       230
       230
       -
           method clock = env#clock

     

       231
       231
       -
           method net = env#net

     

       232
       232
       -
           method sw = sw

     

       233
       233
       -
         end in

     

       234
       234
       -
         Test_server.start_server ~port test_env;

     

       235
       235
       -
       

     

       236
       236
       -
         let req = Requests.create ~sw env in

     

       237
       237
       -
         let body = Requests.Body.text "test post data" in

     

       238
       238
       -
         let response = Requests.post req ~body (base_url ^ "/echo") in

     

       239
       239
       -
       

     

       240
       240
       -
         Alcotest.(check int) "POST status" 200 (Requests.Response.status_code response);

     

       241
       241
       -
       

     

       242
       242
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       243
       243
       -
         let json = Yojson.Basic.from_string body_str in

     

       244
       244
       -
         let received_body =

     

       245
       245
       -
           json |> Yojson.Basic.Util.member "body" |> Yojson.Basic.Util.to_string

     

       246
       246
       -
         in

     

       247
       247
       -
       

     

       248
       248
       -
         Alcotest.(check string) "POST body" "test post data" received_body

     

       249
       249
       -
       

     

       250
       250
       -
       let test_put_request () =

     

       251
       251
       -
         run @@ fun env ->

     

       252
       252
       -
         Eio.Switch.run @@ fun sw ->

     

       253
       253
       -
         let port = get_free_port () in

     

       254
       254
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       255
       255
       -
       

     

       256
       256
       -
         let test_env = object

     

       257
       257
       -
           method clock = env#clock

     

       258
       258
       -
           method net = env#net

     

       259
       259
       -
           method sw = sw

     

       260
       260
       -
         end in

     

       261
       261
       -
         Test_server.start_server ~port test_env;

     

       262
       262
       -
       

     

       263
       263
       -
         let req = Requests.create ~sw env in

     

       264
       264
       -
         let body = Requests.Body.text "put data" in

     

       265
       265
       -
         let response = Requests.put req ~body (base_url ^ "/echo") in

     

       266
       266
       -
       

     

       267
       267
       -
         Alcotest.(check int) "PUT status" 200 (Requests.Response.status_code response);

     

       268
       268
       -
       

     

       269
       269
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       270
       270
       -
         let json = Yojson.Basic.from_string body_str in

     

       271
       271
       -
         let method_str =

     

       272
       272
       -
           json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string

     

       273
       273
       -
         in

     

       274
       274
       -
       

     

       275
       275
       -
         Alcotest.(check string) "PUT method" "PUT" method_str

     

       276
       276
       -
       

     

       277
       277
       -
       let test_delete_request () =

     

       278
       278
       -
         run @@ fun env ->

     

       279
       279
       -
         Eio.Switch.run @@ fun sw ->

     

       280
       280
       -
         let port = get_free_port () in

     

       281
       281
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       282
       282
       -
       

     

       283
       283
       -
         let test_env = object

     

       284
       284
       -
           method clock = env#clock

     

       285
       285
       -
           method net = env#net

     

       286
       286
       -
           method sw = sw

     

       287
       287
       -
         end in

     

       288
       288
       -
         Test_server.start_server ~port test_env;

     

       289
       289
       -
       

     

       290
       290
       -
         let req = Requests.create ~sw env in

     

       291
       291
       -
         let response = Requests.delete req (base_url ^ "/echo") in

     

       292
       292
       -
       

     

       293
       293
       -
         Alcotest.(check int) "DELETE status" 200 (Requests.Response.status_code response);

     

       294
       294
       -
       

     

       295
       295
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       296
       296
       -
         let json = Yojson.Basic.from_string body_str in

     

       297
       297
       -
         let method_str =

     

       298
       298
       -
           json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string

     

       299
       299
       -
         in

     

       300
       300
       -
       

     

       301
       301
       -
         Alcotest.(check string) "DELETE method" "DELETE" method_str

     

       302
       302
       -
       

     

       303
       303
       -
       let test_patch_request () =

     

       304
       304
       -
         run @@ fun env ->

     

       305
       305
       -
         Eio.Switch.run @@ fun sw ->

     

       306
       306
       -
         let port = get_free_port () in

     

       307
       307
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       308
       308
       -
       

     

       309
       309
       -
         let test_env = object

     

       310
       310
       -
           method clock = env#clock

     

       311
       311
       -
           method net = env#net

     

       312
       312
       -
           method sw = sw

     

       313
       313
       -
         end in

     

       314
       314
       -
         Test_server.start_server ~port test_env;

     

       315
       315
       -
       

     

       316
       316
       -
         let req = Requests.create ~sw env in

     

       317
       317
       -
         let body = Requests.Body.of_string Requests.Mime.json {|{"patch": "data"}|} in

     

       318
       318
       -
         let response = Requests.patch req ~body (base_url ^ "/echo") in

     

       319
       319
       -
       

     

       320
       320
       -
         Alcotest.(check int) "PATCH status" 200 (Requests.Response.status_code response);

     

       321
       321
       -
       

     

       322
       322
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       323
       323
       -
         let json = Yojson.Basic.from_string body_str in

     

       324
       324
       -
         let method_str =

     

       325
       325
       -
           json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string

     

       326
       326
       -
         in

     

       327
       327
       -
       

     

       328
       328
       -
         Alcotest.(check string) "PATCH method" "PATCH" method_str

     

       329
       329
       -
       

     

       330
       330
       -
       let test_head_request () =

     

       331
       331
       -
         run @@ fun env ->

     

       332
       332
       -
         Eio.Switch.run @@ fun sw ->

     

       333
       333
       -
         let port = get_free_port () in

     

       334
       334
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       335
       335
       -
       

     

       336
       336
       -
         let test_env = object

     

       337
       337
       -
           method clock = env#clock

     

       338
       338
       -
           method net = env#net

     

       339
       339
       -
           method sw = sw

     

       340
       340
       -
         end in

     

       341
       341
       -
         Test_server.start_server ~port test_env;

     

       342
       342
       -
       

     

       343
       343
       -
         let req = Requests.create ~sw env in

     

       344
       344
       -
         let response = Requests.head req (base_url ^ "/echo") in

     

       345
       345
       -
       

     

       346
       346
       -
         Alcotest.(check int) "HEAD status" 200 (Requests.Response.status_code response)

     

       347
       347
       -
       

     

       348
       348
       -
       let test_options_request () =

     

       349
       349
       -
         run @@ fun env ->

     

       350
       350
       -
         Eio.Switch.run @@ fun sw ->

     

       351
       351
       -
         let port = get_free_port () in

     

       352
       352
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       353
       353
       -
       

     

       354
       354
       -
         let test_env = object

     

       355
       355
       -
           method clock = env#clock

     

       356
       356
       -
           method net = env#net

     

       357
       357
       -
           method sw = sw

     

       358
       358
       -
         end in

     

       359
       359
       -
         Test_server.start_server ~port test_env;

     

       360
       360
       -
       

     

       361
       361
       -
         let req = Requests.create ~sw env in

     

       362
       362
       -
         let response = Requests.options req (base_url ^ "/echo") in

     

       363
       363
       -
       

     

       364
       364
       -
         Alcotest.(check int) "OPTIONS status" 200 (Requests.Response.status_code response)

     

       365
       365
       -
       

     

       366
       366
       -
       let test_custom_headers () =

     

       367
       367
       -
         run @@ fun env ->

     

       368
       368
       -
         Eio.Switch.run @@ fun sw ->

     

       369
       369
       -
         let port = get_free_port () in

     

       370
       370
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       371
       371
       -
       

     

       372
       372
       -
         let test_env = object

     

       373
       373
       -
           method clock = env#clock

     

       374
       374
       -
           method net = env#net

     

       375
       375
       -
           method sw = sw

     

       376
       376
       -
         end in

     

       377
       377
       -
         Test_server.start_server ~port test_env;

     

       378
       378
       -
       

     

       379
       379
       -
         let req = Requests.create ~sw env in

     

       380
       380
       -
         let headers =

     

       381
       381
       -
           Requests.Headers.empty

     

       382
       382
       -
           |> Requests.Headers.set "X-Custom-Header" "custom-value"

     

       383
       383
       -
           |> Requests.Headers.set "User-Agent" "test-agent"

     

       384
       384
       -
         in

     

       385
       385
       -
         let response = Requests.get req ~headers (base_url ^ "/echo") in

     

       386
       386
       -
       

     

       387
       387
       -
         Alcotest.(check int) "Headers status" 200 (Requests.Response.status_code response);

     

       388
       388
       -
       

     

       389
       389
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       390
       390
       -
         let json = Yojson.Basic.from_string body_str in

     

       391
       391
       -
         let headers_obj = json |> Yojson.Basic.Util.member "headers" in

     

       392
       392
       -
       

     

       393
       393
       -
         let custom_header =

     

       394
       394
       -
           headers_obj

     

       395
       395
       -
           |> Yojson.Basic.Util.member "x-custom-header"

     

       396
       396
       -
           |> Yojson.Basic.Util.to_string_option

     

       397
       397
       -
           |> Option.value ~default:""

     

       398
       398
       -
         in

     

       399
       399
       -
       

     

       400
       400
       -
         Alcotest.(check string) "Custom header" "custom-value" custom_header

     

       401
       401
       -
       

     

       402
       402
       -
       let test_query_params () =

     

       403
       403
       -
         run @@ fun env ->

     

       404
       404
       -
         Eio.Switch.run @@ fun sw ->

     

       405
       405
       -
         let port = get_free_port () in

     

       406
       406
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       407
       407
       -
       

     

       408
       408
       -
         let test_env = object

     

       409
       409
       -
           method clock = env#clock

     

       410
       410
       -
           method net = env#net

     

       411
       411
       -
           method sw = sw

     

       412
       412
       -
         end in

     

       413
       413
       -
         Test_server.start_server ~port test_env;

     

       414
       414
       -
       

     

       415
       415
       -
         let req = Requests.create ~sw env in

     

       416
       416
       -
         let params = [("key1", "value1"); ("key2", "value2")] in

     

       417
       417
       -
         let response = Requests.get req ~params (base_url ^ "/echo") in

     

       418
       418
       -
       

     

       419
       419
       -
         Alcotest.(check int) "Query params status" 200 (Requests.Response.status_code response);

     

       420
       420
       -
       

     

       421
       421
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       422
       422
       -
         let json = Yojson.Basic.from_string body_str in

     

       423
       423
       -
         let uri = json |> Yojson.Basic.Util.member "uri" |> Yojson.Basic.Util.to_string in

     

       424
       424
       -
       

     

       425
       425
       -
         Alcotest.(check bool) "Query params present" true

     

       426
       426
       -
           (string_contains uri "key1=value1" && string_contains uri "key2=value2")

     

       427
       427
       -
       

     

       428
       428
       -
       let test_json_body () =

     

       429
       429
       -
         run @@ fun env ->

     

       430
       430
       -
         Eio.Switch.run @@ fun sw ->

     

       431
       431
       -
         let port = get_free_port () in

     

       432
       432
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       433
       433
       -
       

     

       434
       434
       -
         let test_env = object

     

       435
       435
       -
           method clock = env#clock

     

       436
       436
       -
           method net = env#net

     

       437
       437
       -
           method sw = sw

     

       438
       438
       -
         end in

     

       439
       439
       -
         Test_server.start_server ~port test_env;

     

       440
       440
       -
       

     

       441
       441
       -
         let req = Requests.create ~sw env in

     

       442
       442
       -
         let json_data = {|{"name": "test", "value": 42}|} in

     

       443
       443
       -
         let body = Requests.Body.of_string Requests.Mime.json json_data in

     

       444
       444
       -
         let response = Requests.post req ~body (base_url ^ "/json") in

     

       445
       445
       -
       

     

       446
       446
       -
         Alcotest.(check int) "JSON body status" 200 (Requests.Response.status_code response);

     

       447
       447
       -
       

     

       448
       448
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       449
       449
       -
         let json = Yojson.Basic.from_string body_str in

     

       450
       450
       -
         let received = json |> Yojson.Basic.Util.member "received" in

     

       451
       451
       -
         let name = received |> Yojson.Basic.Util.member "name" |> Yojson.Basic.Util.to_string in

     

       452
       452
       -
       

     

       453
       453
       -
         Alcotest.(check string) "JSON field" "test" name

     

       454
       454
       -
       

     

       455
       455
       -
       let test_form_data () =

     

       456
       456
       -
         run @@ fun env ->

     

       457
       457
       -
         Eio.Switch.run @@ fun sw ->

     

       458
       458
       -
         let port = get_free_port () in

     

       459
       459
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       460
       460
       -
       

     

       461
       461
       -
         let test_env = object

     

       462
       462
       -
           method clock = env#clock

     

       463
       463
       -
           method net = env#net

     

       464
       464
       -
           method sw = sw

     

       465
       465
       -
         end in

     

       466
       466
       -
         Test_server.start_server ~port test_env;

     

       467
       467
       -
       

     

       468
       468
       -
         let req = Requests.create ~sw env in

     

       469
       469
       -
         let form_data = [("field1", "value1"); ("field2", "value2")] in

     

       470
       470
       -
         let body = Requests.Body.form form_data in

     

       471
       471
       -
         let response = Requests.post req ~body (base_url ^ "/echo") in

     

       472
       472
       -
       

     

       473
       473
       -
         Alcotest.(check int) "Form data status" 200 (Requests.Response.status_code response);

     

       474
       474
       -
       

     

       475
       475
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       476
       476
       -
         let json = Yojson.Basic.from_string body_str in

     

       477
       477
       -
         let received_body =

     

       478
       478
       -
           json |> Yojson.Basic.Util.member "body" |> Yojson.Basic.Util.to_string

     

       479
       479
       -
         in

     

       480
       480
       -
       

     

       481
       481
       -
         Alcotest.(check bool) "Form data encoded" true

     

       482
       482
       -
           (string_contains received_body "field1=value1" &&

     

       483
       483
       -
            string_contains received_body "field2=value2")

     

       484
       484
       -
       

     

       485
       485
       -
       let test_status_codes () =

     

       486
       486
       -
         run @@ fun env ->

     

       487
       487
       -
         Eio.Switch.run @@ fun sw ->

     

       488
       488
       -
         let port = get_free_port () in

     

       489
       489
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       490
       490
       -
       

     

       491
       491
       -
         let test_env = object

     

       492
       492
       -
           method clock = env#clock

     

       493
       493
       -
           method net = env#net

     

       494
       494
       -
           method sw = sw

     

       495
       495
       -
         end in

     

       496
       496
       -
         Test_server.start_server ~port test_env;

     

       497
       497
       -
       

     

       498
       498
       -
         let req = Requests.create ~sw env in

     

       499
       499
       -
       

     

       500
       500
       -
         let resp_200 = Requests.get req (base_url ^ "/status/200") in

     

       501
       501
       -
         Alcotest.(check int) "Status 200" 200 (Requests.Response.status_code resp_200);

     

       502
       502
       -
       

     

       503
       503
       -
         let resp_404 = Requests.get req (base_url ^ "/status/404") in

     

       504
       504
       -
         Alcotest.(check int) "Status 404" 404 (Requests.Response.status_code resp_404);

     

       505
       505
       -
       

     

       506
       506
       -
         let resp_500 = Requests.get req (base_url ^ "/status/500") in

     

       507
       507
       -
         Alcotest.(check int) "Status 500" 500 (Requests.Response.status_code resp_500)

     

       508
       508
       -
       

     

       509
       509
       -
       let test_redirects () =

     

       510
       510
       -
         run @@ fun env ->

     

       511
       511
       -
         Eio.Switch.run @@ fun sw ->

     

       512
       512
       -
         let port = get_free_port () in

     

       513
       513
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       514
       514
       -
       

     

       515
       515
       -
         let test_env = object

     

       516
       516
       -
           method clock = env#clock

     

       517
       517
       -
           method net = env#net

     

       518
       518
       -
           method sw = sw

     

       519
       519
       -
         end in

     

       520
       520
       -
         Test_server.start_server ~port test_env;

     

       521
       521
       -
       

     

       522
       522
       -
         let req = Requests.create ~sw ~follow_redirects:true env in

     

       523
       523
       -
         let response = Requests.get req (base_url ^ "/redirect") in

     

       524
       524
       -
       

     

       525
       525
       -
         Alcotest.(check int) "Redirect followed" 200 (Requests.Response.status_code response);

     

       526
       526
       -
       

     

       527
       527
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       528
       528
       -
         Alcotest.(check string) "Redirect result" "redirect successful" body_str

     

       529
       529
       -
       

     

       530
       530
       -
       let test_no_redirect () =

     

       531
       531
       -
         run @@ fun env ->

     

       532
       532
       -
         Eio.Switch.run @@ fun sw ->

     

       533
       533
       -
         let port = get_free_port () in

     

       534
       534
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       535
       535
       -
       

     

       536
       536
       -
         let test_env = object

     

       537
       537
       -
           method clock = env#clock

     

       538
       538
       -
           method net = env#net

     

       539
       539
       -
           method sw = sw

     

       540
       540
       -
         end in

     

       541
       541
       -
         Test_server.start_server ~port test_env;

     

       542
       542
       -
       

     

       543
       543
       -
         let req = Requests.create ~sw env in

     

       544
       544
       -
         let response = Requests.request req ~follow_redirects:false ~method_:`GET (base_url ^ "/redirect") in

     

       545
       545
       -
       

     

       546
       546
       -
         Alcotest.(check int) "Redirect not followed" 301

     

       547
       547
       -
           (Requests.Response.status_code response)

     

       548
       548
       -
       

     

       549
       549
       -
       let test_cookies () =

     

       550
       550
       -
         run @@ fun env ->

     

       551
       551
       -
         Eio.Switch.run @@ fun sw ->

     

       552
       552
       -
         let port = get_free_port () in

     

       553
       553
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       554
       554
       -
       

     

       555
       555
       -
         let test_env = object

     

       556
       556
       -
           method clock = env#clock

     

       557
       557
       -
           method net = env#net

     

       558
       558
       -
           method sw = sw

     

       559
       559
       -
         end in

     

       560
       560
       -
         Test_server.start_server ~port test_env;

     

       561
       561
       -
       

     

       562
       562
       -
         let req = Requests.create ~sw env in

     

       563
       563
       -
       

     

       564
       564
       -
         let _first_response = Requests.get req (base_url ^ "/cookies") in

     

       565
       565
       -
       

     

       566
       566
       -
         let second_response = Requests.get req (base_url ^ "/cookies") in

     

       567
       567
       -
         let body_str = Requests.Response.body second_response |> Eio.Flow.read_all in

     

       568
       568
       -
       

     

       569
       569
       -
         Alcotest.(check bool) "Cookies sent back" true

     

       570
       570
       -
           (string_contains body_str "test_cookie=test_value")

     

       571
       571
       -
       

     

       572
       572
       -
       let test_bearer_auth () =

     

       573
       573
       -
         run @@ fun env ->

     

       574
       574
       -
         Eio.Switch.run @@ fun sw ->

     

       575
       575
       -
         let port = get_free_port () in

     

       576
       576
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       577
       577
       -
       

     

       578
       578
       -
         let test_env = object

     

       579
       579
       -
           method clock = env#clock

     

       580
       580
       -
           method net = env#net

     

       581
       581
       -
           method sw = sw

     

       582
       582
       -
         end in

     

       583
       583
       -
         Test_server.start_server ~port test_env;

     

       584
       584
       -
       

     

       585
       585
       -
         let req = Requests.create ~sw env in

     

       586
       586
       -
         let auth = Requests.Auth.bearer ~token:"valid_token" in

     

       587
       587
       -
         let response = Requests.get req ~auth (base_url ^ "/auth") in

     

       588
       588
       -
       

     

       589
       589
       -
         Alcotest.(check int) "Bearer auth status" 200 (Requests.Response.status_code response);

     

       590
       590
       -
       

     

       591
       591
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       592
       592
       -
         Alcotest.(check string) "Bearer auth result" "authorized" body_str

     

       593
       593
       -
       

     

       594
       594
       -
       let test_basic_auth () =

     

       595
       595
       -
         run @@ fun env ->

     

       596
       596
       -
         Eio.Switch.run @@ fun sw ->

     

       597
       597
       -
         let port = get_free_port () in

     

       598
       598
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       599
       599
       -
       

     

       600
       600
       -
         let test_env = object

     

       601
       601
       -
           method clock = env#clock

     

       602
       602
       -
           method net = env#net

     

       603
       603
       -
           method sw = sw

     

       604
       604
       -
         end in

     

       605
       605
       -
         Test_server.start_server ~port test_env;

     

       606
       606
       -
       

     

       607
       607
       -
         let req = Requests.create ~sw env in

     

       608
       608
       -
         let auth = Requests.Auth.basic ~username:"user" ~password:"pass" in

     

       609
       609
       -
         let response = Requests.get req ~auth (base_url ^ "/auth") in

     

       610
       610
       -
       

     

       611
       611
       -
         Alcotest.(check int) "Basic auth status" 200 (Requests.Response.status_code response);

     

       612
       612
       -
       

     

       613
       613
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       614
       614
       -
         Alcotest.(check string) "Basic auth result" "basic auth received" body_str

     

       615
       615
       -
       

     

       616
       616
       -
       let test_timeout () =

     

       617
       617
       -
         run @@ fun env ->

     

       618
       618
       -
         Eio.Switch.run @@ fun sw ->

     

       619
       619
       -
         let port = get_free_port () in

     

       620
       620
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       621
       621
       -
       

     

       622
       622
       -
         let test_env = object

     

       623
       623
       -
           method clock = env#clock

     

       624
       624
       -
           method net = env#net

     

       625
       625
       -
           method sw = sw

     

       626
       626
       -
         end in

     

       627
       627
       -
         Test_server.start_server ~port test_env;

     

       628
       628
       -
       

     

       629
       629
       -
         let req = Requests.create ~sw env in

     

       630
       630
       -
         let timeout = Requests.Timeout.create ~total:0.5 () in

     

       631
       631
       -
       

     

       632
       632
       -
         let exception_raised =

     

       633
       633
       -
           try

     

       634
       634
       -
             let _ = Requests.get req ~timeout (base_url ^ "/timeout") in

     

       635
       635
       -
             false

     

       636
       636
       -
           with _ -> true

     

       637
       637
       -
         in

     

       638
       638
       -
       

     

       639
       639
       -
         Alcotest.(check bool) "Timeout triggered" true exception_raised

     

       640
       640
       -
       

     

       641
       641
       -
       let test_concurrent_requests () =

     

       642
       642
       -
         run @@ fun env ->

     

       643
       643
       -
         Eio.Switch.run @@ fun sw ->

     

       644
       644
       -
         let port = get_free_port () in

     

       645
       645
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       646
       646
       -
       

     

       647
       647
       -
         let test_env = object

     

       648
       648
       -
           method clock = env#clock

     

       649
       649
       -
           method net = env#net

     

       650
       650
       -
           method sw = sw

     

       651
       651
       -
         end in

     

       652
       652
       -
         Test_server.start_server ~port test_env;

     

       653
       653
       -
       

     

       654
       654
       -
         let req = Requests.create ~sw env in

     

       655
       655
       -
       

     

       656
       656
       -
         let r1 = ref None in

     

       657
       657
       -
         let r2 = ref None in

     

       658
       658
       -
         let r3 = ref None in

     

       659
       659
       -
       

     

       660
       660
       -
         Eio.Fiber.all [

     

       661
       661
       -
           (fun () -> r1 := Some (Requests.get req (base_url ^ "/status/200")));

     

       662
       662
       -
           (fun () -> r2 := Some (Requests.get req (base_url ^ "/status/404")));

     

       663
       663
       -
           (fun () -> r3 := Some (Requests.get req (base_url ^ "/status/500")));

     

       664
       664
       -
         ];

     

       665
       665
       -
       

     

       666
       666
       -
         let r1 = Option.get !r1 in

     

       667
       667
       -
         let r2 = Option.get !r2 in

     

       668
       668
       -
         let r3 = Option.get !r3 in

     

       669
       669
       -
       

     

       670
       670
       -
         Alcotest.(check int) "Concurrent 1" 200 (Requests.Response.status_code r1);

     

       671
       671
       -
         Alcotest.(check int) "Concurrent 2" 404 (Requests.Response.status_code r2);

     

       672
       672
       -
         Alcotest.(check int) "Concurrent 3" 500 (Requests.Response.status_code r3)

     

       673
       673
       -
       

     

       674
       674
       -
       let test_large_response () =

     

       675
       675
       -
         run @@ fun env ->

     

       676
       676
       -
         Eio.Switch.run @@ fun sw ->

     

       677
       677
       -
         let port = get_free_port () in

     

       678
       678
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       679
       679
       -
       

     

       680
       680
       -
         let test_env = object

     

       681
       681
       -
           method clock = env#clock

     

       682
       682
       -
           method net = env#net

     

       683
       683
       -
           method sw = sw

     

       684
       684
       -
         end in

     

       685
       685
       -
         Test_server.start_server ~port test_env;

     

       686
       686
       -
       

     

       687
       687
       -
         let req = Requests.create ~sw env in

     

       688
       688
       -
         let response = Requests.get req (base_url ^ "/large") in

     

       689
       689
       -
       

     

       690
       690
       -
         Alcotest.(check int) "Large response status" 200 (Requests.Response.status_code response);

     

       691
       691
       -
       

     

       692
       692
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       693
       693
       -
         Alcotest.(check int) "Large response size" 10000 (String.length body_str)

     

       694
       694
       -
       

     

       695
       695
       -
       let test_one_module () =

     

       696
       696
       -
         run @@ fun env ->

     

       697
       697
       -
         Eio.Switch.run @@ fun sw ->

     

       698
       698
       -
         let port = get_free_port () in

     

       699
       699
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       700
       700
       -
       

     

       701
       701
       -
         let test_env = object

     

       702
       702
       -
           method clock = env#clock

     

       703
       703
       -
           method net = env#net

     

       704
       704
       -
           method sw = sw

     

       705
       705
       -
         end in

     

       706
       706
       -
         Test_server.start_server ~port test_env;

     

       707
       707
       -
       

     

       708
       708
       -
         let response = Requests.One.get ~sw

     

       709
       709
       -
           ~clock:env#clock ~net:env#net

     

       710
       710
       -
           (base_url ^ "/echo")

     

       711
       711
       -
         in

     

       712
       712
       -
       

     

       713
       713
       -
         Alcotest.(check int) "One module status" 200 (Requests.Response.status_code response)

     

       714
       714
       -
       

     

       715
       715
       -
       let test_multipart () =

     

       716
       716
       -
         run @@ fun env ->

     

       717
       717
       -
         Eio.Switch.run @@ fun sw ->

     

       718
       718
       -
         let port = get_free_port () in

     

       719
       719
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       720
       720
       -
       

     

       721
       721
       -
         let test_env = object

     

       722
       722
       -
           method clock = env#clock

     

       723
       723
       -
           method net = env#net

     

       724
       724
       -
           method sw = sw

     

       725
       725
       -
         end in

     

       726
       726
       -
         Test_server.start_server ~port test_env;

     

       727
       727
       -
       

     

       728
       728
       -
         let req = Requests.create ~sw env in

     

       729
       729
       -
         let parts = [

     

       730
       730
       -
           { Requests.Body.name = "field1";

     

       731
       731
       -
             filename = None;

     

       732
       732
       -
             content_type = Requests.Mime.text;

     

       733
       733
       -
             content = `String "value1" };

     

       734
       734
       -
           { Requests.Body.name = "field2";

     

       735
       735
       -
             filename = Some "test.txt";

     

       736
       736
       -
             content_type = Requests.Mime.text;

     

       737
       737
       -
             content = `String "file content" };

     

       738
       738
       -
         ] in

     

       739
       739
       -
         let body = Requests.Body.multipart parts in

     

       740
       740
       -
         let response = Requests.post req ~body (base_url ^ "/multipart") in

     

       741
       741
       -
       

     

       742
       742
       -
         Alcotest.(check int) "Multipart status" 200 (Requests.Response.status_code response);

     

       743
       743
       -
       

     

       744
       744
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       745
       745
       -
         Alcotest.(check bool) "Multipart recognized" true

     

       746
       746
       -
           (String.starts_with ~prefix:"Multipart received:" body_str)

     

       747
       747
       -
       

     

       748
       748
       -
       let test_response_headers () =

     

       749
       749
       -
         run @@ fun env ->

     

       750
       750
       -
         Eio.Switch.run @@ fun sw ->

     

       751
       751
       -
         let port = get_free_port () in

     

       752
       752
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       753
       753
       -
       

     

       754
       754
       -
         let test_env = object

     

       755
       755
       -
           method clock = env#clock

     

       756
       756
       -
           method net = env#net

     

       757
       757
       -
           method sw = sw

     

       758
       758
       -
         end in

     

       759
       759
       -
         Test_server.start_server ~port test_env;

     

       760
       760
       -
       

     

       761
       761
       -
         let req = Requests.create ~sw env in

     

       762
       762
       -
         let response = Requests.get req (base_url ^ "/json") in

     

       763
       763
       -
       

     

       764
       764
       -
         let content_type =

     

       765
       765
       -
           Requests.Response.headers response

     

       766
       766
       -
           |> Requests.Headers.get "content-type"

     

       767
       767
       -
         in

     

       768
       768
       -
       

     

       769
       769
       -
         Alcotest.(check (option string)) "Response content-type"

     

       770
       770
       -
           (Some "application/json") content_type

     

       771
       771
       -
       

     

       772
       772
       -
       let test_default_headers () =

     

       773
       773
       -
         run @@ fun env ->

     

       774
       774
       -
         Eio.Switch.run @@ fun sw ->

     

       775
       775
       -
         let port = get_free_port () in

     

       776
       776
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       777
       777
       -
       

     

       778
       778
       -
         let test_env = object

     

       779
       779
       -
           method clock = env#clock

     

       780
       780
       -
           method net = env#net

     

       781
       781
       -
           method sw = sw

     

       782
       782
       -
         end in

     

       783
       783
       -
         Test_server.start_server ~port test_env;

     

       784
       784
       -
       

     

       785
       785
       -
         let default_headers =

     

       786
       786
       -
           Requests.Headers.empty

     

       787
       787
       -
           |> Requests.Headers.set "X-Default" "default-value"

     

       788
       788
       -
         in

     

       789
       789
       -
         let req = Requests.create ~sw ~default_headers env in

     

       790
       790
       -
         let response = Requests.get req (base_url ^ "/echo") in

     

       791
       791
       -
       

     

       792
       792
       -
         let body_str = Requests.Response.body response |> Eio.Flow.read_all in

     

       793
       793
       -
         let json = Yojson.Basic.from_string body_str in

     

       794
       794
       -
         let headers_obj = json |> Yojson.Basic.Util.member "headers" in

     

       795
       795
       -
       

     

       796
       796
       -
         let default_header =

     

       797
       797
       -
           headers_obj

     

       798
       798
       -
           |> Yojson.Basic.Util.member "x-default"

     

       799
       799
       -
           |> Yojson.Basic.Util.to_string_option

     

       800
       800
       -
           |> Option.value ~default:""

     

       801
       801
       -
         in

     

       802
       802
       -
       

     

       803
       803
       -
         Alcotest.(check string) "Default header present" "default-value" default_header

     

       804
       804
       -
       

     

       805
       805
       -
       let test_session_persistence () =

     

       806
       806
       -
         run @@ fun env ->

     

       807
       807
       -
         Eio.Switch.run @@ fun sw ->

     

       808
       808
       -
         let port = get_free_port () in

     

       809
       809
       -
         let base_url = Printf.sprintf "http://127.0.0.1:%d" port in

     

       810
       810
       -
       

     

       811
       811
       -
         let test_env = object

     

       812
       812
       -
           method clock = env#clock

     

       813
       813
       -
           method net = env#net

     

       814
       814
       -
           method sw = sw

     

       815
       815
       -
         end in

     

       816
       816
       -
         Test_server.start_server ~port test_env;

     

       817
       817
       -
       

     

       818
       818
       -
         let req = Requests.create ~sw env in

     

       819
       819
       -
       

     

       820
       820
       -
         let req = Requests.set_default_header req "X-Session" "session-123" in

     

       821
       821
       -
       

     

       822
       822
       -
         let auth = Requests.Auth.bearer ~token:"test_token" in

     

       823
       823
       -
         let req = Requests.set_auth req auth in

     

       824
       824
       -
       

     

       825
       825
       -
         let response1 = Requests.get req (base_url ^ "/echo") in

     

       826
       826
       -
         let body_str1 = Requests.Response.body response1 |> Eio.Flow.read_all in

     

       827
       827
       -
         let json1 = Yojson.Basic.from_string body_str1 in

     

       828
       828
       -
         let headers1 = json1 |> Yojson.Basic.Util.member "headers" in

     

       829
       829
       -
       

     

       830
       830
       -
         let session_header =

     

       831
       831
       -
           headers1

     

       832
       832
       -
           |> Yojson.Basic.Util.member "x-session"

     

       833
       833
       -
           |> Yojson.Basic.Util.to_string_option

     

       834
       834
       -
           |> Option.value ~default:""

     

       835
       835
       -
         in

     

       836
       836
       -
       

     

       837
       837
       -
         Alcotest.(check string) "Session header persisted" "session-123" session_header;

     

       838
       838
       -
       

     

       839
       839
       -
         let req = Requests.remove_default_header req "X-Session" in

     

       840
       840
       -
       

     

       841
       841
       -
         let response2 = Requests.get req (base_url ^ "/echo") in

     

       842
       842
       -
         let body_str2 = Requests.Response.body response2 |> Eio.Flow.read_all in

     

       843
       843
       -
         let json2 = Yojson.Basic.from_string body_str2 in

     

       844
       844
       -
         let headers2 = json2 |> Yojson.Basic.Util.member "headers" in

     

       845
       845
       -
       

     

       846
       846
       -
         let session_header2 =

     

       847
       847
       -
           headers2

     

       848
       848
       -
           |> Yojson.Basic.Util.member "x-session"

     

       849
       849
       -
           |> Yojson.Basic.Util.to_string_option

     

       850
       850
       -
         in

     

       851
       851
       -
       

     

       852
       852
       -
         Alcotest.(check (option string)) "Session header removed" None session_header2

     

       853
       853
       -
       

     

       854
       854
       -
       let () =

     

       855
       855
       -
         Logs.set_reporter (Logs.format_reporter ());

     

       856
       856
       -
         Logs.set_level (Some Logs.Warning);

     

       857
       857
       -
       

     

       858
       858
       -
         let open Alcotest in

     

       859
       859
       -
         run "Requests Tests" [

     

       860
       860
       -
           "HTTP Methods", [

     

       861
       861
       -
             test_case "GET request" `Quick test_get_request;

     

       862
       862
       -
             test_case "POST request" `Quick test_post_request;

     

       863
       863
       -
             test_case "PUT request" `Quick test_put_request;

     

       864
       864
       -
             test_case "DELETE request" `Quick test_delete_request;

     

       865
       865
       -
             test_case "PATCH request" `Quick test_patch_request;

     

       866
       866
       -
             test_case "HEAD request" `Quick test_head_request;

     

       867
       867
       -
             test_case "OPTIONS request" `Quick test_options_request;

     

       868
       868
       -
           ];

     

       869
       869
       -
           "Request Features", [

     

       870
       870
       -
             test_case "Custom headers" `Quick test_custom_headers;

     

       871
       871
       -
             test_case "Query parameters" `Quick test_query_params;

     

       872
       872
       -
             test_case "JSON body" `Quick test_json_body;

     

       873
       873
       -
             test_case "Form data" `Quick test_form_data;

     

       874
       874
       -
             test_case "Multipart upload" `Quick test_multipart;

     

       875
       875
       -
             test_case "Default headers" `Quick test_default_headers;

     

       876
       876
       -
           ];

     

       877
       877
       -
           "Response Handling", [

     

       878
       878
       -
             test_case "Status codes" `Quick test_status_codes;

     

       879
       879
       -
             test_case "Response headers" `Quick test_response_headers;

     

       880
       880
       -
             test_case "Large response" `Quick test_large_response;

     

       881
       881
       -
           ];

     

       882
       882
       -
           "Redirects", [

     

       883
       883
       -
             test_case "Follow redirects" `Quick test_redirects;

     

       884
       884
       -
             test_case "No follow redirects" `Quick test_no_redirect;

     

       885
       885
       -
           ];

     

       886
       886
       -
           "Authentication", [

     

       887
       887
       -
             test_case "Bearer auth" `Quick test_bearer_auth;

     

       888
       888
       -
             test_case "Basic auth" `Quick test_basic_auth;

     

       889
       889
       -
           ];

     

       890
       890
       -
           "Session Features", [

     

       891
       891
       -
             test_case "Cookies" `Quick test_cookies;

     

       892
       892
       -
             test_case "Session persistence" `Quick test_session_persistence;

     

       893
       893
       -
           ];

     

       894
       894
       -
           "Advanced", [

     

       895
       895
       -
             test_case "Timeout handling" `Quick test_timeout;

     

       896
       896
       -
             test_case "Concurrent requests" `Quick test_concurrent_requests;

     

       897
       897
       -
             test_case "One module" `Quick test_one_module;

     

       898
       898
       -
           ];

     

       899
       899
       -
         ]

+2 -1

stack/requests_json_api/dune-project

+1 -1

stack/requests_json_api/lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (public_name requests_json_api)

     

       3
       3
        
        (name requests_json_api)

     

       4
       4
       -
        (libraries requests eio ezjsonm))

     

       4
       4
       +
        (libraries requests eio jsont jsont.bytesrw))

+83 -15

stack/requests_json_api/lib/requests_json_api.ml

···

       27
       27
        
       

     

       28
       28
        
       (** {1 JSON Helpers} *)

     

       29
       29
        
       

     

       30
       30
       -
       let parse_json parser body_str =

     

       31
       31
       -
         Ezjsonm.from_string body_str |> parser

     

       30
       30
       +
       let parse_json decoder body_str =

     

       31
       31
       +
         match Jsont_bytesrw.decode_string' decoder body_str with

     

       32
       32
       +
         | Ok v -> v

     

       33
       33
       +
         | Error e -> failwith (Fmt.str "JSON parse error: %s" (Jsont.Error.to_string e))

     

       32
       34
        
       

     

       33
       33
       -
       let parse_json_result parser body_str =

     

       34
       34
       -
         try Ok (parse_json parser body_str)

     

       35
       35
       -
         with exn -> Error (Printexc.to_string exn)

     

       35
       35
       +
       let parse_json_result decoder body_str =

     

       36
       36
       +
         match Jsont_bytesrw.decode_string' decoder body_str with

     

       37
       37
       +
         | Ok v -> Ok v

     

       38
       38
       +
         | Error e -> Error (Jsont.Error.to_string e)

     

       36
       39
        
       

     

       37
       37
       -
       let get_json_exn session url parser =

     

       40
       40
       +
       let get_json_exn session url decoder =

     

       38
       41
        
         let response = Requests.get session url in

     

       39
       42
        
         let status = Requests.Response.status_code response in

     

       40
       43
        
         if status < 200 || status >= 300 then

     

       41
       44
        
           failwith (Printf.sprintf "HTTP %d" status);

     

       42
       42
       -
         read_body response |> parse_json parser

     

       45
       45
       +
         read_body response |> parse_json decoder

     

       43
       46
        
       

     

       44
       44
       -
       let get_json session url parser =

     

       47
       47
       +
       let get_json session url decoder =

     

       45
       48
        
         match get_result session url with

     

       46
       49
        
         | Ok body ->

     

       47
       47
       -
             (match parse_json_result parser body with

     

       50
       50
       +
             (match parse_json_result decoder body with

     

       48
       51
        
              | Ok result -> Ok result

     

       49
       52
        
              | Error msg -> Error (`Json_error msg))

     

       50
       53
        
         | Error (status, body) -> Error (`Http (status, body))

     

       51
       54
        
       

     

       52
       52
       -
       let post_json session url json_value =

     

       53
       53
       -
         let body_str = Ezjsonm.value_to_string json_value in

     

       55
       55
       +
       let post_json session url jsont_codec value =

     

       56
       56
       +
         let body_str = match Jsont_bytesrw.encode_string' jsont_codec value with

     

       57
       57
       +
           | Ok s -> s

     

       58
       58
       +
           | Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))

     

       59
       59
       +
         in

     

       54
       60
        
         let body = Requests.Body.of_string Requests.Mime.json body_str in

     

       55
       61
        
         Requests.post session url ~body

     

       56
       62
        
       

     

       57
       57
       -
       let post_json_exn session url json_value =

     

       58
       58
       -
         let response = post_json session url json_value in

     

       63
       63
       +
       let post_json_exn session url jsont_codec value =

     

       64
       64
       +
         let response = post_json session url jsont_codec value in

     

       59
       65
        
         let status = Requests.Response.status_code response in

     

       60
       66
        
         if status < 200 || status >= 300 then

     

       61
       67
        
           failwith (Printf.sprintf "HTTP %d" status);

     

       62
       68
        
         read_body response

     

       63
       69
        
       

     

       64
       64
       -
       let post_json_result session url json_value =

     

       70
       70
       +
       let post_json_result session url jsont_codec value =

     

       65
       71
        
         try

     

       66
       66
       -
           let response = post_json session url json_value in

     

       72
       72
       +
           let response = post_json session url jsont_codec value in

     

       67
       73
        
           check_2xx response

     

       68
       74
        
         with exn ->

     

       69
       75
        
           Error (0, Printexc.to_string exn)

     

       76
       76
       +
       

     

       77
       77
       +
       let post_json_decode_exn session url ~req req_value ~resp =

     

       78
       78
       +
         let response = post_json session url req req_value in

     

       79
       79
       +
         let status = Requests.Response.status_code response in

     

       80
       80
       +
         if status < 200 || status >= 300 then

     

       81
       81
       +
           failwith (Printf.sprintf "HTTP %d" status);

     

       82
       82
       +
         read_body response |> parse_json resp

     

       83
       83
       +
       

     

       84
       84
       +
       let post_json_decode session url ~req req_value ~resp =

     

       85
       85
       +
         try

     

       86
       86
       +
           let response = post_json session url req req_value in

     

       87
       87
       +
           match check_2xx response with

     

       88
       88
       +
           | Ok body ->

     

       89
       89
       +
               (match parse_json_result resp body with

     

       90
       90
       +
                | Ok result -> Ok result

     

       91
       91
       +
                | Error msg -> Error (`Json_error msg))

     

       92
       92
       +
           | Error (status, body) -> Error (`Http (status, body))

     

       93
       93
       +
         with exn ->

     

       94
       94
       +
           Error (`Http (0, Printexc.to_string exn))

     

       95
       95
       +
       

     

       96
       96
       +
       let put_json_exn session url jsont_codec value =

     

       97
       97
       +
         let body_str = match Jsont_bytesrw.encode_string' jsont_codec value with

     

       98
       98
       +
           | Ok s -> s

     

       99
       99
       +
           | Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))

     

       100
       100
       +
         in

     

       101
       101
       +
         let body = Requests.Body.of_string Requests.Mime.json body_str in

     

       102
       102
       +
         let response = Requests.put session url ~body in

     

       103
       103
       +
         let status = Requests.Response.status_code response in

     

       104
       104
       +
         if status < 200 || status >= 300 then

     

       105
       105
       +
           failwith (Printf.sprintf "HTTP %d" status);

     

       106
       106
       +
         read_body response

     

       107
       107
       +
       

     

       108
       108
       +
       let put_json_decode_exn session url ~req req_value ~resp =

     

       109
       109
       +
         let body_str = match Jsont_bytesrw.encode_string' req req_value with

     

       110
       110
       +
           | Ok s -> s

     

       111
       111
       +
           | Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))

     

       112
       112
       +
         in

     

       113
       113
       +
         let body = Requests.Body.of_string Requests.Mime.json body_str in

     

       114
       114
       +
         let response = Requests.put session url ~body in

     

       115
       115
       +
         let status = Requests.Response.status_code response in

     

       116
       116
       +
         if status < 200 || status >= 300 then

     

       117
       117
       +
           failwith (Printf.sprintf "HTTP %d" status);

     

       118
       118
       +
         read_body response |> parse_json resp

     

       119
       119
       +
       

     

       120
       120
       +
       let patch_json_exn session url jsont_codec value =

     

       121
       121
       +
         let body_str = match Jsont_bytesrw.encode_string' jsont_codec value with

     

       122
       122
       +
           | Ok s -> s

     

       123
       123
       +
           | Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))

     

       124
       124
       +
         in

     

       125
       125
       +
         let body = Requests.Body.of_string Requests.Mime.json body_str in

     

       126
       126
       +
         let response = Requests.patch session url ~body in

     

       127
       127
       +
         let status = Requests.Response.status_code response in

     

       128
       128
       +
         if status < 200 || status >= 300 then

     

       129
       129
       +
           failwith (Printf.sprintf "HTTP %d" status);

     

       130
       130
       +
         read_body response

     

       131
       131
       +
       

     

       132
       132
       +
       let delete_json_exn session url =

     

       133
       133
       +
         let response = Requests.delete session url in

     

       134
       134
       +
         let status = Requests.Response.status_code response in

     

       135
       135
       +
         if status < 200 || status >= 300 then

     

       136
       136
       +
           failwith (Printf.sprintf "HTTP %d" status);

     

       137
       137
       +
         read_body response

     

       70
       138
        
       

     

       71
       139
        
       (** {1 URL Helpers} *)

     

       72
       140

+51 -13

stack/requests_json_api/lib/requests_json_api.mli

···

       8
       8
        
           {[

     

       9
       9
        
             open Requests_json_api

     

       10
       10
        
       

     

       11
       11
       +
             (* Define a Jsont codec for your type *)

     

       12
       12
       +
             type user = { id : int; name : string }

     

       13
       13
       +
       

     

       14
       14
       +
             let user_jsont =

     

       15
       15
       +
               Jsont.Object.map (fun id name -> { id; name })

     

       16
       16
       +
               |> Jsont.Object.mem "id" Jsont.int ~enc:(fun u -> u.id)

     

       17
       17
       +
               |> Jsont.Object.mem "name" Jsont.string ~enc:(fun u -> u.name)

     

       18
       18
       +
               |> Jsont.Object.finish

     

       19
       19
       +
       

     

       20
       20
       +
             let users_jsont = Jsont.list user_jsont

     

       21
       21
       +
       

     

       11
       22
        
             let fetch_users session =

     

       12
       12
       -
               get_json_exn session (base_url / "users") parse_users

     

       23
       23
       +
               get_json_exn session (base_url / "users") users_jsont

     

       13
       24
        
           ]}

     

       14
       25
        
       *)

     

       15
       26
        
       

     

       16
       27
        
       (** {1 JSON Request Helpers} *)

     

       17
       28
        
       

     

       18
       18
       -
       val get_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> (Ezjsonm.value -> 'a) -> 'a

     

       19
       19
       -
       (** [get_json_exn session url parser] makes a GET request, checks status is 2xx,

     

       20
       20
       -
           reads and parses JSON body, then applies the parser function.

     

       29
       29
       +
       val get_json_exn : Requests.t -> string -> 'a Jsont.t -> 'a

     

       30
       30
       +
       (** [get_json_exn session url decoder] makes a GET request, checks status is 2xx,

     

       31
       31
       +
           reads and parses JSON body using the provided Jsont decoder.

     

       21
       32
        
           Raises [Failure] on any error (HTTP, network, or JSON parse). *)

     

       22
       33
        
       

     

       23
       23
       -
       val get_json : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> (Ezjsonm.value -> 'a) ->

     

       34
       34
       +
       val get_json : Requests.t -> string -> 'a Jsont.t ->

     

       24
       35
        
         ('a, [> `Http of int * string | `Json_error of string]) result

     

       25
       36
        
       (** Like [get_json_exn] but returns [Result] instead of raising exceptions.

     

       26
       37
        
           Returns [Ok parsed_value] on success, or [Error] with details on failure. *)

     

       27
       38
        
       

     

       28
       28
       -
       val post_json : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> Ezjsonm.value -> Requests.Response.t

     

       29
       29
       -
       (** [post_json session url json_value] creates a JSON request body and POSTs it to the URL.

     

       39
       39
       +
       val post_json : Requests.t -> string -> 'a Jsont.t -> 'a -> Requests.Response.t

     

       40
       40
       +
       (** [post_json session url codec value] encodes [value] using the Jsont codec and POSTs it to the URL.

     

       30
       41
        
           Returns the raw response for custom handling. *)

     

       31
       42
        
       

     

       32
       32
       -
       val post_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> Ezjsonm.value -> string

     

       43
       43
       +
       val post_json_exn : Requests.t -> string -> 'a Jsont.t -> 'a -> string

     

       33
       44
        
       (** Like [post_json] but checks status is 2xx and returns the response body as a string.

     

       34
       45
        
           Raises [Failure] on non-2xx status. *)

     

       35
       46
        
       

     

       36
       36
       -
       val post_json_result : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> Ezjsonm.value ->

     

       47
       47
       +
       val post_json_result : Requests.t -> string -> 'a Jsont.t -> 'a ->

     

       37
       48
        
         (string, int * string) result

     

       38
       49
        
       (** Like [post_json_exn] but returns [Result] instead of raising.

     

       39
       50
        
           [Ok body] on 2xx status, [Error (status, body)] otherwise. *)

     

       40
       51
        
       

     

       52
       52
       +
       val post_json_decode_exn : Requests.t -> string ->

     

       53
       53
       +
         req:'a Jsont.t -> 'a -> resp:'b Jsont.t -> 'b

     

       54
       54
       +
       (** [post_json_decode_exn session url ~req req_value ~resp] encodes [req_value] using the [req] codec,

     

       55
       55
       +
           POSTs it to the URL, checks status is 2xx, and decodes the response using the [resp] codec.

     

       56
       56
       +
           Raises [Failure] on any error. *)

     

       57
       57
       +
       

     

       58
       58
       +
       val post_json_decode : Requests.t -> string ->

     

       59
       59
       +
         req:'a Jsont.t -> 'a -> resp:'b Jsont.t ->

     

       60
       60
       +
         ('b, [> `Http of int * string | `Json_error of string]) result

     

       61
       61
       +
       (** Like [post_json_decode_exn] but returns [Result] instead of raising. *)

     

       62
       62
       +
       

     

       63
       63
       +
       val put_json_exn : Requests.t -> string -> 'a Jsont.t -> 'a -> string

     

       64
       64
       +
       (** [put_json_exn session url codec value] encodes [value] and PUTs it to the URL.

     

       65
       65
       +
           Returns response body. Raises [Failure] on non-2xx status. *)

     

       66
       66
       +
       

     

       67
       67
       +
       val put_json_decode_exn : Requests.t -> string ->

     

       68
       68
       +
         req:'a Jsont.t -> 'a -> resp:'b Jsont.t -> 'b

     

       69
       69
       +
       (** Like [post_json_decode_exn] but uses PUT method. *)

     

       70
       70
       +
       

     

       71
       71
       +
       val patch_json_exn : Requests.t -> string -> 'a Jsont.t -> 'a -> string

     

       72
       72
       +
       (** [patch_json_exn session url codec value] encodes [value] and PATCHes it to the URL.

     

       73
       73
       +
           Returns response body. Raises [Failure] on non-2xx status. *)

     

       74
       74
       +
       

     

       75
       75
       +
       val delete_json_exn : Requests.t -> string -> string

     

       76
       76
       +
       (** [delete_json_exn session url] makes a DELETE request.

     

       77
       77
       +
           Returns response body. Raises [Failure] on non-2xx status. *)

     

       78
       78
       +
       

     

       41
       79
        
       (** {1 JSON Parsing Helpers} *)

     

       42
       80
        
       

     

       43
       43
       -
       val parse_json : (Ezjsonm.value -> 'a) -> string -> 'a

     

       44
       44
       -
       (** [parse_json parser body_str] parses a JSON string and applies the parser function.

     

       81
       81
       +
       val parse_json : 'a Jsont.t -> string -> 'a

     

       82
       82
       +
       (** [parse_json decoder body_str] parses a JSON string using the provided Jsont decoder.

     

       45
       83
        
           Raises exception on parse error. *)

     

       46
       84
        
       

     

       47
       47
       -
       val parse_json_result : (Ezjsonm.value -> 'a) -> string -> ('a, string) result

     

       85
       85
       +
       val parse_json_result : 'a Jsont.t -> string -> ('a, string) result

     

       48
       86
        
       (** Like [parse_json] but returns [Result] on parse error instead of raising. *)

     

       49
       87
        
       

     

       50
       88
        
       (** {1 Low-Level Helpers} *)

     
···

       53
       91
        
       (** [read_body response] reads the entire response body as a string.

     

       54
       92
        
           Equivalent to [Requests.Response.body response |> Eio.Flow.read_all] *)

     

       55
       93
        
       

     

       56
       56
       -
       val get_result : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> (string, int * string) result

     

       94
       94
       +
       val get_result : Requests.t -> string -> (string, int * string) result

     

       57
       95
        
       (** [get_result session url] makes a GET request and returns the result.

     

       58
       96
        
           Returns [Ok body] on 2xx status, [Error (status, body)] otherwise. *)

     

       59
       97

+2 -1

stack/requests_json_api/requests_json_api.opam

···

       13
       13
        
         "dune" {>= "3.0"}

     

       14
       14
        
         "requests"

     

       15
       15
        
         "eio"

     

       16
       16
       -
         "ezjsonm"

     

       16
       16
       +
         "jsont"

     

       17
       17
       +
         "bytesrw"

     

       17
       18
        
         "odoc" {with-doc}

     

       18
       19
        
       ]

     

       19
       20
        
       build: [

+1 -1

stack/river/bin/dune

···

       1
       1
        
       (executable

     

       2
       2
        
        (public_name river-cli)

     

       3
       3
        
        (name river_cli)

     

       4
       4
       -
        (libraries river cmdliner yojson fmt fmt.tty fmt.cli eio eio_main eiocmd unix ptime syndic xdge))

     

       4
       4
       +
        (libraries river cmdliner jsont jsont.bytesrw fmt fmt.tty fmt.cli eio eio_main eiocmd unix ptime syndic xdge))

+36 -38

stack/river/bin/river_cli.ml

···

       38
       38
        
             with Eio.Io (Eio.Fs.E (Already_exists _), _) -> ()

     

       39
       39
        
           ) dirs

     

       40
       40
        
       

     

       41
       41
       -
         let user_of_json json =

     

       42
       42
       -
           let open Yojson.Safe.Util in

     

       43
       43
       -
           try

     

       44
       44
       -
             let feeds_json = json |> member "feeds" |> to_list in

     

       45
       45
       -
             let feeds = List.map (fun feed ->

     

       46
       46
       -
               { River.name = feed |> member "name" |> to_string;

     

       47
       47
       -
                 url = feed |> member "url" |> to_string }

     

       48
       48
       -
             ) feeds_json in

     

       49
       49
       -
             Some {

     

       50
       50
       -
               username = json |> member "username" |> to_string;

     

       51
       51
       -
               fullname = json |> member "fullname" |> to_string;

     

       52
       52
       -
               email = json |> member "email" |> to_string_option;

     

       53
       53
       -
               feeds;

     

       54
       54
       -
               last_synced = json |> member "last_synced" |> to_string_option;

     

       55
       55
       -
             }

     

       56
       56
       -
           with _ -> None

     

       41
       41
       +
         (* JSON codecs for user data *)

     

       42
       42
       +
       

     

       43
       43
       +
         (* Codec for River.source (feed) *)

     

       44
       44
       +
         let source_jsont =

     

       45
       45
       +
           let make name url = { River.name; url } in

     

       46
       46
       +
           Jsont.Object.map ~kind:"Source" make

     

       47
       47
       +
           |> Jsont.Object.mem "name" Jsont.string ~enc:(fun s -> s.River.name)

     

       48
       48
       +
           |> Jsont.Object.mem "url" Jsont.string ~enc:(fun s -> s.River.url)

     

       49
       49
       +
           |> Jsont.Object.finish

     

       50
       50
       +
       

     

       51
       51
       +
         (* Codec for user *)

     

       52
       52
       +
         let user_jsont =

     

       53
       53
       +
           let make username fullname email feeds last_synced =

     

       54
       54
       +
             { username; fullname; email; feeds; last_synced }

     

       55
       55
       +
           in

     

       56
       56
       +
           Jsont.Object.map ~kind:"User" make

     

       57
       57
       +
           |> Jsont.Object.mem "username" Jsont.string ~enc:(fun u -> u.username)

     

       58
       58
       +
           |> Jsont.Object.mem "fullname" Jsont.string ~enc:(fun u -> u.fullname)

     

       59
       59
       +
           |> Jsont.Object.opt_mem "email" Jsont.string ~enc:(fun u -> u.email)

     

       60
       60
       +
           |> Jsont.Object.mem "feeds" (Jsont.list source_jsont) ~enc:(fun u -> u.feeds)

     

       61
       61
       +
           |> Jsont.Object.opt_mem "last_synced" Jsont.string ~enc:(fun u -> u.last_synced)

     

       62
       62
       +
           |> Jsont.Object.finish

     

       63
       63
       +
       

     

       64
       64
       +
         let user_of_string s =

     

       65
       65
       +
           match Jsont_bytesrw.decode_string' user_jsont s with

     

       66
       66
       +
           | Ok user -> Some user

     

       67
       67
       +
           | Error err ->

     

       68
       68
       +
               Log.err (fun m -> m "Failed to parse user JSON: %s" (Jsont.Error.to_string err));

     

       69
       69
       +
               None

     

       70
       70
       +
       

     

       71
       71
       +
         let user_to_string user =

     

       72
       72
       +
           match Jsont_bytesrw.encode_string' ~format:Jsont.Indent user_jsont user with

     

       73
       73
       +
           | Ok s -> s

     

       74
       74
       +
           | Error err -> failwith ("Failed to encode user: " ^ Jsont.Error.to_string err)

     

       57
       75
        
       

     

       58
       76
        
         let load_user state username =

     

       59
       77
        
           let file = user_file state username in

     

       60
       78
        
           try

     

       61
       79
        
             let content = Eio.Path.load file in

     

       62
       62
       -
             let json = Yojson.Safe.from_string content in

     

       63
       63
       -
             user_of_json json

     

       80
       80
       +
             user_of_string content

     

       64
       81
        
           with

     

       65
       82
        
           | Eio.Io (Eio.Fs.E (Not_found _), _) -> None

     

       66
       83
        
           | e ->

     

       67
       84
        
             Log.err (fun m -> m "Error loading user %s: %s" username (Printexc.to_string e));

     

       68
       85
        
             None

     

       69
       86
        
       

     

       70
       70
       -
         let user_to_json user =

     

       71
       71
       -
           let feeds_json = List.map (fun feed ->

     

       72
       72
       -
             `Assoc [

     

       73
       73
       -
               "name", `String feed.River.name;

     

       74
       74
       -
               "url", `String feed.River.url;

     

       75
       75
       -
             ]

     

       76
       76
       -
           ) user.feeds in

     

       77
       77
       -
           `Assoc [

     

       78
       78
       -
             "username", `String user.username;

     

       79
       79
       -
             "fullname", `String user.fullname;

     

       80
       80
       -
             "email", (match user.email with

     

       81
       81
       -
               | Some e -> `String e

     

       82
       82
       -
               | None -> `Null);

     

       83
       83
       -
             "feeds", `List feeds_json;

     

       84
       84
       -
             "last_synced", (match user.last_synced with

     

       85
       85
       -
               | Some s -> `String s

     

       86
       86
       -
               | None -> `Null);

     

       87
       87
       -
           ]

     

       88
       88
       -
       

     

       89
       87
        
         let save_user state user =

     

       90
       88
        
           let file = user_file state user.username in

     

       91
       91
       -
           let json = user_to_json user |> Yojson.Safe.to_string ~std:true in

     

       89
       89
       +
           let json = user_to_string user in

     

       92
       90
        
           Eio.Path.save ~create:(`Or_truncate 0o644) file json

     

       93
       91
        
       

     

       94
       92
        
         let list_users state =

+1 -2

stack/river/dune-project

···

       37
       37
        
         lambdasoup

     

       38
       38
        
         uri

     

       39
       39
        
         (cmdliner (>= 2.0.0))

     

       40
       40
       -
         yojson

     

       41
       40
        
         fmt

     

       42
       41
        
         xdge

     

       43
       42
        
         (jsonfeed (>= 1.1.0))

     

       44
       43
        
         (jsont (>= 0.2.0))

     

       45
       45
       -
         bytesrw

     

       44
       44
       +
         (jsont.bytesrw (>= 0.2.0))

     

       46
       45
        
         (odoc :with-doc)))

+1 -2

stack/river/lib/client.ml

···

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

     

       22
       22
        
       

     

       23
       23
        
       type t = {

     

       24
       24
       -
         session : (float Eio.Time.clock_ty Eio.Resource.t,

     

       25
       25
       -
                    [`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t;

     

       24
       24
       +
         session : Requests.t;

     

       26
       25
        
       }

     

       27
       26
        
       

     

       28
       27
        
       let create ~sw (env : _ ) =

+1 -2

stack/river/lib/client.mli

···

       54
       54
        
       (** [session t] returns the underlying Requests session.

     

       55
       55
        
       

     

       56
       56
        
           This is used internally by River's HTTP functions. *)

     

       57
       57
       -
       val session : t -> (float Eio.Time.clock_ty Eio.Resource.t,

     

       58
       58
       -
                           [`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t

     

       57
       57
       +
       val session : t -> Requests.t

+1 -1

stack/river/lib/dune

···

       2
       2
        
        (name river)

     

       3
       3
        
        (public_name river)

     

       4
       4
        
        (wrapped false)

     

       5
       5
       -
        (libraries eio eio_main requests requests_json_api logs str syndic lambdasoup uri ptime jsonfeed jsont bytesrw))

     

       5
       5
       +
        (libraries eio eio_main requests requests_json_api logs str syndic lambdasoup uri ptime jsonfeed jsont jsont.bytesrw cacheio xdge))

+264 -189

stack/river/lib/river_store.ml

···

       1
       1
        
       (*

     

       2
       2
       -
        * Persistent storage for Atom feed entries using Cacheio

     

       2
       2
       +
        * Persistent storage for Atom feed entries using Cacheio and Jsonfeed

     

       3
       3
        
        *)

     

       4
       4
        
       

     

       5
       5
        
       let src = Logs.Src.create "river.store" ~doc:"River persistent storage"

     
···

       7
       7
        
       

     

       8
       8
        
       (* Types *)

     

       9
       9
        
       

     

       10
       10
       -
       type stored_entry = {

     

       11
       11
       -
         atom_id : string;

     

       12
       12
       -
         title : string;

     

       13
       13
       -
         link : Uri.t option;

     

       14
       14
       -
         published : Ptime.t option;

     

       15
       15
       -
         updated : Ptime.t;

     

       16
       16
       -
         author_name : string;

     

       17
       17
       -
         author_email : string option;

     

       18
       18
       -
         content : string;

     

       10
       10
       +
       (* Storage metadata that extends Jsonfeed.Item via unknown fields *)

     

       11
       11
       +
       type storage_meta = {

     

       19
       12
        
         feed_url : string;

     

       20
       13
        
         feed_name : string;

     

       21
       14
        
         feed_title : string;

     

       22
       15
        
         stored_at : Ptime.t;

     

       23
       23
       -
         tags : string list;

     

       24
       24
       -
         summary : string option;

     

       16
       16
       +
       }

     

       17
       17
       +
       

     

       18
       18
       +
       (* A stored entry is a Jsonfeed.Item.t with storage metadata in unknown fields *)

     

       19
       19
       +
       type stored_entry = {

     

       20
       20
       +
         item : Jsonfeed.Item.t;

     

       21
       21
       +
         meta : storage_meta;

     

       25
       22
        
       }

     

       23
       23
       +
       

     

       24
       24
       +
       (* Stored entry accessors *)

     

       25
       25
       +
       let entry_item entry = entry.item

     

       26
       26
       +
       let entry_feed_url entry = entry.meta.feed_url

     

       27
       27
       +
       let entry_feed_name entry = entry.meta.feed_name

     

       28
       28
       +
       let entry_feed_title entry = entry.meta.feed_title

     

       29
       29
       +
       let entry_stored_at entry = entry.meta.stored_at

     

       26
       30
        
       

     

       27
       31
        
       type feed_info = {

     

       28
       32
        
         url : string;

     
···

       54
       58
        
         let feed_key = make_feed_key feed_url in

     

       55
       59
        
         feed_key ^ "/meta.json"

     

       56
       60
        
       

     

       57
       57
       -
       (* JSON serialization *)

     

       61
       61
       +
       (* JSON serialization using Jsonfeed and Jsont *)

     

       58
       62
        
       

     

       59
       59
       -
       let entry_to_json entry =

     

       60
       60
       -
         `Assoc [

     

       61
       61
       -
           "atom_id", `String entry.atom_id;

     

       62
       62
       -
           "title", `String entry.title;

     

       63
       63
       -
           "link", (match entry.link with

     

       64
       64
       -
             | Some u -> `String (Uri.to_string u)

     

       65
       65
       -
             | None -> `Null);

     

       66
       66
       -
           "published", (match entry.published with

     

       67
       67
       -
             | Some t -> `String (Ptime.to_rfc3339 t)

     

       68
       68
       -
             | None -> `Null);

     

       69
       69
       -
           "updated", `String (Ptime.to_rfc3339 entry.updated);

     

       70
       70
       -
           "author_name", `String entry.author_name;

     

       71
       71
       -
           "author_email", (match entry.author_email with Some e -> `String e | None -> `Null);

     

       72
       72
       -
           "content", `String entry.content;

     

       73
       73
       -
           "feed_url", `String entry.feed_url;

     

       74
       74
       -
           "feed_name", `String entry.feed_name;

     

       75
       75
       -
           "feed_title", `String entry.feed_title;

     

       76
       76
       -
           "stored_at", `String (Ptime.to_rfc3339 entry.stored_at);

     

       77
       77
       -
           "tags", `List (List.map (fun t -> `String t) entry.tags);

     

       78
       78
       -
           "summary", (match entry.summary with Some s -> `String s | None -> `Null);

     

       79
       79
       -
         ]

     

       63
       63
       +
       (* Storage metadata codec - stores feed info and storage timestamp *)

     

       64
       64
       +
       let storage_meta_jsont : storage_meta Jsont.t =

     

       65
       65
       +
         Jsont.Object.(

     

       66
       66
       +
           map ~kind:"StorageMeta" (fun feed_url feed_name feed_title stored_at : storage_meta ->

     

       67
       67
       +
             { feed_url; feed_name; feed_title; stored_at })

     

       68
       68
       +
           |> mem "x_river_feed_url" Jsont.string ~enc:(fun m -> m.feed_url)

     

       69
       69
       +
           |> mem "x_river_feed_name" Jsont.string ~enc:(fun m -> m.feed_name)

     

       70
       70
       +
           |> mem "x_river_feed_title" Jsont.string ~enc:(fun m -> m.feed_title)

     

       71
       71
       +
           |> mem "x_river_stored_at" Jsonfeed.Rfc3339.jsont ~enc:(fun m -> m.stored_at)

     

       72
       72
       +
           |> finish

     

       73
       73
       +
         )

     

       80
       74
        
       

     

       81
       81
       -
       let entry_of_json json =

     

       82
       82
       -
         let open Yojson.Safe.Util in

     

       83
       83
       -
         let parse_time s =

     

       84
       84
       -
           match Ptime.of_rfc3339 s with

     

       85
       85
       -
           | Ok (t, _, _) -> t

     

       86
       86
       -
           | Error _ -> failwith ("Invalid timestamp: " ^ s)

     

       75
       75
       +
       (* Codec for feed_info *)

     

       76
       76
       +
       let feed_meta_jsont : feed_info Jsont.t =

     

       77
       77
       +
         Jsont.Object.(

     

       78
       78
       +
           map ~kind:"FeedInfo" (fun url name title last_updated entry_count : feed_info ->

     

       79
       79
       +
             { url; name; title; last_updated; entry_count })

     

       80
       80
       +
           |> mem "url" Jsont.string ~enc:(fun (m : feed_info) -> m.url)

     

       81
       81
       +
           |> mem "name" Jsont.string ~enc:(fun m -> m.name)

     

       82
       82
       +
           |> mem "title" Jsont.string ~enc:(fun m -> m.title)

     

       83
       83
       +
           |> mem "last_updated" Jsonfeed.Rfc3339.jsont ~enc:(fun m -> m.last_updated)

     

       84
       84
       +
           |> mem "entry_count" Jsont.int ~enc:(fun m -> m.entry_count)

     

       85
       85
       +
           |> finish

     

       86
       86
       +
         )

     

       87
       87
       +
       

     

       88
       88
       +
       (* Helper to create item with storage metadata in unknown fields *)

     

       89
       89
       +
       let merge_storage_meta item meta =

     

       90
       90
       +
         let meta_json = Jsont_bytesrw.encode_string' storage_meta_jsont meta

     

       91
       91
       +
                         |> Result.get_ok in

     

       92
       92
       +
         let meta_unknown = Jsont_bytesrw.decode_string' Jsont.json meta_json

     

       93
       93
       +
                            |> Result.get_ok in

     

       94
       94
       +
         Jsonfeed.Item.create

     

       95
       95
       +
           ~id:(Jsonfeed.Item.id item)

     

       96
       96
       +
           ~content:(Jsonfeed.Item.content item)

     

       97
       97
       +
           ?url:(Jsonfeed.Item.url item)

     

       98
       98
       +
           ?external_url:(Jsonfeed.Item.external_url item)

     

       99
       99
       +
           ?title:(Jsonfeed.Item.title item)

     

       100
       100
       +
           ?summary:(Jsonfeed.Item.summary item)

     

       101
       101
       +
           ?image:(Jsonfeed.Item.image item)

     

       102
       102
       +
           ?banner_image:(Jsonfeed.Item.banner_image item)

     

       103
       103
       +
           ?date_published:(Jsonfeed.Item.date_published item)

     

       104
       104
       +
           ?date_modified:(Jsonfeed.Item.date_modified item)

     

       105
       105
       +
           ?authors:(Jsonfeed.Item.authors item)

     

       106
       106
       +
           ?tags:(Jsonfeed.Item.tags item)

     

       107
       107
       +
           ?language:(Jsonfeed.Item.language item)

     

       108
       108
       +
           ?attachments:(Jsonfeed.Item.attachments item)

     

       109
       109
       +
           ?references:(Jsonfeed.Item.references item)

     

       110
       110
       +
           ~unknown:meta_unknown

     

       111
       111
       +
           ()

     

       112
       112
       +
       

     

       113
       113
       +
       (* Helper to extract storage metadata from item's unknown fields *)

     

       114
       114
       +
       let extract_storage_meta item =

     

       115
       115
       +
         let unknown = Jsonfeed.Item.unknown item in

     

       116
       116
       +
         let meta_str = Jsont_bytesrw.encode_string' Jsont.json unknown |> Result.get_ok in

     

       117
       117
       +
         match Jsont_bytesrw.decode_string' storage_meta_jsont meta_str with

     

       118
       118
       +
         | Ok meta -> meta

     

       119
       119
       +
         | Error e -> failwith ("Missing storage metadata: " ^ Jsont.Error.to_string e)

     

       120
       120
       +
       

     

       121
       121
       +
       (* Stored entry codec - just wraps Jsonfeed.Item.jsont *)

     

       122
       122
       +
       let stored_entry_jsont : stored_entry Jsont.t =

     

       123
       123
       +
         let kind = "StoredEntry" in

     

       124
       124
       +
         let of_string s =

     

       125
       125
       +
           match Jsont_bytesrw.decode_string' Jsonfeed.Item.jsont s with

     

       126
       126
       +
           | Ok item -> Ok { item; meta = extract_storage_meta item }

     

       127
       127
       +
           | Error e -> Error (Jsont.Error.to_string e)

     

       128
       128
       +
         in

     

       129
       129
       +
         let enc entry =

     

       130
       130
       +
           let item_with_meta = merge_storage_meta entry.item entry.meta in

     

       131
       131
       +
           match Jsont_bytesrw.encode_string' Jsonfeed.Item.jsont item_with_meta with

     

       132
       132
       +
           | Ok s -> s

     

       133
       133
       +
           | Error e -> failwith ("Failed to encode: " ^ Jsont.Error.to_string e)

     

       87
       134
        
         in

     

       88
       88
       -
         {

     

       89
       89
       -
           atom_id = json |> member "atom_id" |> to_string;

     

       90
       90
       -
           title = json |> member "title" |> to_string;

     

       91
       91
       -
           link = json |> member "link" |> to_string_option |> Option.map Uri.of_string;

     

       92
       92
       -
           published = json |> member "published" |> to_string_option |> Option.map parse_time;

     

       93
       93
       -
           updated = json |> member "updated" |> to_string |> parse_time;

     

       94
       94
       -
           author_name = json |> member "author_name" |> to_string;

     

       95
       95
       -
           author_email = json |> member "author_email" |> to_string_option;

     

       96
       96
       -
           content = json |> member "content" |> to_string;

     

       97
       97
       -
           feed_url = json |> member "feed_url" |> to_string;

     

       98
       98
       -
           feed_name = json |> member "feed_name" |> to_string;

     

       99
       99
       -
           feed_title = json |> member "feed_title" |> to_string;

     

       100
       100
       -
           stored_at = json |> member "stored_at" |> to_string |> parse_time;

     

       101
       101
       -
           tags = (try json |> member "tags" |> to_list |> List.map to_string with _ -> []);

     

       102
       102
       -
           summary = (try json |> member "summary" |> to_string_option with _ -> None);

     

       103
       103
       -
         }

     

       135
       135
       +
         Jsont.of_of_string ~kind of_string ~enc

     

       136
       136
       +
       

     

       137
       137
       +
       (* Encode/decode functions *)

     

       138
       138
       +
       let entry_to_string entry =

     

       139
       139
       +
         match Jsont_bytesrw.encode_string' stored_entry_jsont entry with

     

       140
       140
       +
         | Ok s -> s

     

       141
       141
       +
         | Error err -> failwith ("Failed to encode entry: " ^ Jsont.Error.to_string err)

     

       142
       142
       +
       

     

       143
       143
       +
       let entry_of_string s =

     

       144
       144
       +
         match Jsont_bytesrw.decode_string' stored_entry_jsont s with

     

       145
       145
       +
         | Ok entry -> entry

     

       146
       146
       +
         | Error err -> failwith ("Failed to parse entry: " ^ Jsont.Error.to_string err)

     

       104
       147
        
       

     

       105
       105
       -
       let feed_meta_to_json meta =

     

       106
       106
       -
         `Assoc [

     

       107
       107
       -
           "url", `String meta.url;

     

       108
       108
       -
           "name", `String meta.name;

     

       109
       109
       -
           "title", `String meta.title;

     

       110
       110
       -
           "last_updated", `String (Ptime.to_rfc3339 meta.last_updated);

     

       111
       111
       -
         ]

     

       148
       148
       +
       let feed_meta_to_string meta =

     

       149
       149
       +
         match Jsont_bytesrw.encode_string' feed_meta_jsont meta with

     

       150
       150
       +
         | Ok s -> s

     

       151
       151
       +
         | Error err -> failwith ("Failed to encode feed metadata: " ^ Jsont.Error.to_string err)

     

       112
       152
        
       

     

       113
       113
       -
       let feed_meta_of_json json =

     

       114
       114
       -
         let open Yojson.Safe.Util in

     

       115
       115
       -
         let parse_time s =

     

       116
       116
       -
           match Ptime.of_rfc3339 s with

     

       117
       117
       -
           | Ok (t, _, _) -> t

     

       118
       118
       -
           | Error _ -> failwith ("Invalid timestamp: " ^ s)

     

       119
       119
       -
         in

     

       120
       120
       -
         {

     

       121
       121
       -
           url = json |> member "url" |> to_string;

     

       122
       122
       -
           name = json |> member "name" |> to_string;

     

       123
       123
       -
           title = json |> member "title" |> to_string;

     

       124
       124
       -
           last_updated = json |> member "last_updated" |> to_string |> parse_time;

     

       125
       125
       -
           entry_count = 0; (* Will be counted separately *)

     

       126
       126
       -
         }

     

       153
       153
       +
       let feed_meta_of_string s =

     

       154
       154
       +
         match Jsont_bytesrw.decode_string' feed_meta_jsont s with

     

       155
       155
       +
         | Ok meta -> meta

     

       156
       156
       +
         | Error err -> failwith ("Failed to parse feed metadata: " ^ Jsont.Error.to_string err)

     

       127
       157
        
       

     

       128
       158
        
       (* Store creation *)

     

       129
       159
        
       

     
···

       142
       172
        
         Log.info (fun m -> m "Created River store with XDG at %a" Eio.Path.pp base_dir);

     

       143
       173
        
         { cache; base_dir }

     

       144
       174
        
       

     

       145
       145
       -
       (* Convert Post.t to stored_entry *)

     

       146
       146
       -
       let entry_of_post ~feed_url ~feed_name ~feed_title (post : Post.t) =

     

       147
       147
       -
         let atom_id = post.id in  (* Use the post's unique ID *)

     

       148
       148
       -
         let updated = match post.date with

     

       149
       149
       -
           | Some d -> d

     

       150
       150
       -
           | None -> Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get

     

       175
       175
       +
       (* Convert Post.t to Jsonfeed.Item.t *)

     

       176
       176
       +
       let item_of_post ~feed_url ~feed_name ~feed_title (post : Post.t) =

     

       177
       177
       +
         let content =

     

       178
       178
       +
           let html = Soup.to_string post.content in

     

       179
       179
       +
           `Html html

     

       151
       180
        
         in

     

       152
       152
       -
         let published = post.date in

     

       153
       153
       -
         {

     

       154
       154
       -
           atom_id;

     

       155
       155
       -
           title = post.title;

     

       156
       156
       -
           link = post.link;

     

       157
       157
       -
           published;

     

       158
       158
       -
           updated;

     

       159
       159
       -
           author_name = post.author;

     

       160
       160
       -
           author_email = if post.email = "" then None else Some post.email;

     

       161
       161
       -
           content = Soup.to_string post.content;

     

       181
       181
       +
         let url = Option.map Uri.to_string post.link in

     

       182
       182
       +
         let authors =

     

       183
       183
       +
           if post.author = "" then None

     

       184
       184
       +
           else Some [Jsonfeed.Author.create ~name:post.author ()]

     

       185
       185
       +
         in

     

       186
       186
       +
         let tags = if post.tags = [] then None else Some post.tags in

     

       187
       187
       +
         let item = Jsonfeed.Item.create

     

       188
       188
       +
           ~id:post.id

     

       189
       189
       +
           ~content

     

       190
       190
       +
           ?url

     

       191
       191
       +
           ?title:(if post.title = "" then None else Some post.title)

     

       192
       192
       +
           ?summary:post.summary

     

       193
       193
       +
           ?date_published:post.date

     

       194
       194
       +
           ?date_modified:post.date

     

       195
       195
       +
           ?authors

     

       196
       196
       +
           ?tags

     

       197
       197
       +
           ()

     

       198
       198
       +
         in

     

       199
       199
       +
         let meta = {

     

       162
       200
        
           feed_url;

     

       163
       201
        
           feed_name;

     

       164
       202
        
           feed_title;

     

       165
       203
        
           stored_at = Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get;

     

       166
       166
       -
           tags = post.tags;

     

       167
       167
       -
           summary = post.summary;

     

       168
       168
       -
         }

     

       204
       204
       +
         } in

     

       205
       205
       +
         { item; meta }

     

       169
       206
        
       

     

       170
       170
       -
       (* Convert Syndic.Atom.entry to stored_entry *)

     

       171
       171
       -
       let entry_of_atom ~feed_url ~feed_name ~feed_title (atom_entry : Syndic.Atom.entry) =

     

       207
       207
       +
       (* Convert Syndic.Atom.entry to Jsonfeed.Item.t *)

     

       208
       208
       +
       let item_of_atom ~feed_url ~feed_name ~feed_title (atom_entry : Syndic.Atom.entry) =

     

       172
       209
        
         let atom_id = Uri.to_string atom_entry.id in

     

       173
       173
       -
         let updated = atom_entry.updated in

     

       174
       174
       -
         let published = match atom_entry.published with

     

       210
       210
       +
         let date_modified = atom_entry.updated in

     

       211
       211
       +
         let date_published = match atom_entry.published with

     

       175
       212
        
           | Some p -> Some p

     

       176
       213
        
           | None -> Some atom_entry.updated

     

       177
       214
        
         in

     

       178
       178
       -
         (* Extract author info - Syndic doesn't expose person record fields,

     

       179
       179
       -
            so we'll use placeholders and reconstruct via Atom.author later *)

     

       180
       180
       -
         let content = match atom_entry.content with

     

       181
       181
       -
           | Some (Syndic.Atom.Text s) -> s

     

       182
       182
       -
           | Some (Syndic.Atom.Html (_, s)) -> s

     

       215
       215
       +
         (* Extract content *)

     

       216
       216
       +
         let content_html = match atom_entry.content with

     

       217
       217
       +
           | Some (Syndic.Atom.Text s) -> Some s

     

       218
       218
       +
           | Some (Syndic.Atom.Html (_, s)) -> Some s

     

       183
       219
        
           | Some (Syndic.Atom.Xhtml (_, nodes)) ->

     

       184
       220
        
               let ns_prefix _ = Some "" in

     

       185
       185
       -
               String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) nodes)

     

       186
       186
       -
           | Some (Syndic.Atom.Mime _) | Some (Syndic.Atom.Src _) | None ->

     

       187
       187
       -
               (match atom_entry.summary with

     

       188
       188
       -
               | Some (Syndic.Atom.Text s) -> s

     

       189
       189
       -
               | Some (Syndic.Atom.Html (_, s)) -> s

     

       190
       190
       -
               | Some (Syndic.Atom.Xhtml (_, nodes)) ->

     

       191
       191
       -
                   let ns_prefix _ = Some "" in

     

       192
       192
       -
                   String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) nodes)

     

       193
       193
       -
               | None -> "")

     

       221
       221
       +
               Some (String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) nodes))

     

       222
       222
       +
           | Some (Syndic.Atom.Mime _) | Some (Syndic.Atom.Src _) | None -> None

     

       223
       223
       +
         in

     

       224
       224
       +
         let content_text = match atom_entry.summary with

     

       225
       225
       +
           | Some s -> Some (Util.string_of_text_construct s)

     

       226
       226
       +
           | None -> None

     

       227
       227
       +
         in

     

       228
       228
       +
         let content = match content_html, content_text with

     

       229
       229
       +
           | Some h, Some t -> `Both (h, t)

     

       230
       230
       +
           | Some h, None -> `Html h

     

       231
       231
       +
           | None, Some t -> `Text t

     

       232
       232
       +
           | None, None -> `Text "" (* Fallback *)

     

       194
       233
        
         in

     

       195
       195
       -
         let link = try

     

       196
       196
       -
           Some (List.find (fun l -> l.Syndic.Atom.rel = Syndic.Atom.Alternate) atom_entry.links).href

     

       234
       234
       +
         let url = try

     

       235
       235
       +
           Some (Uri.to_string (List.find (fun l -> l.Syndic.Atom.rel = Syndic.Atom.Alternate) atom_entry.links).href)

     

       197
       236
        
         with Not_found ->

     

       198
       237
        
           match atom_entry.links with

     

       199
       199
       -
           | l :: _ -> Some l.href

     

       238
       238
       +
           | l :: _ -> Some (Uri.to_string l.href)

     

       200
       239
        
           | [] -> None

     

       201
       240
        
         in

     

       202
       202
       -
         (* Extract tags from categories *)

     

       203
       203
       -
         let tags = List.map (fun cat -> cat.Syndic.Atom.term) atom_entry.categories in

     

       204
       204
       -
         (* Extract summary *)

     

       241
       241
       +
         let tags =

     

       242
       242
       +
           let cat_tags = List.map (fun cat -> cat.Syndic.Atom.term) atom_entry.categories in

     

       243
       243
       +
           if cat_tags = [] then None else Some cat_tags

     

       244
       244
       +
         in

     

       205
       245
        
         let summary = match atom_entry.summary with

     

       206
       246
        
           | Some s -> Some (Util.string_of_text_construct s)

     

       207
       247
        
           | None -> None

     

       208
       248
        
         in

     

       209
       209
       -
         {

     

       210
       210
       -
           atom_id;

     

       211
       211
       -
           title = Util.string_of_text_construct atom_entry.title;

     

       212
       212
       -
           link;

     

       213
       213
       -
           published;

     

       214
       214
       -
           updated;

     

       215
       215
       -
           author_name = feed_name; (* Use feed name as fallback *)

     

       216
       216
       -
           author_email = None;

     

       217
       217
       -
           content;

     

       249
       249
       +
         let item = Jsonfeed.Item.create

     

       250
       250
       +
           ~id:atom_id

     

       251
       251
       +
           ~content

     

       252
       252
       +
           ?url

     

       253
       253
       +
           ~title:(Util.string_of_text_construct atom_entry.title)

     

       254
       254
       +
           ?summary

     

       255
       255
       +
           ?date_published

     

       256
       256
       +
           ~date_modified

     

       257
       257
       +
           ?tags

     

       258
       258
       +
           ()

     

       259
       259
       +
         in

     

       260
       260
       +
         let meta = {

     

       218
       261
        
           feed_url;

     

       219
       262
        
           feed_name;

     

       220
       263
        
           feed_title;

     

       221
       264
        
           stored_at = Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get;

     

       222
       222
       -
           tags;

     

       223
       223
       -
           summary;

     

       224
       224
       -
         }

     

       265
       265
       +
         } in

     

       266
       266
       +
         { item; meta }

     

       225
       267
        
       

     

       226
       268
        
       (* Feed metadata management *)

     

       227
       269
        
       let update_feed_meta store ~feed_url ~feed_name ~feed_title ~sw:_ =

     
···

       233
       275
        
           last_updated = Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get;

     

       234
       276
        
           entry_count = 0;

     

       235
       277
        
         } in

     

       236
       236
       -
         let json = feed_meta_to_json meta |> Yojson.Safe.to_string in

     

       237
       237
       -
         let source = Eio.Flow.string_source json in

     

       278
       278
       +
         let json_str = feed_meta_to_string meta in

     

       279
       279
       +
         let source = Eio.Flow.string_source json_str in

     

       238
       280
        
         Cacheio.put store.cache ~key ~source ~ttl:None ();

     

       239
       281
        
         Log.debug (fun m -> m "Updated feed metadata for %s" feed_url)

     

       240
       282
        
       

     
···

       245
       287
        
         | Some source ->

     

       246
       288
        
             try

     

       247
       289
        
               let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in

     

       248
       248
       -
               let json = Yojson.Safe.from_string json_str in

     

       249
       249
       -
               Some (feed_meta_of_json json)

     

       290
       290
       +
               Some (feed_meta_of_string json_str)

     

       250
       291
        
             with e ->

     

       251
       292
        
               Log.err (fun m -> m "Failed to parse feed metadata: %s" (Printexc.to_string e));

     

       252
       293
        
               None

     
···

       254
       295
        
       (* Entry storage *)

     

       255
       296
        
       

     

       256
       297
        
       let store_entry store ~feed_url ~feed_name ~feed_title ~post ~sw =

     

       257
       257
       -
         let entry = entry_of_post ~feed_url ~feed_name ~feed_title post in

     

       258
       258
       -
         let key = make_entry_key feed_url entry.atom_id in

     

       259
       259
       -
         let json = entry_to_json entry |> Yojson.Safe.to_string in

     

       260
       260
       -
         let source = Eio.Flow.string_source json in

     

       298
       298
       +
         let entry = item_of_post ~feed_url ~feed_name ~feed_title post in

     

       299
       299
       +
         let key = make_entry_key feed_url (Jsonfeed.Item.id entry.item) in

     

       300
       300
       +
         let json_str = entry_to_string entry in

     

       301
       301
       +
         let source = Eio.Flow.string_source json_str in

     

       261
       302
        
         Cacheio.put store.cache ~key ~source ~ttl:None ();

     

       262
       262
       -
         Log.debug (fun m -> m "Stored entry %s for feed %s" entry.atom_id feed_url);

     

       303
       303
       +
         Log.debug (fun m -> m "Stored entry %s for feed %s" (Jsonfeed.Item.id entry.item) feed_url);

     

       263
       304
        
         (* Update feed metadata *)

     

       264
       305
        
         update_feed_meta store ~feed_url ~feed_name ~feed_title ~sw

     

       265
       306
        
       

     
···

       273
       314
        
       let store_atom_entries store ~feed_url ~feed_name ~feed_title ~entries ~sw =

     

       274
       315
        
         Log.info (fun m -> m "Storing %d Atom entries for feed %s" (List.length entries) feed_url);

     

       275
       316
        
         List.iter (fun atom_entry ->

     

       276
       276
       -
           let entry = entry_of_atom ~feed_url ~feed_name ~feed_title atom_entry in

     

       277
       277
       -
           let key = make_entry_key feed_url entry.atom_id in

     

       278
       278
       -
           let json = entry_to_json entry |> Yojson.Safe.to_string in

     

       279
       279
       -
           let source = Eio.Flow.string_source json in

     

       317
       317
       +
           let entry = item_of_atom ~feed_url ~feed_name ~feed_title atom_entry in

     

       318
       318
       +
           let key = make_entry_key feed_url (Jsonfeed.Item.id entry.item) in

     

       319
       319
       +
           let json_str = entry_to_string entry in

     

       320
       320
       +
           let source = Eio.Flow.string_source json_str in

     

       280
       321
        
           Cacheio.put store.cache ~key ~source ~ttl:None ();

     

       281
       281
       -
           Log.debug (fun m -> m "Stored Atom entry %s" entry.atom_id);

     

       322
       322
       +
           Log.debug (fun m -> m "Stored Atom entry %s" (Jsonfeed.Item.id entry.item));

     

       282
       323
        
         ) entries;

     

       283
       324
        
         update_feed_meta store ~feed_url ~feed_name ~feed_title ~sw;

     

       284
       325
        
         Log.info (fun m -> m "Stored %d Atom entries for feed %s" (List.length entries) feed_url)

     
···

       292
       333
        
         | Some source ->

     

       293
       334
        
             try

     

       294
       335
        
               let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in

     

       295
       295
       -
               let json = Yojson.Safe.from_string json_str in

     

       296
       296
       -
               Some (entry_of_json json)

     

       336
       336
       +
               Some (entry_of_string json_str)

     

       297
       337
        
             with e ->

     

       298
       338
        
               Log.err (fun m -> m "Failed to parse entry: %s" (Printexc.to_string e));

     

       299
       339
        
               None

     
···

       311
       351
        
             | Some source ->

     

       312
       352
        
                 try

     

       313
       353
        
                   let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in

     

       314
       314
       -
                   let json = Yojson.Safe.from_string json_str in

     

       315
       315
       -
                   Some (entry_of_json json)

     

       354
       354
       +
                   Some (entry_of_string json_str)

     

       316
       355
        
                 with e ->

     

       317
       356
        
                   Log.err (fun m -> m "Failed to parse entry from scan: %s" (Printexc.to_string e));

     

       318
       357
        
                   None

     

       319
       358
        
           else None

     

       320
       359
        
         ) entries in

     

       321
       321
       -
         (* Sort by updated time, newest first *)

     

       322
       322
       -
         List.sort (fun a b -> Ptime.compare b.updated a.updated) feed_entries

     

       360
       360
       +
         (* Sort by date_modified, newest first *)

     

       361
       361
       +
         List.sort (fun a b ->

     

       362
       362
       +
           let time_a = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in

     

       363
       363
       +
           let time_b = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in

     

       364
       364
       +
           Ptime.compare time_b time_a

     

       365
       365
       +
         ) feed_entries

     

       323
       366
        
       

     

       324
       367
        
       let list_entries_filtered store ~feed_url ?since ?until ?limit ?(sort=`Updated) () =

     

       325
       368
        
         let entries = list_entries store ~feed_url in

     

       326
       369
        
         (* Filter by time *)

     

       327
       370
        
         let entries = match since with

     

       328
       371
        
           | None -> entries

     

       329
       329
       -
           | Some t -> List.filter (fun e -> Ptime.is_later e.updated ~than:t || Ptime.equal e.updated t) entries

     

       372
       372
       +
           | Some t -> List.filter (fun e ->

     

       373
       373
       +
               let time = Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at in

     

       374
       374
       +
               Ptime.is_later time ~than:t || Ptime.equal time t) entries

     

       330
       375
        
         in

     

       331
       376
        
         let entries = match until with

     

       332
       377
        
           | None -> entries

     

       333
       333
       -
           | Some t -> List.filter (fun e -> Ptime.is_earlier e.updated ~than:t || Ptime.equal e.updated t) entries

     

       378
       378
       +
           | Some t -> List.filter (fun e ->

     

       379
       379
       +
               let time = Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at in

     

       380
       380
       +
               Ptime.is_earlier time ~than:t || Ptime.equal time t) entries

     

       334
       381
        
         in

     

       335
       382
        
         (* Sort *)

     

       336
       383
        
         let entries = match sort with

     

       337
       384
        
           | `Published -> List.sort (fun a b ->

     

       338
       338
       -
               match a.published, b.published with

     

       339
       339
       -
               | Some pa, Some pb -> Ptime.compare pb pa

     

       385
       385
       +
               let pa = Jsonfeed.Item.date_published a.item in

     

       386
       386
       +
               let pb = Jsonfeed.Item.date_published b.item in

     

       387
       387
       +
               match pa, pb with

     

       388
       388
       +
               | Some ta, Some tb -> Ptime.compare tb ta

     

       340
       389
        
               | None, Some _ -> 1

     

       341
       390
        
               | Some _, None -> -1

     

       342
       342
       -
               | None, None -> Ptime.compare b.updated a.updated

     

       391
       391
       +
               | None, None ->

     

       392
       392
       +
                   let ta = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in

     

       393
       393
       +
                   let tb = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in

     

       394
       394
       +
                   Ptime.compare tb ta

     

       395
       395
       +
             ) entries

     

       396
       396
       +
           | `Updated -> List.sort (fun a b ->

     

       397
       397
       +
               let ta = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in

     

       398
       398
       +
               let tb = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in

     

       399
       399
       +
               Ptime.compare tb ta

     

       343
       400
        
             ) entries

     

       344
       344
       -
           | `Updated -> List.sort (fun a b -> Ptime.compare b.updated a.updated) entries

     

       345
       345
       -
           | `Stored -> List.sort (fun a b -> Ptime.compare b.stored_at a.stored_at) entries

     

       401
       401
       +
           | `Stored -> List.sort (fun a b -> Ptime.compare b.meta.stored_at a.meta.stored_at) entries

     

       346
       402
        
         in

     

       347
       403
        
         (* Limit *)

     

       348
       404
        
         match limit with

     
···

       365
       421
        
             | Some source ->

     

       366
       422
        
                 try

     

       367
       423
        
                   let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in

     

       368
       368
       -
                   let json = Yojson.Safe.from_string json_str in

     

       369
       369
       -
                   Some (entry_of_json json)

     

       424
       424
       +
                   Some (entry_of_string json_str)

     

       370
       425
        
                 with e ->

     

       371
       426
        
                   Log.err (fun m -> m "Failed to parse entry: %s" (Printexc.to_string e));

     

       372
       427
        
                   None

     

       373
       428
        
           else None

     

       374
       429
        
         ) entries in

     

       375
       375
       -
         let sorted = List.sort (fun a b -> Ptime.compare b.updated a.updated) all_entries in

     

       430
       430
       +
         let sorted = List.sort (fun a b ->

     

       431
       431
       +
           let ta = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in

     

       432
       432
       +
           let tb = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in

     

       433
       433
       +
           Ptime.compare tb ta

     

       434
       434
       +
         ) all_entries in

     

       376
       435
        
         List.filteri (fun i _ -> i < limit) sorted

     

       377
       436
        
       

     

       378
       437
        
       let find_entry_by_id store ~id =

     
···

       388
       447
        
             | Some source ->

     

       389
       448
        
                 (try

     

       390
       449
        
                   let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in

     

       391
       391
       -
                   let json = Yojson.Safe.from_string json_str in

     

       392
       392
       -
                   let entry = entry_of_json json in

     

       450
       450
       +
                   let entry = entry_of_string json_str in

     

       393
       451
        
                   (* Exact ID match only *)

     

       394
       394
       -
                   if entry.atom_id = id then

     

       452
       452
       +
                   if Jsonfeed.Item.id entry.item = id then

     

       395
       453
        
                     Some entry

     

       396
       454
        
                   else

     

       397
       455
        
                     None

     
···

       401
       459
        
           else None

     

       402
       460
        
         ) entries in

     

       403
       461
        
         (match matching_entry with

     

       404
       404
       -
          | Some e -> Log.debug (fun m -> m "Found entry: %s" e.title)

     

       462
       462
       +
          | Some e -> Log.debug (fun m -> m "Found entry: %s"

     

       463
       463
       +
                                   (Jsonfeed.Item.title e.item |> Option.value ~default:"(no title)"))

     

       405
       464
        
          | None -> Log.debug (fun m -> m "No entry found with ID: %s" id));

     

       406
       465
        
         matching_entry

     

       407
       466
        
       

     
···

       430
       489
        
         let entries = list_entries store ~feed_url in

     

       431
       490
        
         let to_delete = List.filteri (fun i _ -> i >= keep) entries in

     

       432
       491
        
         List.iter (fun entry ->

     

       433
       433
       -
           delete_entry store ~feed_url ~atom_id:entry.atom_id

     

       492
       492
       +
           delete_entry store ~feed_url ~atom_id:(Jsonfeed.Item.id entry.item)

     

       434
       493
        
         ) to_delete;

     

       435
       494
        
         let deleted = List.length to_delete in

     

       436
       495
        
         Log.info (fun m -> m "Pruned %d entries from feed %s (kept %d)" deleted feed_url keep);

     
···

       439
       498
        
       let prune_old_entries store ~feed_url ~older_than =

     

       440
       499
        
         let entries = list_entries store ~feed_url in

     

       441
       500
        
         let to_delete = List.filter (fun e ->

     

       442
       442
       -
           Ptime.is_earlier e.updated ~than:older_than

     

       501
       501
       +
           let time = Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at in

     

       502
       502
       +
           Ptime.is_earlier time ~than:older_than

     

       443
       503
        
         ) entries in

     

       444
       504
        
         List.iter (fun entry ->

     

       445
       445
       -
           delete_entry store ~feed_url ~atom_id:entry.atom_id

     

       505
       505
       +
           delete_entry store ~feed_url ~atom_id:(Jsonfeed.Item.id entry.item)

     

       446
       506
        
         ) to_delete;

     

       447
       507
        
         let deleted = List.length to_delete in

     

       448
       508
        
         Log.info (fun m -> m "Pruned %d old entries from feed %s" deleted feed_url);

     
···

       461
       521
        
             | Some source ->

     

       462
       522
        
                 try

     

       463
       523
        
                   let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in

     

       464
       464
       -
                   let json = Yojson.Safe.from_string json_str in

     

       465
       465
       -
                   Some (feed_meta_of_json json)

     

       524
       524
       +
                   Some (feed_meta_of_string json_str)

     

       466
       525
        
                 with e ->

     

       467
       526
        
                   Log.err (fun m -> m "Failed to parse feed metadata: %s" (Printexc.to_string e));

     

       468
       527
        
                   None

     
···

       502
       561
        
           | Some n -> list_entries_filtered store ~feed_url ~limit:n ()

     

       503
       562
        
         in

     

       504
       563
        
         let atom_entries = List.map (fun entry ->

     

       505
       505
       -
           let id = Uri.of_string entry.atom_id in

     

       506
       506
       -
           let entry_title : Syndic.Atom.text_construct = Syndic.Atom.Text entry.title in

     

       507
       507
       -
           let links = match entry.link with

     

       508
       508
       -
             | Some uri -> [Syndic.Atom.link ~rel:Syndic.Atom.Alternate uri]

     

       564
       564
       +
           let item = entry.item in

     

       565
       565
       +
           let id = Uri.of_string (Jsonfeed.Item.id item) in

     

       566
       566
       +
           let entry_title : Syndic.Atom.text_construct =

     

       567
       567
       +
             Syndic.Atom.Text (Jsonfeed.Item.title item |> Option.value ~default:"(no title)") in

     

       568
       568
       +
           let links = match Jsonfeed.Item.url item with

     

       569
       569
       +
             | Some url_str -> [Syndic.Atom.link ~rel:Syndic.Atom.Alternate (Uri.of_string url_str)]

     

       509
       570
        
             | None -> []

     

       510
       571
        
           in

     

       511
       511
       -
           let entry_content : Syndic.Atom.content = Syndic.Atom.Html (None, entry.content) in

     

       512
       512
       -
           let author = Syndic.Atom.author ?email:entry.author_email entry.author_name in

     

       572
       572
       +
           let content_str = match Jsonfeed.Item.content item with

     

       573
       573
       +
             | `Html h -> h

     

       574
       574
       +
             | `Text t -> t

     

       575
       575
       +
             | `Both (h, _) -> h

     

       576
       576
       +
           in

     

       577
       577
       +
           let entry_content : Syndic.Atom.content = Syndic.Atom.Html (None, content_str) in

     

       578
       578
       +
           let author_name = match Jsonfeed.Item.authors item with

     

       579
       579
       +
             | Some (a :: _) -> Jsonfeed.Author.name a |> Option.value ~default:entry.meta.feed_name

     

       580
       580
       +
             | _ -> entry.meta.feed_name

     

       581
       581
       +
           in

     

       582
       582
       +
           let author = Syndic.Atom.author author_name in

     

       513
       583
        
           let authors = (author, []) in

     

       514
       514
       -
           Syndic.Atom.entry ~id ~title:entry_title ~updated:entry.updated ?published:entry.published

     

       584
       584
       +
           let updated = Jsonfeed.Item.date_modified item |> Option.value ~default:entry.meta.stored_at in

     

       585
       585
       +
           Syndic.Atom.entry ~id ~title:entry_title ~updated

     

       586
       586
       +
             ?published:(Jsonfeed.Item.date_published item)

     

       515
       587
        
             ~links ~content:entry_content ~authors ()

     

       516
       588
        
         ) entries in

     

       517
       589
        
         let feed_title : Syndic.Atom.text_construct = match title with

     
···

       521
       593
        
         let feed_id = Uri.of_string ("urn:river:archive:" ^ (Digest.string feed_url |> Digest.to_hex)) in

     

       522
       594
        
         let feed_updated = match entries with

     

       523
       595
        
           | [] -> Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get

     

       524
       524
       -
           | e :: _ -> e.updated

     

       596
       596
       +
           | e :: _ -> Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at

     

       525
       597
        
         in

     

       526
       598
        
         {

     

       527
       599
        
           Syndic.Atom.id = feed_id;

     
···

       551
       623
        
       (* Pretty printing *)

     

       552
       624
        
       

     

       553
       625
        
       let pp_entry fmt entry =

     

       626
       626
       +
         let item = entry.item in

     

       554
       627
        
         Format.fprintf fmt "@[<v 2>Entry:@,";

     

       555
       555
       -
         Format.fprintf fmt "ID: %s@," entry.atom_id;

     

       556
       556
       -
         Format.fprintf fmt "Title: %s@," entry.title;

     

       557
       557
       -
         Format.fprintf fmt "Link: %s@," (match entry.link with Some u -> Uri.to_string u | None -> "none");

     

       558
       558
       -
         Format.fprintf fmt "Published: %s@," (match entry.published with

     

       559
       559
       -
           | Some t -> Ptime.to_rfc3339 t

     

       560
       560
       -
           | None -> "unknown");

     

       561
       561
       -
         Format.fprintf fmt "Updated: %s@," (Ptime.to_rfc3339 entry.updated);

     

       562
       562
       -
         Format.fprintf fmt "Feed: %s (%s)@," entry.feed_name entry.feed_url;

     

       563
       563
       -
         Format.fprintf fmt "Stored: %s@]" (Ptime.to_rfc3339 entry.stored_at)

     

       628
       628
       +
         Format.fprintf fmt "ID: %s@," (Jsonfeed.Item.id item);

     

       629
       629
       +
         Format.fprintf fmt "Title: %s@," (Jsonfeed.Item.title item |> Option.value ~default:"(no title)");

     

       630
       630
       +
         Format.fprintf fmt "URL: %s@," (Jsonfeed.Item.url item |> Option.value ~default:"(none)");

     

       631
       631
       +
         (match Jsonfeed.Item.date_published item with

     

       632
       632
       +
          | Some t -> Format.fprintf fmt "Published: %s@," (Ptime.to_rfc3339 t)

     

       633
       633
       +
          | None -> ());

     

       634
       634
       +
         (match Jsonfeed.Item.date_modified item with

     

       635
       635
       +
          | Some t -> Format.fprintf fmt "Modified: %s@," (Ptime.to_rfc3339 t)

     

       636
       636
       +
          | None -> ());

     

       637
       637
       +
         Format.fprintf fmt "Feed: %s (%s)@," entry.meta.feed_name entry.meta.feed_url;

     

       638
       638
       +
         Format.fprintf fmt "Stored: %s@]" (Ptime.to_rfc3339 entry.meta.stored_at)

     

       564
       639
        
       

     

       565
       640
        
       let pp_feed_info fmt info =

     

       566
       641
        
         Format.fprintf fmt "@[<v 2>Feed:@,";

     
···

       578
       653
        
         List.iter (fun feed ->

     

       579
       654
        
           Format.fprintf fmt "  - %s: %d entries@," feed.name feed.entry_count

     

       580
       655
        
         ) feeds;

     

       581
       581
       -
         Format.fprintf fmt "@]"
     

       656
       656
       +
         Format.fprintf fmt "@]"

+13 -38

stack/river/lib/river_store.mli

···

       40
       40
        
       (** Abstract type representing the store *)

     

       41
       41
        
       type t

     

       42
       42
        
       

     

       43
       43
       -
       (** Stored entry with resolved URLs and metadata *)

     

       44
       44
       -
       type stored_entry = {

     

       45
       45
       -
         atom_id : string;

     

       46
       46
       -
         (** Unique Atom entry ID (used as key) *)

     

       43
       43
       +
       (** Stored entry - combines Jsonfeed.Item with storage metadata *)

     

       44
       44
       +
       type stored_entry

     

       47
       45
        
       

     

       48
       48
       -
         title : string;

     

       49
       49
       -
         (** Entry title *)

     

       46
       46
       +
       (** {2 Stored Entry Accessors} *)

     

       50
       47
        
       

     

       51
       51
       -
         link : Uri.t option;

     

       52
       52
       -
         (** Primary link (resolved against feed base URI) *)

     

       48
       48
       +
       val entry_item : stored_entry -> Jsonfeed.Item.t

     

       49
       49
       +
       (** Get the underlying Jsonfeed Item *)

     

       53
       50
        
       

     

       54
       54
       -
         published : Ptime.t option;

     

       55
       55
       -
         (** Publication date *)

     

       51
       51
       +
       val entry_feed_url : stored_entry -> string

     

       52
       52
       +
       (** Get the source feed URL *)

     

       56
       53
        
       

     

       57
       57
       -
         updated : Ptime.t;

     

       58
       58
       -
         (** Last update time *)

     

       54
       54
       +
       val entry_feed_name : stored_entry -> string

     

       55
       55
       +
       (** Get the source feed name *)

     

       59
       56
        
       

     

       60
       60
       -
         author_name : string;

     

       61
       61
       -
         (** Entry author name *)

     

       57
       57
       +
       val entry_feed_title : stored_entry -> string

     

       58
       58
       +
       (** Get the source feed title *)

     

       62
       59
        
       

     

       63
       63
       -
         author_email : string option;

     

       64
       64
       -
         (** Entry author email *)

     

       65
       65
       -
       

     

       66
       66
       -
         content : string;

     

       67
       67
       -
         (** HTML content with resolved URLs *)

     

       68
       68
       -
       

     

       69
       69
       -
         feed_url : string;

     

       70
       70
       -
         (** URL of the source feed *)

     

       71
       71
       -
       

     

       72
       72
       -
         feed_name : string;

     

       73
       73
       -
         (** Name of the source feed *)

     

       74
       74
       -
       

     

       75
       75
       -
         feed_title : string;

     

       76
       76
       -
         (** Title of the source feed *)

     

       77
       77
       -
       

     

       78
       78
       -
         stored_at : Ptime.t;

     

       79
       79
       -
         (** When this entry was stored *)

     

       80
       80
       -
       

     

       81
       81
       -
         tags : string list;

     

       82
       82
       -
         (** Tags associated with the entry *)

     

       83
       83
       -
       

     

       84
       84
       -
         summary : string option;

     

       85
       85
       -
         (** Summary/excerpt of the entry *)

     

       86
       86
       -
       }

     

       60
       60
       +
       val entry_stored_at : stored_entry -> Ptime.t

     

       61
       61
       +
       (** Get the storage timestamp *)

     

       87
       62
        
       

     

       88
       63
        
       (** Feed metadata *)

     

       89
       64
        
       type feed_info = {

+1 -2

stack/river/river.opam

···

       22
       22
        
         "lambdasoup"

     

       23
       23
        
         "uri"

     

       24
       24
        
         "cmdliner" {>= "2.0.0"}

     

       25
       25
       -
         "yojson"

     

       26
       25
        
         "fmt"

     

       27
       26
        
         "xdge"

     

       28
       27
        
         "jsonfeed" {>= "1.1.0"}

     

       29
       28
        
         "jsont" {>= "0.2.0"}

     

       30
       30
       -
         "bytesrw"

     

       29
       29
       +
         "jsont.bytesrw" {>= "0.2.0"}

     

       31
       30
        
         "odoc" {with-doc}

     

       32
       31
        
       ]

     

       33
       32
        
       build: [

+1 -1

stack/typesense-client/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (public_name typesense-client)

     

       3
       3
        
        (name typesense_client)

     

       4
       4
       -
        (libraries eio requests requests_json_api ezjsonm fmt uri ptime))

     

       4
       4
       +
        (libraries eio requests requests_json_api jsont jsont.bytesrw fmt uri ptime))

+2 -1

stack/typesense-client/dune-project

···

       12
       12
        
         (ocaml (>= 4.14))

     

       13
       13
        
         eio

     

       14
       14
        
         requests

     

       15
       15
       -
         ezjsonm

     

       15
       15
       +
         jsont

     

       16
       16
       +
         jsont-bytesrw

     

       16
       17
        
         fmt

     

       17
       18
        
         uri

     

       18
       19
        
         ptime))

+2 -1

stack/typesense-client/typesense-client.opam

···

       8
       8
        
         "ocaml" {>= "4.14"}

     

       9
       9
        
         "eio"

     

       10
       10
        
         "requests"

     

       11
       11
       -
         "ezjsonm"

     

       11
       11
       +
         "jsont"

     

       12
       12
       +
         "jsont-bytesrw"

     

       12
       13
        
         "fmt"

     

       13
       14
        
         "uri"

     

       14
       15
        
         "ptime"

+178 -100

stack/typesense-client/typesense_client.ml

···

       6
       6
        
         api_key : string;

     

       7
       7
        
       }

     

       8
       8
        
       

     

       9
       9
       -
       (** Internal polymorphic type for the client *)

     

       10
       10
       -
       type 'net t_internal = {

     

       9
       9
       +
       (** Client type *)

     

       10
       10
       +
       type t = {

     

       11
       11
        
         config: config;

     

       12
       12
       -
         requests_session: (float Eio.Time.clock_ty Eio.Resource.t, 'net Eio.Net.ty Eio.Resource.t) Requests.t;

     

       12
       12
       +
         requests_session: Requests.t;

     

       13
       13
        
       }

     

       14
       14
       -
       

     

       15
       15
       -
       (** Public client type *)

     

       16
       16
       -
       type t = [`Generic | `Unix] t_internal

     

       17
       14
        
       

     

       18
       15
        
       (** Create a new Typesense client *)

     

       19
       16
        
       let create ~requests_session ~config : t =

     
···

       53
       50
        
           Error (Connection_error (Printexc.to_string exn))

     

       54
       51
        
       

     

       55
       52
        
       (** Search result types *)

     

       53
       53
       +
       type highlight = {

     

       54
       54
       +
         field: string;

     

       55
       55
       +
         snippets: string list;

     

       56
       56
       +
       }

     

       57
       57
       +
       

     

       56
       58
        
       type search_result = {

     

       57
       59
        
         id: string;

     

       58
       60
        
         title: string;

     

       59
       61
        
         content: string;

     

       60
       62
        
         score: float;

     

       61
       63
        
         collection: string;

     

       62
       62
       -
         highlights: (string * string list) list;

     

       63
       63
       -
         document: Ezjsonm.value;  (* Store raw document for flexible field access *)

     

       64
       64
       +
         highlights: highlight list;

     

       65
       65
       +
         document: Jsont.json;  (* Store raw document for flexible field access *)

     

       64
       66
        
       }

     

       65
       67
        
       

     

       66
       68
        
       type search_response = {

     
···

       69
       71
        
         query_time: float;

     

       70
       72
        
       }

     

       71
       73
        
       

     

       72
       72
       -
       (** Parse search result from JSON *)

     

       73
       73
       -
       let parse_search_result collection json =

     

       74
       74
       -
         let open Ezjsonm in

     

       75
       75
       -
         let document = get_dict json |> List.assoc "document" in

     

       76
       76
       -
         let highlights = try get_dict json |> List.assoc "highlights" with _ -> `A [] in

     

       77
       77
       -
         let score = try get_dict json |> List.assoc "text_match" |> get_float with _ -> 0.0 in

     

       74
       74
       +
       (* Jsont codecs *)

     

       75
       75
       +
       

     

       76
       76
       +
       (** Helper to find a field by name in the fields list *)

     

       77
       77
       +
       let find_field field_name fields =

     

       78
       78
       +
         List.find_opt (fun ((name, _), _value) -> name = field_name) fields

     

       78
       79
        
       

     

       79
       79
       -
         let id = get_dict document |> List.assoc "id" |> get_string in

     

       80
       80
       -
         let title = try get_dict document |> List.assoc "title" |> get_string with _ -> "" in

     

       81
       81
       -
         let content = try

     

       80
       80
       +
       module Highlight = struct

     

       81
       81
       +
         let make field snippets = { field; snippets }

     

       82
       82
       +
         let field h = h.field

     

       83
       83
       +
         let snippets h = h.snippets

     

       84
       84
       +
       

     

       85
       85
       +
         let jsont =

     

       86
       86
       +
           Jsont.Object.map ~kind:"Highlight" make

     

       87
       87
       +
           |> Jsont.Object.mem "field" Jsont.string ~enc:field

     

       88
       88
       +
           |> Jsont.Object.mem "snippets" (Jsont.list Jsont.string) ~enc:snippets

     

       89
       89
       +
           |> Jsont.Object.finish

     

       90
       90
       +
       end

     

       91
       91
       +
       

     

       92
       92
       +
       module Search_result = struct

     

       93
       93
       +
         (* Helper to extract content from document based on collection *)

     

       94
       94
       +
         let extract_content collection document =

     

       95
       95
       +
           let get_string_field field_name =

     

       96
       96
       +
             match document with

     

       97
       97
       +
             | Jsont.Object (fields, _) ->

     

       98
       98
       +
                 (match find_field field_name fields with

     

       99
       99
       +
                  | Some (_, Jsont.String (s, _)) -> s

     

       100
       100
       +
                  | _ -> "")

     

       101
       101
       +
             | _ -> ""

     

       102
       102
       +
           in

     

       82
       103
        
           match collection with

     

       83
       83
       -
           | "papers" -> get_dict document |> List.assoc "abstract" |> get_string

     

       84
       84
       -
           | "projects" -> get_dict document |> List.assoc "description" |> get_string

     

       85
       85
       -
           | "news" -> get_dict document |> List.assoc "content" |> get_string

     

       86
       86
       -
           | "videos" -> get_dict document |> List.assoc "description" |> get_string

     

       87
       87
       -
           | "notes" -> get_dict document |> List.assoc "content" |> get_string

     

       88
       88
       -
           | "ideas" -> get_dict document |> List.assoc "description" |> get_string

     

       89
       89
       -
           | "contacts" -> get_dict document |> List.assoc "name" |> get_string

     

       104
       104
       +
           | "papers" -> get_string_field "abstract"

     

       105
       105
       +
           | "projects" -> get_string_field "description"

     

       106
       106
       +
           | "news" -> get_string_field "content"

     

       107
       107
       +
           | "videos" -> get_string_field "description"

     

       108
       108
       +
           | "notes" -> get_string_field "content"

     

       109
       109
       +
           | "ideas" -> get_string_field "description"

     

       110
       110
       +
           | "contacts" -> get_string_field "name"

     

       90
       111
        
           | _ -> ""

     

       91
       91
       -
         with _ -> "" in

     

       112
       112
       +
       

     

       113
       113
       +
         let make collection document highlights text_match =

     

       114
       114
       +
           let get_string_field field_name =

     

       115
       115
       +
             match document with

     

       116
       116
       +
             | Jsont.Object (fields, _) ->

     

       117
       117
       +
                 (match find_field field_name fields with

     

       118
       118
       +
                  | Some (_, Jsont.String (s, _)) -> s

     

       119
       119
       +
                  | _ -> "")

     

       120
       120
       +
             | _ -> ""

     

       121
       121
       +
           in

     

       122
       122
       +
           let id = get_string_field "id" in

     

       123
       123
       +
           let title = get_string_field "title" in

     

       124
       124
       +
           let content = extract_content collection document in

     

       125
       125
       +
           let score = Option.value text_match ~default:0.0 in

     

       126
       126
       +
           let highlights = Option.value highlights ~default:[] in

     

       127
       127
       +
           { id; title; content; score; collection; highlights; document }

     

       128
       128
       +
       

     

       129
       129
       +
         let document r = r.document

     

       130
       130
       +
         let highlights r = if r.highlights = [] then None else Some r.highlights

     

       131
       131
       +
         let score r = if r.score = 0.0 then None else Some r.score

     

       132
       132
       +
       

     

       133
       133
       +
         let jsont collection =

     

       134
       134
       +
           Jsont.Object.map ~kind:"SearchResult" (make collection)

     

       135
       135
       +
           |> Jsont.Object.mem "document" Jsont.json ~enc:document

     

       136
       136
       +
           |> Jsont.Object.opt_mem "highlights" (Jsont.list Highlight.jsont) ~enc:highlights

     

       137
       137
       +
           |> Jsont.Object.opt_mem "text_match" Jsont.number ~enc:score

     

       138
       138
       +
           |> Jsont.Object.finish

     

       139
       139
       +
       end

     

       92
       140
        
       

     

       93
       93
       -
         let parse_highlights highlights =

     

       94
       94
       -
           try

     

       95
       95
       -
             get_list (fun h ->

     

       96
       96
       -
               let field = get_dict h |> List.assoc "field" |> get_string in

     

       97
       97
       -
               let snippets = get_dict h |> List.assoc "snippets" |> get_list get_string in

     

       98
       98
       -
               (field, snippets)

     

       99
       99
       -
             ) highlights

     

       100
       100
       -
           with _ -> []

     

       101
       101
       -
         in

     

       141
       141
       +
       module Search_response = struct

     

       142
       142
       +
         let make hits found search_time_ms =

     

       143
       143
       +
           { hits; total = found; query_time = search_time_ms }

     

       102
       144
        
       

     

       103
       103
       -
         { id; title; content; score; collection; highlights = parse_highlights highlights; document }

     

       145
       145
       +
         let hits r = r.hits

     

       146
       146
       +
         let total r = r.total

     

       147
       147
       +
         let query_time r = r.query_time

     

       104
       148
        
       

     

       105
       105
       -
       (** Parse search response from JSON *)

     

       106
       106
       -
       let parse_search_response collection json =

     

       107
       107
       -
         let open Ezjsonm in

     

       108
       108
       -
         let hits = get_dict json |> List.assoc "hits" |> get_list (parse_search_result collection) in

     

       109
       109
       -
         let total = get_dict json |> List.assoc "found" |> get_int in

     

       110
       110
       -
         let query_time = get_dict json |> List.assoc "search_time_ms" |> get_float in

     

       111
       111
       -
         { hits; total; query_time }

     

       149
       149
       +
         let jsont collection =

     

       150
       150
       +
           Jsont.Object.map ~kind:"SearchResponse" make

     

       151
       151
       +
           |> Jsont.Object.mem "hits" (Jsont.list (Search_result.jsont collection)) ~enc:hits

     

       152
       152
       +
           |> Jsont.Object.mem "found" Jsont.int ~enc:total

     

       153
       153
       +
           |> Jsont.Object.mem "search_time_ms" Jsont.number ~enc:query_time

     

       154
       154
       +
           |> Jsont.Object.finish

     

       155
       155
       +
       end

     

       112
       156
        
       

     

       113
       157
        
       (** Search a single collection *)

     

       114
       158
        
       let search_collection client collection_name query ?(limit=10) ?(offset=0) () =

     
···

       128
       172
        
       

     

       129
       173
        
         match make_request client path with

     

       130
       174
        
         | Ok response_str ->

     

       131
       131
       -
             (match Requests_json_api.parse_json_result (parse_search_response collection_name) response_str with

     

       175
       175
       +
             (match Jsont_bytesrw.decode_string' (Search_response.jsont collection_name) response_str with

     

       132
       176
        
              | Ok search_response -> Ok search_response

     

       133
       133
       -
              | Error msg -> Error (Json_error msg))

     

       177
       177
       +
              | Error error -> Error (Json_error (Jsont.Error.to_string error)))

     

       134
       178
        
         | Error err -> Error err

     

       135
       179
        
       

     

       136
       180
        
       (** Helper function to drop n elements from list *)

     
···

       152
       196
        
         results: search_response list;

     

       153
       197
        
       }

     

       154
       198
        
       

     

       155
       155
       -
       (** Parse multisearch response from JSON *)

     

       156
       156
       -
       let parse_multisearch_response json =

     

       157
       157
       -
         let open Ezjsonm in

     

       158
       158
       -
         let results_json = get_dict json |> List.assoc "results" |> get_list (fun r -> r) in

     

       159
       159
       -
         let results = List.mapi (fun i result_json ->

     

       160
       160
       -
           let collection_name = match i with

     

       161
       161
       -
             | 0 -> "contacts"

     

       162
       162
       -
             | 1 -> "news"

     

       163
       163
       -
             | 2 -> "notes"

     

       164
       164
       -
             | 3 -> "papers"

     

       165
       165
       -
             | 4 -> "projects"

     

       166
       166
       -
             | 5 -> "ideas"

     

       167
       167
       -
             | 6 -> "videos"

     

       168
       168
       -
             | _ -> "unknown"

     

       169
       169
       -
           in

     

       170
       170
       -
           parse_search_response collection_name result_json

     

       171
       171
       -
         ) results_json in

     

       172
       172
       -
         { results }

     

       199
       199
       +
       (* Multisearch response decoder - needs special handling for collection names *)

     

       200
       200
       +
       let decode_multisearch_response collections json_str =

     

       201
       201
       +
         (* First decode as generic JSON *)

     

       202
       202
       +
         match Jsont_bytesrw.decode_string' Jsont.json json_str with

     

       203
       203
       +
         | Error e -> Error e

     

       204
       204
       +
         | Ok json ->

     

       205
       205
       +
             (* Extract the results array *)

     

       206
       206
       +
             match json with

     

       207
       207
       +
             | Jsont.Object (fields, _) ->

     

       208
       208
       +
                 (match find_field "results" fields with

     

       209
       209
       +
                  | Some (_, Jsont.Array (results_array, _)) ->

     

       210
       210
       +
                      (* Decode each result with its corresponding collection name *)

     

       211
       211
       +
                      let decode_result idx result_json =

     

       212
       212
       +
                        let collection = List.nth collections idx in

     

       213
       213
       +
                        match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json result_json with

     

       214
       214
       +
                        | Error e -> Error e

     

       215
       215
       +
                        | Ok result_str ->

     

       216
       216
       +
                            Jsont_bytesrw.decode_string' (Search_response.jsont collection) result_str

     

       217
       217
       +
                      in

     

       218
       218
       +
                      let rec decode_all idx acc = function

     

       219
       219
       +
                        | [] -> Ok (List.rev acc)

     

       220
       220
       +
                        | hd :: tl ->

     

       221
       221
       +
                            match decode_result idx hd with

     

       222
       222
       +
                            | Error e -> Error e

     

       223
       223
       +
                            | Ok result -> decode_all (idx + 1) (result :: acc) tl

     

       224
       224
       +
                      in

     

       225
       225
       +
                      (match decode_all 0 [] results_array with

     

       226
       226
       +
                       | Ok results -> Ok { results }

     

       227
       227
       +
                       | Error e -> Error e)

     

       228
       228
       +
                  | _ -> Error (Jsont.Error.msg Jsont.Meta.none "Missing or invalid results field"))

     

       229
       229
       +
             | _ -> Error (Jsont.Error.msg Jsont.Meta.none "Expected JSON object")

     

       173
       230
        
       

     

       174
       231
        
       (** Perform multisearch across all collections *)

     

       175
       232
        
       let multisearch client query ?(limit=10) () =

     
···

       184
       241
        
           ("videos", "title,description,channel,platform,tags");

     

       185
       242
        
         ] in

     

       186
       243
        
       

     

       244
       244
       +
         (* Build search request objects *)

     

       187
       245
        
         let searches = List.map (fun collection ->

     

       188
       246
        
           let query_by = List.assoc collection query_by_collection in

     

       189
       189
       -
           Ezjsonm.dict [

     

       190
       190
       -
             ("collection", Ezjsonm.string collection);

     

       191
       191
       -
             ("q", Ezjsonm.string query);

     

       192
       192
       -
             ("query_by", Ezjsonm.string query_by);

     

       193
       193
       -
             ("exclude_fields", Ezjsonm.string "embedding");

     

       194
       194
       -
             ("per_page", Ezjsonm.int limit);

     

       195
       195
       -
           ]

     

       247
       247
       +
           Jsont.Object ([

     

       248
       248
       +
             (("collection", Jsont.Meta.none), Jsont.String (collection, Jsont.Meta.none));

     

       249
       249
       +
             (("q", Jsont.Meta.none), Jsont.String (query, Jsont.Meta.none));

     

       250
       250
       +
             (("query_by", Jsont.Meta.none), Jsont.String (query_by, Jsont.Meta.none));

     

       251
       251
       +
             (("exclude_fields", Jsont.Meta.none), Jsont.String ("embedding", Jsont.Meta.none));

     

       252
       252
       +
             (("per_page", Jsont.Meta.none), Jsont.Number (float_of_int limit, Jsont.Meta.none));

     

       253
       253
       +
           ], Jsont.Meta.none)

     

       196
       254
        
         ) collections in

     

       197
       255
        
       

     

       198
       198
       -
         let body = Ezjsonm.dict [("searches", Ezjsonm.list (fun x -> x) searches)] |> Ezjsonm.value_to_string in

     

       256
       256
       +
         let request_obj = Jsont.Object ([

     

       257
       257
       +
           (("searches", Jsont.Meta.none), Jsont.Array (searches, Jsont.Meta.none));

     

       258
       258
       +
         ], Jsont.Meta.none) in

     

       199
       259
        
       

     

       200
       200
       -
         match make_request client ~meth:`POST ~body "/multi_search" with

     

       201
       201
       -
         | Ok response_str ->

     

       202
       202
       -
             (match Requests_json_api.parse_json_result parse_multisearch_response response_str with

     

       203
       203
       -
              | Ok multisearch_resp -> Ok multisearch_resp

     

       204
       204
       -
              | Error msg -> Error (Json_error msg))

     

       205
       205
       -
         | Error err -> Error err

     

       260
       260
       +
         match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json request_obj with

     

       261
       261
       +
         | Error encode_error -> Error (Json_error (Jsont.Error.to_string encode_error))

     

       262
       262
       +
         | Ok body ->

     

       263
       263
       +
             match make_request client ~meth:`POST ~body "/multi_search" with

     

       264
       264
       +
             | Ok response_str ->

     

       265
       265
       +
                 (match decode_multisearch_response collections response_str with

     

       266
       266
       +
                  | Ok multisearch_resp -> Ok multisearch_resp

     

       267
       267
       +
                  | Error error -> Error (Json_error (Jsont.Error.to_string error)))

     

       268
       268
       +
             | Error err -> Error err

     

       206
       269
        
       

     

       207
       270
        
       (** Combine multisearch results into single result set *)

     

       208
       271
        
       let combine_multisearch_results (multisearch_resp : multisearch_response) ?(limit=10) ?(offset=0) () =

     
···

       226
       289
        
       

     

       227
       290
        
       (** List all collections *)

     

       228
       291
        
       let list_collections client =

     

       229
       229
       -
         let parse_collections json =

     

       230
       230
       -
           Ezjsonm.get_list (fun c ->

     

       231
       231
       -
             let name = Ezjsonm.get_dict c |> List.assoc "name" |> Ezjsonm.get_string in

     

       232
       232
       -
             let num_docs = Ezjsonm.get_dict c |> List.assoc "num_documents" |> Ezjsonm.get_int in

     

       233
       233
       -
             (name, num_docs)

     

       234
       234
       -
           ) json

     

       235
       235
       -
         in

     

       292
       292
       +
         let module Collection_info = struct

     

       293
       293
       +
           let make name num_documents = (name, num_documents)

     

       294
       294
       +
           let name ci = fst ci

     

       295
       295
       +
           let num_documents ci = snd ci

     

       296
       296
       +
       

     

       297
       297
       +
           let jsont =

     

       298
       298
       +
             Jsont.Object.map ~kind:"CollectionInfo" make

     

       299
       299
       +
             |> Jsont.Object.mem "name" Jsont.string ~enc:name

     

       300
       300
       +
             |> Jsont.Object.mem "num_documents" Jsont.int ~enc:num_documents

     

       301
       301
       +
             |> Jsont.Object.finish

     

       302
       302
       +
         end in

     

       303
       303
       +
       

     

       236
       304
        
         match make_request client "/collections" with

     

       237
       305
        
         | Ok response_str ->

     

       238
       238
       -
             (match Requests_json_api.parse_json_result parse_collections response_str with

     

       306
       306
       +
             (match Jsont_bytesrw.decode_string' (Jsont.list Collection_info.jsont) response_str with

     

       239
       307
        
              | Ok collections -> Ok collections

     

       240
       240
       -
              | Error msg -> Error (Json_error msg))

     

       308
       308
       +
              | Error error -> Error (Json_error (Jsont.Error.to_string error)))

     

       241
       309
        
         | Error err -> Error err

     

       242
       310
        
       

     

       243
       311
        
       (** Pretty printer utilities *)

     

       244
       312
        
       

     

       245
       313
        
       (** Extract field value from JSON document or return empty string if not found *)

     

       246
       246
       -
       let extract_field_string document field =

     

       247
       247
       -
         try

     

       248
       248
       -
           let open Ezjsonm in

     

       249
       249
       -
           get_dict document |> List.assoc field |> get_string

     

       250
       250
       -
         with _ -> ""

     

       314
       314
       +
       let extract_field_string document field_name =

     

       315
       315
       +
         match document with

     

       316
       316
       +
         | Jsont.Object (fields, _) ->

     

       317
       317
       +
             (match find_field field_name fields with

     

       318
       318
       +
              | Some (_, Jsont.String (s, _)) -> s

     

       319
       319
       +
              | _ -> "")

     

       320
       320
       +
         | _ -> ""

     

       251
       321
        
       

     

       252
       322
        
       (** Extract field value from JSON document as string list or return empty list if not found *)

     

       253
       253
       -
       let extract_field_string_list document field =

     

       254
       254
       -
         try

     

       255
       255
       -
           let open Ezjsonm in

     

       256
       256
       -
           get_dict document |> List.assoc field |> get_list get_string

     

       257
       257
       -
         with _ -> []

     

       323
       323
       +
       let extract_field_string_list document field_name =

     

       324
       324
       +
         match document with

     

       325
       325
       +
         | Jsont.Object (fields, _) ->

     

       326
       326
       +
             (match find_field field_name fields with

     

       327
       327
       +
              | Some (_, Jsont.Array (items, _)) ->

     

       328
       328
       +
                  List.filter_map (function

     

       329
       329
       +
                    | Jsont.String (s, _) -> Some s

     

       330
       330
       +
                    | _ -> None

     

       331
       331
       +
                  ) items

     

       332
       332
       +
              | _ -> [])

     

       333
       333
       +
         | _ -> []

     

       258
       334
        
       

     

       259
       335
        
       (** Extract field value from JSON document as boolean or return false if not found *)

     

       260
       260
       -
       let extract_field_bool document field =

     

       261
       261
       -
         try

     

       262
       262
       -
           let open Ezjsonm in

     

       263
       263
       -
           get_dict document |> List.assoc field |> get_bool

     

       264
       264
       -
         with _ -> false

     

       336
       336
       +
       let extract_field_bool document field_name =

     

       337
       337
       +
         match document with

     

       338
       338
       +
         | Jsont.Object (fields, _) ->

     

       339
       339
       +
             (match find_field field_name fields with

     

       340
       340
       +
              | Some (_, Jsont.Bool (b, _)) -> b

     

       341
       341
       +
              | _ -> false)

     

       342
       342
       +
         | _ -> false

     

       265
       343
        
       

     

       266
       344
        
       (** Format authors list for display *)

     

       267
       345
        
       let format_authors authors =

+13 -6

stack/typesense-client/typesense_client.mli

···

       14
       14
        
           @param config Configuration with endpoint and API key

     

       15
       15
        
           @return A client instance *)

     

       16
       16
        
       val create :

     

       17
       17
       -
         requests_session:(float Eio.Time.clock_ty Eio.Resource.t, [`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t ->

     

       17
       17
       +
         requests_session:Requests.t ->

     

       18
       18
        
         config:config ->

     

       19
       19
        
         t

     

       20
       20
        
       

     
···

       27
       27
        
       val pp_error : Format.formatter -> error -> unit

     

       28
       28
        
       

     

       29
       29
        
       (** Search result types *)

     

       30
       30
       +
       

     

       31
       31
       +
       (** A highlight snippet from a search result *)

     

       32
       32
       +
       type highlight = {

     

       33
       33
       +
         field: string;

     

       34
       34
       +
         snippets: string list;

     

       35
       35
       +
       }

     

       36
       36
       +
       

     

       30
       37
        
       type search_result = {

     

       31
       38
        
         id: string;

     

       32
       39
        
         title: string;

     

       33
       40
        
         content: string;

     

       34
       41
        
         score: float;

     

       35
       42
        
         collection: string;

     

       36
       36
       -
         highlights: (string * string list) list;

     

       37
       37
       -
         document: Ezjsonm.value;  (* Store raw document for flexible field access *)

     

       43
       43
       +
         highlights: highlight list;

     

       44
       44
       +
         document: Jsont.json;  (* Store raw document for flexible field access *)

     

       38
       45
        
       }

     

       39
       46
        
       

     

       40
       47
        
       type search_response = {

     
···

       80
       87
        
         ((string * int) list, error) result

     

       81
       88
        
       

     

       82
       89
        
       (** Pretty printer utilities *)

     

       83
       83
       -
       val extract_field_string : Ezjsonm.value -> string -> string

     

       84
       84
       -
       val extract_field_string_list : Ezjsonm.value -> string -> string list

     

       85
       85
       -
       val extract_field_bool : Ezjsonm.value -> string -> bool

     

       90
       90
       +
       val extract_field_string : Jsont.json -> string -> string

     

       91
       91
       +
       val extract_field_string_list : Jsont.json -> string -> string list

     

       92
       92
       +
       val extract_field_bool : Jsont.json -> string -> bool

     

       86
       93
        
       val format_authors : string list -> string

     

       87
       94
        
       val format_date : string -> string

     

       88
       95
        
       val format_tags : string list -> string

+1 -1

stack/zotero-translation/dune

···

       1
       1
        
       (library

     

       2
       2
        
         (name zotero_translation)

     

       3
       3
        
         (public_name zotero-translation)

     

       4
       4
       -
         (libraries astring eio requests ezjsonm fpath uri))

     

       4
       4
       +
         (libraries astring eio requests jsont jsont.bytesrw fpath uri))

+2 -1

stack/zotero-translation/dune-project

···

       17
       17
        
         uri

     

       18
       18
        
         eio

     

       19
       19
        
         requests

     

       20
       20
       -
         ezjsonm

     

       20
       20
       +
         jsont

     

       21
       21
       +
         (jsont-bytesrw (>= "0.4"))

     

       21
       22
        
         yaml

     

       22
       23
        
         astring))

+2 -1

stack/zotero-translation/zotero-translation.opam

···

       13
       13
        
         "uri"

     

       14
       14
        
         "eio"

     

       15
       15
        
         "requests"

     

       16
       16
       -
         "ezjsonm"

     

       16
       16
       +
         "jsont"

     

       17
       17
       +
         "jsont-bytesrw" {>= "0.4"}

     

       17
       18
        
         "yaml"

     

       18
       19
        
         "astring"

     

       19
       20
        
         "odoc" {with-doc}

+107 -60

stack/zotero-translation/zotero_translation.ml

···

       1
       1
        
       (** Resolve a DOI from a Zotero translation server *)

     

       2
       2
        
       

     

       3
       3
       -
       module J = Ezjsonm

     

       4
       4
       -
       

     

       5
       3
        
       (* From the ZTS source code:  https://github.com/zotero/translation-server/blob/master/src/formats.js

     

       6
       4
        
         bibtex: "9cb70025-a888-4a29-a210-93ec52da40d4",

     

       7
       5
        
       	biblatex: "b6e39b57-8942-4d11-8259-342c46ce395f",

     
···

       99
       97
        
         | true -> Uri.of_string (base_uri ^ "import")

     

       100
       98
        
         | false -> Uri.of_string (base_uri ^ "/import")

     

       101
       99
        
       

     

       102
       102
       -
       type ('clock, 'net) t = {

     

       100
       100
       +
       type t = {

     

       103
       101
        
         base_uri: string;

     

       104
       104
       -
         requests_session: ('clock, 'net) Requests.t;

     

       102
       102
       +
         requests_session: Requests.t;

     

       105
       103
        
       }

     

       106
       104
        
       

     

       107
       107
       -
       let create ~sw ~env ?requests_session base_uri =

     

       108
       108
       -
         let requests_session = match requests_session with

     

       109
       109
       -
           | Some session -> session

     

       110
       110
       -
           | None -> Requests.create ~sw env

     

       111
       111
       -
         in

     

       105
       105
       +
       let create ~requests_session base_uri =

     

       112
       106
        
         { base_uri; requests_session }

     

       113
       107
        
       

     

       114
       114
       -
       let v _base_uri =

     

       115
       115
       -
         failwith "Zotero_translation.v is deprecated. Use Zotero_translation.create ~sw ~env base_uri instead"

     

       116
       116
       -
       

     

       117
       108
        
       let resolve_doi { base_uri; requests_session } doi =

     

       118
       109
        
         let body_str = "https://doi.org/" ^ doi in

     

       119
       110
        
         let uri = web_endp base_uri in

     
···

       123
       114
        
         let body = Requests.Response.body response |> Eio.Flow.read_all in

     

       124
       115
        
         if status = 200 then begin

     

       125
       116
        
           try

     

       126
       126
       -
             let doi_json = J.from_string body in

     

       127
       127
       -
             Ok doi_json

     

       117
       117
       +
             match Jsont_bytesrw.decode_string' Jsont.json body with

     

       118
       118
       +
             | Ok doi_json -> Ok doi_json

     

       119
       119
       +
             | Error e -> Error (`Msg (Jsont.Error.to_string e))

     

       128
       120
        
           with exn -> Error (`Msg (Printexc.to_string exn))

     

       129
       121
        
         end else

     

       130
       122
        
           Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))

     
···

       138
       130
        
         let body = Requests.Response.body response |> Eio.Flow.read_all in

     

       139
       131
        
         if status = 200 then begin

     

       140
       132
        
           try

     

       141
       141
       -
             let url_json = J.from_string body in

     

       142
       142
       -
             Ok url_json

     

       133
       133
       +
             match Jsont_bytesrw.decode_string' Jsont.json body with

     

       134
       134
       +
             | Ok url_json -> Ok url_json

     

       135
       135
       +
             | Error e -> Error (`Msg (Jsont.Error.to_string e))

     

       143
       136
        
           with exn -> Error (`Msg (Printexc.to_string exn))

     

       144
       137
        
         end else

     

       145
       138
        
           Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))

     
···

       153
       146
        
         let body = Requests.Response.body response |> Eio.Flow.read_all in

     

       154
       147
        
         if status = 200 then begin

     

       155
       148
        
             try

     

       156
       156
       -
               let doi_json = J.from_string body in

     

       157
       157
       -
               Ok doi_json

     

       149
       149
       +
               match Jsont_bytesrw.decode_string' Jsont.json body with

     

       150
       150
       +
               | Ok doi_json -> Ok doi_json

     

       151
       151
       +
               | Error e -> Error (`Msg (Jsont.Error.to_string e))

     

       158
       152
        
             with exn -> Error (`Msg (Printexc.to_string exn))

     

       159
       153
        
         end else

     

       160
       154
        
           Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))

     

       161
       155
        
       

     

       162
       156
        
       let export { base_uri; requests_session } format api =

     

       163
       163
       -
         let body_str = J.to_string api in

     

       164
       164
       -
         let uri = Uri.with_query' (export_endp base_uri ) ["format", (format_to_string format)] in

     

       165
       165
       -
         let body = Requests.Body.of_string Requests.Mime.json body_str in

     

       166
       166
       -
         let response = Requests.post requests_session ~body (Uri.to_string uri) in

     

       167
       167
       -
         let status = Requests.Response.status_code response in

     

       168
       168
       -
         let body = Requests.Response.body response |> Eio.Flow.read_all in

     

       169
       169
       -
         if status = 200 then begin

     

       170
       170
       -
           try

     

       171
       171
       -
             match format with

     

       172
       172
       -
             | Bibtex -> Ok (Astring.String.trim body)

     

       173
       173
       -
             | _ -> Ok body

     

       174
       174
       -
           with exn -> Error (`Msg (Printexc.to_string exn))

     

       175
       175
       -
         end else

     

       176
       176
       -
           Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))

     

       157
       157
       +
         match Jsont_bytesrw.encode_string' Jsont.json api with

     

       158
       158
       +
         | Error e -> Error (`Msg (Jsont.Error.to_string e))

     

       159
       159
       +
         | Ok body_str ->

     

       160
       160
       +
             let uri = Uri.with_query' (export_endp base_uri ) ["format", (format_to_string format)] in

     

       161
       161
       +
             let body = Requests.Body.of_string Requests.Mime.json body_str in

     

       162
       162
       +
             let response = Requests.post requests_session ~body (Uri.to_string uri) in

     

       163
       163
       +
             let status = Requests.Response.status_code response in

     

       164
       164
       +
             let body = Requests.Response.body response |> Eio.Flow.read_all in

     

       165
       165
       +
             if status = 200 then begin

     

       166
       166
       +
               try

     

       167
       167
       +
                 match format with

     

       168
       168
       +
                 | Bibtex -> Ok (Astring.String.trim body)

     

       169
       169
       +
                 | _ -> Ok body

     

       170
       170
       +
               with exn -> Error (`Msg (Printexc.to_string exn))

     

       171
       171
       +
             end else

     

       172
       172
       +
               Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))

     

       177
       173
        
       

     

       178
       174
        
       let unescape_hex s =

     

       179
       175
        
         let buf = Buffer.create (String.length s) in

     
···

       206
       202
        
         | Ok [bib] ->

     

       207
       203
        
             let f = Bibtex.fields bib |> Bibtex.SM.bindings |> List.map (fun (k,v) -> k, (unescape_bibtex v)) in

     

       208
       204
        
             let ty = match Bibtex.type' bib with "inbook" -> "book" | x -> x in

     

       209
       209
       -
             let v = List.fold_left (fun acc (k,v) -> (k,(`String v))::acc) ["bibtype",`String ty] f in

     

       205
       205
       +
             let v = List.fold_left (fun acc (k,v) -> ((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))::acc)

     

       206
       206
       +
                 [(("bibtype", Jsont.Meta.none), Jsont.String (ty, Jsont.Meta.none))] f in

     

       210
       207
        
             v

     

       211
       208
        
         | Ok _ -> failwith "one bib at a time plz"

     

       212
       209
        
       

     

       213
       210
        
       let bib_of_doi zt doi =

     

       214
       211
        
         prerr_endline ("Fetching " ^ doi);

     

       215
       215
       -
         let v = match resolve_doi zt doi with

     

       216
       216
       -
         | Ok r -> r

     

       212
       212
       +
         match resolve_doi zt doi with

     

       217
       213
        
         | Error (`Msg _) ->

     

       218
       214
        
            Printf.eprintf "%s failed on /web, trying to /search\n%!" doi;

     

       219
       219
       -
            match search_id zt doi with

     

       215
       215
       +
            begin match search_id zt doi with

     

       220
       216
        
            | Error (`Msg e) -> failwith e

     

       221
       221
       -
            | Ok r -> r

     

       222
       222
       -
         in

     

       223
       223
       -
         match export zt Bibtex v with

     

       224
       224
       -
         | Error (`Msg e) -> failwith e

     

       225
       225
       -
         | Ok r ->

     

       226
       226
       -
             print_endline r;

     

       227
       227
       -
             r

     

       217
       217
       +
            | Ok v ->

     

       218
       218
       +
                match export zt Bibtex v with

     

       219
       219
       +
                | Error (`Msg e) -> failwith e

     

       220
       220
       +
                | Ok r ->

     

       221
       221
       +
                    print_endline r;

     

       222
       222
       +
                    r

     

       223
       223
       +
            end

     

       224
       224
       +
         | Ok v ->

     

       225
       225
       +
             match export zt Bibtex v with

     

       226
       226
       +
             | Error (`Msg e) -> failwith e

     

       227
       227
       +
             | Ok r ->

     

       228
       228
       +
                 print_endline r;

     

       229
       229
       +
                 r

     

       230
       230
       +
       

     

       231
       231
       +
       (* Helper to get string from Jsont.json *)

     

       232
       232
       +
       let get_string = function

     

       233
       233
       +
         | Jsont.String (s, _) -> s

     

       234
       234
       +
         | _ -> failwith "Expected string in JSON"

     

       235
       235
       +
       

     

       236
       236
       +
       (* Helper to get list from Jsont.json *)

     

       237
       237
       +
       let get_list f = function

     

       238
       238
       +
         | Jsont.Array (arr, _) -> List.map f arr

     

       239
       239
       +
         | _ -> failwith "Expected array in JSON"

     

       240
       240
       +
       

     

       241
       241
       +
       (* Helper to find a field in Jsont.Object *)

     

       242
       242
       +
       let find_field name = function

     

       243
       243
       +
         | Jsont.Object (mems, _) ->

     

       244
       244
       +
             List.find_map (fun ((k, _), v) -> if k = name then Some v else None) mems

     

       245
       245
       +
         | _ -> None

     

       246
       246
       +
       

     

       247
       247
       +
       (* Helper to get a required field as string *)

     

       248
       248
       +
       let get_field name json =

     

       249
       249
       +
         match find_field name json with

     

       250
       250
       +
         | Some v -> get_string v

     

       251
       251
       +
         | None -> failwith ("Missing field: " ^ name)

     

       252
       252
       +
       

     

       253
       253
       +
       (* Helper to update a field in a Jsont.Object *)

     

       254
       254
       +
       let update_field name value json =

     

       255
       255
       +
         match json with

     

       256
       256
       +
         | Jsont.Object (mems, meta) ->

     

       257
       257
       +
             let mems' =

     

       258
       258
       +
               match value with

     

       259
       259
       +
               | None -> List.filter (fun ((k, _), _) -> k <> name) mems

     

       260
       260
       +
               | Some v ->

     

       261
       261
       +
                   let without = List.filter (fun ((k, _), _) -> k <> name) mems in

     

       262
       262
       +
                   ((name, Jsont.Meta.none), v) :: without

     

       263
       263
       +
             in

     

       264
       264
       +
             Jsont.Object (mems', meta)

     

       265
       265
       +
         | _ -> json

     

       228
       266
        
       

     

       229
       267
        
       let split_authors keys =

     

       268
       268
       +
         let json = Jsont.Object (keys, Jsont.Meta.none) in

     

       269
       269
       +
         let author_str = get_field "author" json in

     

       230
       270
        
         let authors =

     

       231
       231
       -
           List.assoc "author" keys |> J.get_string |>

     

       232
       232
       -
           Astring.String.cuts ~empty:false ~sep:" and " |>

     

       271
       271
       +
           Astring.String.cuts ~empty:false ~sep:" and " author_str |>

     

       233
       272
        
           List.map Bibtex.list_value |>

     

       234
       273
        
           List.map (fun v -> List.rev v |> String.concat " ") |>

     

       235
       235
       -
           List.map (fun x -> `String x)

     

       274
       274
       +
           List.map (fun x -> Jsont.String (x, Jsont.Meta.none))

     

       236
       275
        
         in

     

       237
       276
        
         let keywords =

     

       238
       238
       -
           List.assoc_opt "keywords" keys |> function

     

       277
       277
       +
           match find_field "keywords" json with

     

       239
       278
        
           | None -> []

     

       240
       279
        
           | Some k ->

     

       241
       241
       -
               Astring.String.cuts ~empty:false ~sep:", " (J.get_string k) |>

     

       242
       242
       -
               List.map (fun x -> `String x)

     

       280
       280
       +
               Astring.String.cuts ~empty:false ~sep:", " (get_string k) |>

     

       281
       281
       +
               List.map (fun x -> Jsont.String (x, Jsont.Meta.none))

     

       243
       282
        
         in

     

       244
       244
       -
         J.update (`O keys) ["author"] (Some (`A authors)) |> fun j ->

     

       245
       245
       -
         J.update j ["keywords"] (match keywords with [] -> None | _ -> Some (`A keywords))

     

       283
       283
       +
         let json' = update_field "author" (Some (Jsont.Array (authors, Jsont.Meta.none))) json in

     

       284
       284
       +
         let json'' = update_field "keywords"

     

       285
       285
       +
           (match keywords with [] -> None | _ -> Some (Jsont.Array (keywords, Jsont.Meta.none))) json' in

     

       286
       286
       +
         match json'' with

     

       287
       287
       +
         | Jsont.Object (mems, _) -> mems

     

       288
       288
       +
         | _ -> failwith "Expected object"

     

       246
       289
        
       

     

       247
       290
        
       let add_bibtex ~slug y =

     

       248
       248
       -
         let (.%{}) = fun y k -> J.find y [k] in

     

       291
       291
       +
         let json = Jsont.Object (y, Jsont.Meta.none) in

     

       292
       292
       +
         let find_opt k = find_field k json in

     

       249
       293
        
         let add_if_present k f m =

     

       250
       250
       -
           match J.find y [k] with

     

       251
       251
       -
           | v -> Bibtex.SM.add k (f v) m

     

       252
       252
       -
           | exception Not_found -> m in

     

       253
       253
       -
         let string k m = add_if_present k J.get_string m in

     

       254
       254
       -
         let authors m = add_if_present "author" (fun j -> J.get_list J.get_string j |> String.concat " and ") m in

     

       294
       294
       +
           match find_opt k with

     

       295
       295
       +
           | Some v -> Bibtex.SM.add k (f v) m

     

       296
       296
       +
           | None -> m

     

       297
       297
       +
         in

     

       298
       298
       +
         let string k m = add_if_present k get_string m in

     

       299
       299
       +
         let authors m = add_if_present "author" (fun j -> get_list get_string j |> String.concat " and ") m in

     

       255
       300
        
         let cite_key = Astring.String.map (function '-' -> '_' |x -> x) slug in

     

       256
       301
        
         let fields = Bibtex.SM.empty in

     

       257
       257
       -
         let type' = y.%{"bibtype"} |> J.get_string |> String.lowercase_ascii in

     

       302
       302
       +
         let type' = get_field "bibtype" json |> String.lowercase_ascii in

     

       258
       303
        
         let fields = authors fields |> string "title" |> string "doi" |> string "month" |> string "year" |> string "url" in

     

       259
       304
        
         let fields = match type' with

     

       260
       305
        
           | "article" -> string "journal" fields |> string "volume" |> string "number" |> string "pages"

     
···

       264
       309
        
           | "misc" -> string "howpublished" fields

     

       265
       310
        
           | "techreport" -> string "institution" fields |> string "number" |> string "address"

     

       266
       311
        
           | b -> prerr_endline ("unknown bibtype " ^ b); fields in

     

       267
       267
       -
         Bibtex.v ~type' ~cite_key ~fields () |> Fmt.str "%a" Bibtex.pp |>

     

       268
       268
       -
         fun bib -> J.update y ["bib"] (Some (`String bib))

     

       312
       312
       +
         let bib = Bibtex.v ~type' ~cite_key ~fields () |> Fmt.str "%a" Bibtex.pp in

     

       313
       313
       +
         match update_field "bib" (Some (Jsont.String (bib, Jsont.Meta.none))) json with

     

       314
       314
       +
         | Jsont.Object (mems, _) -> mems

     

       315
       315
       +
         | _ -> failwith "Expected object"

     

       269
       316
        
       

     

       270
       317
        
       let json_of_doi zt ~slug doi =

     

       271
       318
        
         let x = bib_of_doi zt doi in

+15 -23

stack/zotero-translation/zotero_translation.mli

···

       1
       1
        
       (** {1 Interface to the Zotero Translation Server} *)

     

       2
       2
        
       

     

       3
       3
       -
       type ('clock, 'net) t

     

       3
       3
       +
       type t

     

       4
       4
        
       

     

       5
       5
        
       type format =

     

       6
       6
        
         | Bibtex

     
···

       25
       25
        
       val format_of_string: string -> format option

     

       26
       26
        
       

     

       27
       27
        
       (** Create a Zotero Translation client.

     

       28
       28
       -
           @param requests_session Optional Requests session for connection pooling.

     

       29
       29
       -
                                  If not provided, a new session is created. *)

     

       28
       28
       +
           @param requests_session Shared Requests session for connection pooling.

     

       29
       29
       +
           @param base_uri Base URI of the Zotero translation server (e.g., "http://localhost:1969"). *)

     

       30
       30
        
       val create :

     

       31
       31
       -
         sw:Eio.Switch.t ->

     

       32
       32
       -
         env:< clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t;

     

       33
       33
       -
               net: ([> [> `Generic ] Eio.Net.ty ] as 'net) Eio.Resource.t;

     

       34
       34
       -
               fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->

     

       35
       35
       -
         ?requests_session:('clock Eio.Resource.t, 'net Eio.Resource.t) Requests.t ->

     

       36
       36
       -
         string -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t

     

       31
       31
       +
         requests_session:Requests.t ->

     

       32
       32
       +
         string -> t

     

       37
       33
        
       

     

       38
       38
       -
       (** Deprecated: use [create] instead *)

     

       39
       39
       -
       val v : string -> (_, _) t

     

       40
       40
       -
         [@@deprecated "Use create ~sw ~env base_uri instead"]

     

       41
       41
       -
       

     

       42
       42
       -
       val resolve_doi: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->

     

       43
       43
       -
         string -> (Ezjsonm.t, [>`Msg of string]) result

     

       34
       34
       +
       val resolve_doi: t ->

     

       35
       35
       +
         string -> (Jsont.json, [>`Msg of string]) result

     

       44
       36
        
       

     

       45
       45
       -
       val resolve_url: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->

     

       46
       46
       -
         string -> (Ezjsonm.t, [>`Msg of string]) result

     

       37
       37
       +
       val resolve_url: t ->

     

       38
       38
       +
         string -> (Jsont.json, [>`Msg of string]) result

     

       47
       39
        
       

     

       48
       48
       -
       val search_id: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->

     

       49
       49
       -
         string -> (Ezjsonm.t, [>`Msg of string]) result

     

       40
       40
       +
       val search_id: t ->

     

       41
       41
       +
         string -> (Jsont.json, [>`Msg of string]) result

     

       50
       42
        
       

     

       51
       51
       -
       val export: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->

     

       52
       52
       -
         format -> Ezjsonm.t -> (string, [>`Msg of string]) result

     

       43
       43
       +
       val export: t ->

     

       44
       44
       +
         format -> Jsont.json -> (string, [>`Msg of string]) result

     

       53
       45
        
       

     

       54
       54
       -
       val json_of_doi : ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->

     

       55
       55
       -
         slug:string -> string -> Ezjsonm.value

     

       46
       46
       +
       val json_of_doi : t ->

     

       47
       47
       +
         slug:string -> string -> Jsont.object'

+217

stack/zulip/ARCHITECTURE.md

···

       1
       1
       +
       # Zulip Library Architecture

     

       2
       2
       +
       

     

       3
       3
       +
       ## Overview

     

       4
       4
       +
       

     

       5
       5
       +
       The Zulip OCaml library follows a clean, layered architecture that separates protocol types, encoding concerns, and HTTP communication.

     

       6
       6
       +
       

     

       7
       7
       +
       ## Architecture Layers

     

       8
       8
       +
       

     

       9
       9
       +
       ```

     

       10
       10
       +
       ┌─────────────────────────────────────┐

     

       11
       11
       +
       │   API Modules (Messages, Channels)  │  ← High-level operations

     

       12
       12
       +
       ├─────────────────────────────────────┤

     

       13
       13
       +
       │   Protocol Types (Message, Channel) │  ← Business logic types with Jsont codecs

     

       14
       14
       +
       ├─────────────────────────────────────┤

     

       15
       15
       +
       │   Encode Module                     │  ← JSON/Form encoding utilities

     

       16
       16
       +
       ├─────────────────────────────────────┤

     

       17
       17
       +
       │   Client Module                     │  ← HTTP request/response handling

     

       18
       18
       +
       ├─────────────────────────────────────┤

     

       19
       19
       +
       │   Requests Library (EIO-based)      │  ← Low-level HTTP

     

       20
       20
       +
       └─────────────────────────────────────┘

     

       21
       21
       +
       ```

     

       22
       22
       +
       

     

       23
       23
       +
       ## Key Design Principles

     

       24
       24
       +
       

     

       25
       25
       +
       ### 1. **Protocol Types with Jsont Codecs**

     

       26
       26
       +
       

     

       27
       27
       +
       Each Zulip API type (Message, Channel, User, etc.) has:

     

       28
       28
       +
       - A clean OCaml record type

     

       29
       29
       +
       - A `jsont` codec that defines bidirectional JSON conversion

     

       30
       30
       +
       - Accessor functions

     

       31
       31
       +
       - Pretty printer

     

       32
       32
       +
       

     

       33
       33
       +
       Example from `channel.ml`:

     

       34
       34
       +
       ```ocaml

     

       35
       35
       +
       type t = {

     

       36
       36
       +
         name : string;

     

       37
       37
       +
         description : string;

     

       38
       38
       +
         invite_only : bool;

     

       39
       39
       +
         history_public_to_subscribers : bool;

     

       40
       40
       +
       }

     

       41
       41
       +
       

     

       42
       42
       +
       let jsont =

     

       43
       43
       +
         Jsont.Object.map ~kind:"Channel" make

     

       44
       44
       +
         |> Jsont.Object.mem "name" Jsont.string ~enc:name

     

       45
       45
       +
         |> Jsont.Object.mem "description" Jsont.string ~enc:description

     

       46
       46
       +
         |> Jsont.Object.mem "invite_only" Jsont.bool ~enc:invite_only

     

       47
       47
       +
         |> Jsont.Object.mem "history_public_to_subscribers" Jsont.bool ~enc:history_public_to_subscribers

     

       48
       48
       +
         |> Jsont.Object.finish

     

       49
       49
       +
       ```

     

       50
       50
       +
       

     

       51
       51
       +
       ### 2. **Encode Module: Separation of Encoding Concerns**

     

       52
       52
       +
       

     

       53
       53
       +
       The `Encode` module provides clean utilities for converting between OCaml types and wire formats:

     

       54
       54
       +
       

     

       55
       55
       +
       ```ocaml

     

       56
       56
       +
       (** Convert using a jsont codec *)

     

       57
       57
       +
       val to_json_string : 'a Jsont.t -> 'a -> string

     

       58
       58
       +
       val to_form_urlencoded : 'a Jsont.t -> 'a -> string

     

       59
       59
       +
       val from_json : 'a Jsont.t -> Jsont.json -> ('a, string) result

     

       60
       60
       +
       ```

     

       61
       61
       +
       

     

       62
       62
       +
       This eliminates the need for:

     

       63
       63
       +
       - ❌ Manual JSON tree walking

     

       64
       64
       +
       - ❌ Round-trip encode→decode conversions

     

       65
       65
       +
       - ❌ Per-type encoding functions

     

       66
       66
       +
       

     

       67
       67
       +
       ### 3. **Request/Response Types with Codecs**

     

       68
       68
       +
       

     

       69
       69
       +
       API operations define request/response types locally with their codecs:

     

       70
       70
       +
       

     

       71
       71
       +
       ```ocaml

     

       72
       72
       +
       (* In channels.ml *)

     

       73
       73
       +
       module Subscribe_request = struct

     

       74
       74
       +
         type t = { subscriptions : string list }

     

       75
       75
       +
       

     

       76
       76
       +
         let codec =

     

       77
       77
       +
           Jsont.Object.(

     

       78
       78
       +
             map ~kind:"SubscribeRequest" (fun subscriptions -> { subscriptions })

     

       79
       79
       +
             |> mem "subscriptions" (Jsont.list Jsont.string) ~enc:(fun r -> r.subscriptions)

     

       80
       80
       +
             |> finish

     

       81
       81
       +
           )

     

       82
       82
       +
       end

     

       83
       83
       +
       

     

       84
       84
       +
       let subscribe client ~channels =

     

       85
       85
       +
         let req = Subscribe_request.{ subscriptions = channels } in

     

       86
       86
       +
         let body = Encode.to_form_urlencoded Subscribe_request.codec req in

     

       87
       87
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       88
       88
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/users/me/subscriptions"

     

       89
       89
       +
                 ~body ~content_type () with

     

       90
       90
       +
         | Ok _json -> Ok ()

     

       91
       91
       +
         | Error err -> Error err

     

       92
       92
       +
       ```

     

       93
       93
       +
       

     

       94
       94
       +
       ### 4. **Type-Safe Decoding**

     

       95
       95
       +
       

     

       96
       96
       +
       Response parsing uses codecs directly instead of manual pattern matching:

     

       97
       97
       +
       

     

       98
       98
       +
       ```ocaml

     

       99
       99
       +
       (* OLD - manual JSON walking *)

     

       100
       100
       +
       match json with

     

       101
       101
       +
       | Jsont.Object (fields, _) ->

     

       102
       102
       +
           let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       103
       103
       +
           (match List.assoc_opt "streams" assoc with

     

       104
       104
       +
            | Some (Jsont.Array (channel_list, _)) -> ...

     

       105
       105
       +
       

     

       106
       106
       +
       (* NEW - type-safe codec *)

     

       107
       107
       +
       let response_codec =

     

       108
       108
       +
         Jsont.Object.(

     

       109
       109
       +
           map ~kind:"StreamsResponse" (fun streams -> streams)

     

       110
       110
       +
           |> mem "streams" (Jsont.list Channel.jsont) ~enc:(fun x -> x)

     

       111
       111
       +
           |> finish

     

       112
       112
       +
         )

     

       113
       113
       +
       in

     

       114
       114
       +
       match Encode.from_json response_codec json with

     

       115
       115
       +
       | Ok channels -> Ok channels

     

       116
       116
       +
       | Error msg -> Error (...)

     

       117
       117
       +
       ```

     

       118
       118
       +
       

     

       119
       119
       +
       ## Benefits

     

       120
       120
       +
       

     

       121
       121
       +
       ### ✅ Type Safety

     

       122
       122
       +
       - Jsont codecs ensure correct JSON structure

     

       123
       123
       +
       - Compilation errors catch schema mismatches

     

       124
       124
       +
       - No runtime type confusion

     

       125
       125
       +
       

     

       126
       126
       +
       ### ✅ Maintainability

     

       127
       127
       +
       - Protocol changes only require updating codecs

     

       128
       128
       +
       - No manual JSON manipulation scattered through code

     

       129
       129
       +
       - Clear separation of concerns

     

       130
       130
       +
       

     

       131
       131
       +
       ### ✅ Reusability

     

       132
       132
       +
       - Codecs can be composed and reused

     

       133
       133
       +
       - Encode module works for any jsont-encoded type

     

       134
       134
       +
       - Request/response types are self-documenting

     

       135
       135
       +
       

     

       136
       136
       +
       ### ✅ Testability

     

       137
       137
       +
       - Easy to test encoding/decoding in isolation

     

       138
       138
       +
       - Mock responses can be type-checked

     

       139
       139
       +
       - Round-trip property testing possible

     

       140
       140
       +
       

     

       141
       141
       +
       ## Migration Pattern

     

       142
       142
       +
       

     

       143
       143
       +
       When adding new API endpoints:

     

       144
       144
       +
       

     

       145
       145
       +
       1. **Define the protocol type with codec**:

     

       146
       146
       +
          ```ocaml

     

       147
       147
       +
          type my_request = { field1: string; field2: int }

     

       148
       148
       +
       

     

       149
       149
       +
          let my_request_codec =

     

       150
       150
       +
            Jsont.Object.(

     

       151
       151
       +
              map ~kind:"MyRequest" (fun field1 field2 -> { field1; field2 })

     

       152
       152
       +
              |> mem "field1" Jsont.string ~enc:(fun r -> r.field1)

     

       153
       153
       +
              |> mem "field2" Jsont.int ~enc:(fun r -> r.field2)

     

       154
       154
       +
              |> finish

     

       155
       155
       +
            )

     

       156
       156
       +
          ```

     

       157
       157
       +
       

     

       158
       158
       +
       2. **Encode using Encode module**:

     

       159
       159
       +
          ```ocaml

     

       160
       160
       +
          let body = Encode.to_form_urlencoded my_request_codec req in

     

       161
       161
       +
          (* or *)

     

       162
       162
       +
          let json = Encode.to_json_string my_request_codec req in

     

       163
       163
       +
          ```

     

       164
       164
       +
       

     

       165
       165
       +
       3. **Decode responses with codec**:

     

       166
       166
       +
          ```ocaml

     

       167
       167
       +
          match Client.request client ~method_:`POST ~path:"/api/..." ~body () with

     

       168
       168
       +
          | Ok json ->

     

       169
       169
       +
              (match Encode.from_json response_codec json with

     

       170
       170
       +
               | Ok data -> Ok data

     

       171
       171
       +
               | Error msg -> Error ...)

     

       172
       172
       +
          ```

     

       173
       173
       +
       

     

       174
       174
       +
       ## Comparison with Old Approach

     

       175
       175
       +
       

     

       176
       176
       +
       ### Old (Manual JSON Manipulation):

     

       177
       177
       +
       ```ocaml

     

       178
       178
       +
       let send client message =

     

       179
       179
       +
         let json = Message.to_json message in  (* Round-trip conversion *)

     

       180
       180
       +
         let params = match json with

     

       181
       181
       +
           | Jsont.Object (fields, _) ->  (* Manual pattern matching *)

     

       182
       182
       +
               List.fold_left (fun acc ((key, _), value) ->

     

       183
       183
       +
                 let str_value = match value with  (* More pattern matching *)

     

       184
       184
       +
                   | Jsont.String (s, _) -> s

     

       185
       185
       +
                   | Jsont.Bool (true, _) -> "true"

     

       186
       186
       +
                   | _ -> ""

     

       187
       187
       +
                 in

     

       188
       188
       +
                 (key, str_value) :: acc

     

       189
       189
       +
               ) [] fields

     

       190
       190
       +
           | _ -> [] in

     

       191
       191
       +
         (* ... *)

     

       192
       192
       +
       ```

     

       193
       193
       +
       

     

       194
       194
       +
       ### New (Codec-Based):

     

       195
       195
       +
       ```ocaml

     

       196
       196
       +
       let send client message =

     

       197
       197
       +
         let body = Message.to_form_urlencoded message in  (* Clean encoding *)

     

       198
       198
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       199
       199
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/messages"

     

       200
       200
       +
                 ~body ~content_type () with

     

       201
       201
       +
         | Ok response -> Message_response.of_json response

     

       202
       202
       +
         | Error err -> Error err

     

       203
       203
       +
       ```

     

       204
       204
       +
       

     

       205
       205
       +
       ## Future Enhancements

     

       206
       206
       +
       

     

       207
       207
       +
       - **Validation**: Add validation layers on top of codecs

     

       208
       208
       +
       - **Versioning**: Support multiple API versions with codec variants

     

       209
       209
       +
       - **Documentation**: Generate API docs from codec definitions

     

       210
       210
       +
       - **Testing**: Property-based testing with codec round-trips

     

       211
       211
       +
       - **Code Generation**: Consider generating codecs from OpenAPI specs

     

       212
       212
       +
       

     

       213
       213
       +
       ## References

     

       214
       214
       +
       

     

       215
       215
       +
       - Jsont library: https://erratique.ch/software/jsont

     

       216
       216
       +
       - Zulip REST API: https://zulip.com/api/rest

     

       217
       217
       +
       - Original design doc: `CLAUDE.md`

-689

stack/zulip/CLAUDE.md

···

       1
       1
       -
       I would like to build high quality OCaml bindings to the Zulip REST API,

     

       2
       2
       -
       documented at https://zulip.com/api/rest.  As another reference, the Python

     

       3
       3
       -
       `zulip` library from pip is well maintained.

     

       4
       4
       -
       

     

       5
       5
       -
       My target is to use the OCaml EIO direct-style library, with an idiomatic as

     

       6
       6
       -
       possible API that implements it. For JSON parsing, using the jsonm library is

     

       7
       7
       -
       right. For HTTPS, use cohttp-eio with the tls-eio library. You have access to

     

       8
       8
       -
       an OCaml LSP via MCP which provides type hints and other language server

     

       9
       9
       -
       features after you complete a `dune build`.

     

       10
       10
       -
       

     

       11
       11
       -
       # OCaml Zulip Library Design

     

       12
       12
       -
       

     

       13
       13
       -
       Based on analysis of:

     

       14
       14
       -
       - Zulip REST API documentation: https://zulip.com/api/rest

     

       15
       15
       -
       - Python zulip library: https://github.com/zulip/python-zulip-api

     

       16
       16
       -
       - Zulip error handling: https://zulip.com/api/rest-error-handling

     

       17
       17
       -
       - Zulip send message API: https://zulip.com/api/send-message

     

       18
       18
       -
       

     

       19
       19
       -
       ## Overview

     

       20
       20
       -
       The library follows OCaml best practices with abstract types (`type t`) per module, comprehensive constructors/accessors, and proper pretty printers. Each core concept gets its own module with a clean interface.

     

       21
       21
       -
       

     

       22
       22
       -
       ## Module Structure

     

       23
       23
       -
       

     

       24
       24
       -
       ### Authentication (`Zulip.Auth`)

     

       25
       25
       -
       ```ocaml

     

       26
       26
       -
       type t (* abstract *)

     

       27
       27
       -
       

     

       28
       28
       -
       val create : server_url:string -> email:string -> api_key:string -> t

     

       29
       29
       -
       val from_zuliprc : ?path:string -> unit -> (t, Error.t) result

     

       30
       30
       -
       val server_url : t -> string

     

       31
       31
       -
       val email : t -> string

     

       32
       32
       -
       val to_basic_auth_header : t -> string

     

       33
       33
       -
       val pp : Format.formatter -> t -> unit

     

       34
       34
       -
       ```

     

       35
       35
       -
       

     

       36
       36
       -
       ### Error Handling (`Zulip.Error`)

     

       37
       37
       -
       ```ocaml

     

       38
       38
       -
       type code = 

     

       39
       39
       -
         | Invalid_api_key

     

       40
       40
       -
         | Request_variable_missing

     

       41
       41
       -
         | Bad_request

     

       42
       42
       -
         | User_deactivated

     

       43
       43
       -
         | Realm_deactivated

     

       44
       44
       -
         | Rate_limit_hit

     

       45
       45
       -
         | Other of string

     

       46
       46
       -
       

     

       47
       47
       -
       type t (* abstract *)

     

       48
       48
       -
       

     

       49
       49
       -
       val create : code:code -> msg:string -> ?extra:(string * Jsonm.value) list -> unit -> t

     

       50
       50
       -
       val code : t -> code

     

       51
       51
       -
       val message : t -> string

     

       52
       52
       -
       val extra : t -> (string * Jsonm.value) list

     

       53
       53
       -
       val pp : Format.formatter -> t -> unit

     

       54
       54
       -
       val of_json : Jsonm.value -> t option

     

       55
       55
       -
       ```

     

       56
       56
       -
       

     

       57
       57
       -
       ### Message Types (`Zulip.Message_type`)

     

       58
       58
       -
       ```ocaml

     

       59
       59
       -
       type t = [ `Direct | `Channel ]

     

       60
       60
       -
       

     

       61
       61
       -
       val to_string : t -> string

     

       62
       62
       -
       val of_string : string -> t option

     

       63
       63
       -
       val pp : Format.formatter -> t -> unit

     

       64
       64
       -
       ```

     

       65
       65
       -
       

     

       66
       66
       -
       ### Message (`Zulip.Message`)

     

       67
       67
       -
       ```ocaml

     

       68
       68
       -
       type t (* abstract *)

     

       69
       69
       -
       

     

       70
       70
       -
       val create : 

     

       71
       71
       -
         type_:Message_type.t -> 

     

       72
       72
       -
         to_:string list -> 

     

       73
       73
       -
         content:string -> 

     

       74
       74
       -
         ?topic:string -> 

     

       75
       75
       -
         ?queue_id:string -> 

     

       76
       76
       -
         ?local_id:string -> 

     

       77
       77
       -
         ?read_by_sender:bool -> 

     

       78
       78
       -
         unit -> t

     

       79
       79
       -
       

     

       80
       80
       -
       val type_ : t -> Message_type.t

     

       81
       81
       -
       val to_ : t -> string list

     

       82
       82
       -
       val content : t -> string

     

       83
       83
       -
       val topic : t -> string option

     

       84
       84
       -
       val queue_id : t -> string option

     

       85
       85
       -
       val local_id : t -> string option

     

       86
       86
       -
       val read_by_sender : t -> bool

     

       87
       87
       -
       val to_json : t -> Jsonm.value

     

       88
       88
       -
       val pp : Format.formatter -> t -> unit

     

       89
       89
       -
       ```

     

       90
       90
       -
       

     

       91
       91
       -
       ### Message Response (`Zulip.Message_response`)

     

       92
       92
       -
       ```ocaml

     

       93
       93
       -
       type t (* abstract *)

     

       94
       94
       -
       

     

       95
       95
       -
       val id : t -> int

     

       96
       96
       -
       val automatic_new_visibility_policy : t -> string option

     

       97
       97
       -
       val of_json : Jsonm.value -> (t, Error.t) result

     

       98
       98
       -
       val pp : Format.formatter -> t -> unit

     

       99
       99
       -
       ```

     

       100
       100
       -
       

     

       101
       101
       -
       ### Client (`Zulip.Client`)

     

       102
       102
       -
       ```ocaml

     

       103
       103
       -
       type t (* abstract *)

     

       104
       104
       -
       

     

       105
       105
       -
       val create : #Eio.Env.t -> Auth.t -> t

     

       106
       106
       -
       val with_client : #Eio.Env.t -> Auth.t -> (t -> 'a) -> 'a

     

       107
       107
       -
       

     

       108
       108
       -
       val request : 

     

       109
       109
       -
         t -> 

     

       110
       110
       -
         method_:[`GET | `POST | `PUT | `DELETE | `PATCH] ->

     

       111
       111
       -
         path:string -> 

     

       112
       112
       -
         ?params:(string * string) list ->

     

       113
       113
       -
         ?body:string ->

     

       114
       114
       -
         unit -> 

     

       115
       115
       -
         (Jsonm.value, Error.t) result

     

       116
       116
       -
       ```

     

       117
       117
       -
       

     

       118
       118
       -
       ### Messages (`Zulip.Messages`)

     

       119
       119
       -
       ```ocaml

     

       120
       120
       -
       val send : Client.t -> Message.t -> (Message_response.t, Error.t) result

     

       121
       121
       -
       val edit : Client.t -> message_id:int -> ?content:string -> ?topic:string -> unit -> (unit, Error.t) result

     

       122
       122
       -
       val delete : Client.t -> message_id:int -> (unit, Error.t) result

     

       123
       123
       -
       val get : Client.t -> message_id:int -> (Jsonm.value, Error.t) result

     

       124
       124
       -
       val get_messages : 

     

       125
       125
       -
         Client.t -> 

     

       126
       126
       -
         ?anchor:string -> 

     

       127
       127
       -
         ?num_before:int -> 

     

       128
       128
       -
         ?num_after:int -> 

     

       129
       129
       -
         ?narrow:string list -> 

     

       130
       130
       -
         unit -> 

     

       131
       131
       -
         (Jsonm.value, Error.t) result

     

       132
       132
       -
       ```

     

       133
       133
       -
       

     

       134
       134
       -
       ### Channel (`Zulip.Channel`)

     

       135
       135
       -
       ```ocaml

     

       136
       136
       -
       type t (* abstract *)

     

       137
       137
       -
       

     

       138
       138
       -
       val create : 

     

       139
       139
       -
         name:string -> 

     

       140
       140
       -
         description:string -> 

     

       141
       141
       -
         ?invite_only:bool -> 

     

       142
       142
       -
         ?history_public_to_subscribers:bool -> 

     

       143
       143
       -
         unit -> t

     

       144
       144
       -
       

     

       145
       145
       -
       val name : t -> string

     

       146
       146
       -
       val description : t -> string

     

       147
       147
       -
       val invite_only : t -> bool

     

       148
       148
       -
       val history_public_to_subscribers : t -> bool

     

       149
       149
       -
       val to_json : t -> Jsonm.value

     

       150
       150
       -
       val of_json : Jsonm.value -> (t, Error.t) result

     

       151
       151
       -
       val pp : Format.formatter -> t -> unit

     

       152
       152
       -
       ```

     

       153
       153
       -
       

     

       154
       154
       -
       ### Channels (`Zulip.Channels`)

     

       155
       155
       -
       ```ocaml

     

       156
       156
       -
       val create_channel : Client.t -> Channel.t -> (unit, Error.t) result

     

       157
       157
       -
       val delete : Client.t -> name:string -> (unit, Error.t) result

     

       158
       158
       -
       val list : Client.t -> (Channel.t list, Error.t) result

     

       159
       159
       -
       val subscribe : Client.t -> channels:string list -> (unit, Error.t) result

     

       160
       160
       -
       val unsubscribe : Client.t -> channels:string list -> (unit, Error.t) result

     

       161
       161
       -
       ```

     

       162
       162
       -
       

     

       163
       163
       -
       ### User (`Zulip.User`)

     

       164
       164
       -
       ```ocaml

     

       165
       165
       -
       type t (* abstract *)

     

       166
       166
       -
       

     

       167
       167
       -
       val create : 

     

       168
       168
       -
         email:string -> 

     

       169
       169
       -
         full_name:string -> 

     

       170
       170
       -
         ?is_active:bool -> 

     

       171
       171
       -
         ?is_admin:bool -> 

     

       172
       172
       -
         ?is_bot:bool -> 

     

       173
       173
       -
         unit -> t

     

       174
       174
       -
       

     

       175
       175
       -
       val email : t -> string

     

       176
       176
       -
       val full_name : t -> string

     

       177
       177
       -
       val is_active : t -> bool

     

       178
       178
       -
       val is_admin : t -> bool

     

       179
       179
       -
       val is_bot : t -> bool

     

       180
       180
       -
       val to_json : t -> Jsonm.value

     

       181
       181
       -
       val of_json : Jsonm.value -> (t, Error.t) result

     

       182
       182
       -
       val pp : Format.formatter -> t -> unit

     

       183
       183
       -
       ```

     

       184
       184
       -
       

     

       185
       185
       -
       ### Users (`Zulip.Users`)

     

       186
       186
       -
       ```ocaml

     

       187
       187
       -
       val list : Client.t -> (User.t list, Error.t) result

     

       188
       188
       -
       val get : Client.t -> email:string -> (User.t, Error.t) result

     

       189
       189
       -
       val create_user : Client.t -> email:string -> full_name:string -> (unit, Error.t) result

     

       190
       190
       -
       val deactivate : Client.t -> email:string -> (unit, Error.t) result

     

       191
       191
       -
       ```

     

       192
       192
       -
       

     

       193
       193
       -
       ### Event Type (`Zulip.Event_type`)

     

       194
       194
       -
       ```ocaml

     

       195
       195
       -
       type t = 

     

       196
       196
       -
         | Message

     

       197
       197
       -
         | Subscription 

     

       198
       198
       -
         | User_activity

     

       199
       199
       -
         | Other of string

     

       200
       200
       -
       

     

       201
       201
       -
       val to_string : t -> string

     

       202
       202
       -
       val of_string : string -> t

     

       203
       203
       -
       val pp : Format.formatter -> t -> unit

     

       204
       204
       -
       ```

     

       205
       205
       -
       

     

       206
       206
       -
       ### Event (`Zulip.Event`)

     

       207
       207
       -
       ```ocaml

     

       208
       208
       -
       type t (* abstract *)

     

       209
       209
       -
       

     

       210
       210
       -
       val id : t -> int

     

       211
       211
       -
       val type_ : t -> Event_type.t

     

       212
       212
       -
       val data : t -> Jsonm.value

     

       213
       213
       -
       val of_json : Jsonm.value -> (t, Error.t) result

     

       214
       214
       -
       val pp : Format.formatter -> t -> unit

     

       215
       215
       -
       ```

     

       216
       216
       -
       

     

       217
       217
       -
       ### Event Queue (`Zulip.Event_queue`)

     

       218
       218
       -
       ```ocaml

     

       219
       219
       -
       type t (* abstract *)

     

       220
       220
       -
       

     

       221
       221
       -
       val register : 

     

       222
       222
       -
         Client.t -> 

     

       223
       223
       -
         ?event_types:Event_type.t list -> 

     

       224
       224
       -
         unit -> 

     

       225
       225
       -
         (t, Error.t) result

     

       226
       226
       -
       

     

       227
       227
       -
       val id : t -> string

     

       228
       228
       -
       val get_events : t -> Client.t -> ?last_event_id:int -> unit -> (Event.t list, Error.t) result

     

       229
       229
       -
       val delete : t -> Client.t -> (unit, Error.t) result

     

       230
       230
       -
       val pp : Format.formatter -> t -> unit

     

       231
       231
       -
       ```

     

       232
       232
       -
       

     

       233
       233
       -
       ## EIO Bot Framework Extension

     

       234
       234
       -
       

     

       235
       235
       -
       Based on analysis of the Python bot framework at:

     

       236
       236
       -
       - https://github.com/zulip/python-zulip-api/blob/main/zulip_bots/zulip_bots/lib.py

     

       237
       237
       -
       - https://github.com/zulip/python-zulip-api/blob/main/zulip_botserver/zulip_botserver/server.py

     

       238
       238
       -
       

     

       239
       239
       -
       ### Bot Handler (`Zulip.Bot`)

     

       240
       240
       -
       ```ocaml

     

       241
       241
       -
       module Storage : sig

     

       242
       242
       -
         type t (* abstract *)

     

       243
       243
       -
         

     

       244
       244
       -
         val create : Client.t -> t

     

       245
       245
       -
         val get : t -> key:string -> string option

     

       246
       246
       -
         val put : t -> key:string -> value:string -> unit

     

       247
       247
       -
         val contains : t -> key:string -> bool

     

       248
       248
       -
       end

     

       249
       249
       -
       

     

       250
       250
       -
       module Identity : sig

     

       251
       251
       -
         type t (* abstract *)

     

       252
       252
       -
         

     

       253
       253
       -
         val full_name : t -> string

     

       254
       254
       -
         val email : t -> string

     

       255
       255
       -
         val mention_name : t -> string

     

       256
       256
       -
       end

     

       257
       257
       -
       

     

       258
       258
       -
       type handler = {

     

       259
       259
       -
         handle_message : 

     

       260
       260
       -
           client:Client.t ->

     

       261
       261
       -
           message:Jsonm.value ->

     

       262
       262
       -
           response:(Message.t -> unit) ->

     

       263
       263
       -
           unit;

     

       264
       264
       -
         

     

       265
       265
       -
         usage : unit -> string;

     

       266
       266
       -
         description : unit -> string;

     

       267
       267
       -
       }

     

       268
       268
       -
       

     

       269
       269
       -
       type t (* abstract *)

     

       270
       270
       -
       

     

       271
       271
       -
       val create : 

     

       272
       272
       -
         Client.t -> 

     

       273
       273
       -
         handler:handler ->

     

       274
       274
       -
         ?storage:Storage.t ->

     

       275
       275
       -
         unit -> t

     

       276
       276
       -
       

     

       277
       277
       -
       val identity : t -> Identity.t

     

       278
       278
       -
       val storage : t -> Storage.t

     

       279
       279
       -
       val handle_message : t -> Jsonm.value -> unit

     

       280
       280
       -
       val send_reply : t -> original_message:Jsonm.value -> content:string -> unit

     

       281
       281
       -
       val send_message : t -> Message.t -> unit

     

       282
       282
       -
       ```

     

       283
       283
       -
       

     

       284
       284
       -
       ### Bot Server (`Zulip.Bot_server`)

     

       285
       285
       -
       ```ocaml

     

       286
       286
       -
       module Config : sig

     

       287
       287
       -
         type bot_config = {

     

       288
       288
       -
           email : string;

     

       289
       289
       -
           api_key : string;

     

       290
       290
       -
           token : string; (* webhook token *)

     

       291
       291
       -
           server_url : string;

     

       292
       292
       -
           module_name : string;

     

       293
       293
       -
         }

     

       294
       294
       -
         

     

       295
       295
       -
         type t (* abstract *)

     

       296
       296
       -
         

     

       297
       297
       -
         val create : bot_configs:bot_config list -> ?host:string -> ?port:int -> unit -> t

     

       298
       298
       -
         val from_file : string -> (t, Error.t) result

     

       299
       299
       -
         val from_env : string -> (t, Error.t) result

     

       300
       300
       -
         val host : t -> string

     

       301
       301
       -
         val port : t -> int

     

       302
       302
       -
         val bot_configs : t -> bot_config list

     

       303
       303
       -
       end

     

       304
       304
       -
       

     

       305
       305
       -
       type t (* abstract *)

     

       306
       306
       -
       

     

       307
       307
       -
       val create : #Eio.Env.t -> Config.t -> (t, Error.t) result

     

       308
       308
       -
       

     

       309
       309
       -
       val run : t -> unit

     

       310
       310
       -
       (* Starts the server using EIO structured concurrency *)

     

       311
       311
       -
       

     

       312
       312
       -
       val with_server : #Eio.Env.t -> Config.t -> (t -> 'a) -> ('a, Error.t) result

     

       313
       313
       -
       (* Resource-safe server management *)

     

       314
       314
       -
       ```

     

       315
       315
       -
       

     

       316
       316
       -
       ### Bot Registry (`Zulip.Bot_registry`)

     

       317
       317
       -
       ```ocaml

     

       318
       318
       -
       type bot_module = {

     

       319
       319
       -
         name : string;

     

       320
       320
       -
         handler : Bot.handler;

     

       321
       321
       -
         create_instance : Client.t -> Bot.t;

     

       322
       322
       -
       }

     

       323
       323
       -
       

     

       324
       324
       -
       type t (* abstract *)

     

       325
       325
       -
       

     

       326
       326
       -
       val create : unit -> t

     

       327
       327
       -
       val register : t -> bot_module -> unit

     

       328
       328
       -
       val get_handler : t -> email:string -> Bot.t option

     

       329
       329
       -
       val list_bots : t -> string list

     

       330
       330
       -
       

     

       331
       331
       -
       (* Dynamic module loading *)

     

       332
       332
       -
       val load_from_file : string -> (bot_module, Error.t) result

     

       333
       333
       -
       val load_from_directory : string -> (bot_module list, Error.t) result

     

       334
       334
       -
       ```

     

       335
       335
       -
       

     

       336
       336
       -
       ### Webhook Handler (`Zulip.Webhook`)

     

       337
       337
       -
       ```ocaml

     

       338
       338
       -
       type webhook_event = {

     

       339
       339
       -
         bot_email : string;

     

       340
       340
       -
         token : string;

     

       341
       341
       -
         message : Jsonm.value;

     

       342
       342
       -
         trigger : [`Direct_message | `Mention];

     

       343
       343
       -
       }

     

       344
       344
       -
       

     

       345
       345
       -
       type response = {

     

       346
       346
       -
         content : string option;

     

       347
       347
       -
         message_type : Message_type.t option;

     

       348
       348
       -
         to_ : string list option;

     

       349
       349
       -
         topic : string option;

     

       350
       350
       -
       }

     

       351
       351
       -
       

     

       352
       352
       -
       val parse_webhook : string -> (webhook_event, Error.t) result

     

       353
       353
       -
       val handle_webhook : Bot_registry.t -> webhook_event -> (response option, Error.t) result

     

       354
       354
       -
       ```

     

       355
       355
       -
       

     

       356
       356
       -
       ### Structured Concurrency Design

     

       357
       357
       -
       

     

       358
       358
       -
       The EIO-based server uses structured concurrency to manage multiple bots safely:

     

       359
       359
       -
       

     

       360
       360
       -
       ```ocaml

     

       361
       361
       -
       (* Example server implementation using EIO *)

     

       362
       362
       -
       let run_server env config =

     

       363
       363
       -
         let registry = Bot_registry.create () in

     

       364
       364
       -
         

     

       365
       365
       -
         (* Load and register all configured bots concurrently *)

     

       366
       366
       -
         Eio.Switch.run @@ fun sw ->

     

       367
       367
       -
         

     

       368
       368
       -
         (* Start each bot in its own fiber *)

     

       369
       369
       -
         List.iter (fun bot_config ->

     

       370
       370
       -
           Eio.Fiber.fork ~sw (fun () ->

     

       371
       371
       -
             let auth = Auth.create 

     

       372
       372
       -
               ~server_url:bot_config.server_url

     

       373
       373
       -
               ~email:bot_config.email 

     

       374
       374
       -
               ~api_key:bot_config.api_key in

     

       375
       375
       -
             

     

       376
       376
       -
             Client.with_client env auth @@ fun client ->

     

       377
       377
       -
             

     

       378
       378
       -
             (* Load bot module *)

     

       379
       379
       -
             match Bot_registry.load_from_file bot_config.module_name with

     

       380
       380
       -
             | Ok bot_module ->

     

       381
       381
       -
                 let bot = bot_module.create_instance client in

     

       382
       382
       -
                 Bot_registry.register registry bot_module;

     

       383
       383
       -
                 

     

       384
       384
       -
                 (* Keep bot alive and handle events *)

     

       385
       385
       -
                 Event_loop.run client bot

     

       386
       386
       -
             | Error e ->

     

       387
       387
       -
                 Printf.eprintf "Failed to load bot %s: %s\n" 

     

       388
       388
       -
                   bot_config.email (Error.message e)

     

       389
       389
       -
           )

     

       390
       390
       -
         ) (Config.bot_configs config);

     

       391
       391
       -
         

     

       392
       392
       -
         (* Start HTTP server for webhooks *)

     

       393
       393
       -
         let server_addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, Config.port config) in

     

       394
       394
       -
         Eio.Net.run_server env#net server_addr ~on_error:raise @@ fun flow _addr ->

     

       395
       395
       -
           

     

       396
       396
       -
           (* Handle each webhook request concurrently *)

     

       397
       397
       -
           Eio.Switch.run @@ fun req_sw ->

     

       398
       398
       -
           Eio.Fiber.fork ~sw:req_sw (fun () ->

     

       399
       399
       -
             handle_http_request registry flow

     

       400
       400
       -
           )

     

       401
       401
       -
       ```

     

       402
       402
       -
       

     

       403
       403
       -
       ### Event Loop (`Zulip.Event_loop`)

     

       404
       404
       -
       ```ocaml

     

       405
       405
       -
       type t (* abstract *)

     

       406
       406
       -
       

     

       407
       407
       -
       val create : Client.t -> Bot.t -> t

     

       408
       408
       -
       

     

       409
       409
       -
       val run : Client.t -> Bot.t -> unit

     

       410
       410
       -
       (* Runs the event loop using real-time events API *)

     

       411
       411
       -
       

     

       412
       412
       -
       val run_webhook_mode : Client.t -> Bot.t -> unit  

     

       413
       413
       -
       (* Runs in webhook mode, waiting for HTTP callbacks *)

     

       414
       414
       -
       

     

       415
       415
       -
       (* For advanced use cases *)

     

       416
       416
       -
       val with_event_loop : 

     

       417
       417
       -
         Client.t -> 

     

       418
       418
       -
         Bot.t -> 

     

       419
       419
       -
         (Event_queue.t -> unit) -> 

     

       420
       420
       -
         unit

     

       421
       421
       -
       ```

     

       422
       422
       -
       

     

       423
       423
       -
       ## Key EIO Advantages

     

       424
       424
       -
       

     

       425
       425
       -
       1. **Structured Concurrency**: Each bot runs in its own fiber with proper cleanup

     

       426
       426
       -
       2. **Resource Safety**: Automatic cleanup of connections, event queues, and HTTP servers

     

       427
       427
       -
       3. **Backpressure**: Natural flow control through EIO's cooperative scheduling

     

       428
       428
       -
       4. **Error Isolation**: Bot failures don't crash the entire server

     

       429
       429
       -
       5. **Graceful Shutdown**: Structured teardown of all resources

     

       430
       430
       -
       

     

       431
       431
       -
       ## Design Principles

     

       432
       432
       -
       

     

       433
       433
       -
       1. **Abstract Types**: Each major concept has its own module with abstract `type t`

     

       434
       434
       -
       2. **Constructors**: Clear `create` functions with optional parameters

     

       435
       435
       -
       3. **Accessors**: All fields accessible via dedicated functions

     

       436
       436
       -
       4. **Pretty Printing**: Every type has a `pp` function for debugging

     

       437
       437
       -
       5. **JSON Conversion**: Bidirectional JSON conversion where appropriate

     

       438
       438
       -
       6. **Error Handling**: Consistent `(_, Error.t) result` return types

     

       439
       439
       -
       

     

       440
       440
       -
       ## Authentication Strategy

     

       441
       441
       -
       

     

       442
       442
       -
       - Support zuliprc files and direct credential passing

     

       443
       443
       -
       - Abstract `Auth.t` prevents credential leakage

     

       444
       444
       -
       - HTTP Basic Auth with proper encoding

     

       445
       445
       -
       

     

       446
       446
       -
       ## EIO Integration

     

       447
       447
       -
       

     

       448
       448
       -
       - All operations use EIO's direct-style async

     

       449
       449
       -
       - Resource-safe client management with `with_client`

     

       450
       450
       -
       - Proper cleanup of connections and event queues

     

       451
       451
       -
       

     

       452
       452
       -
       ## Example Usage

     

       453
       453
       -
       

     

       454
       454
       -
       ### Simple Message Sending

     

       455
       455
       -
       ```ocaml

     

       456
       456
       -
       let () =

     

       457
       457
       -
         Eio_main.run @@ fun env ->

     

       458
       458
       -
         let auth = Zulip.Auth.create 

     

       459
       459
       -
           ~server_url:"https://example.zulipchat.com"

     

       460
       460
       -
           ~email:"bot@example.com" 

     

       461
       461
       -
           ~api_key:"your-api-key" in

     

       462
       462
       -
         

     

       463
       463
       -
         Zulip.Client.with_client env auth @@ fun client ->

     

       464
       464
       -
         

     

       465
       465
       -
         let message = Zulip.Message.create 

     

       466
       466
       -
           ~type_:`Channel

     

       467
       467
       -
           ~to_:["general"]

     

       468
       468
       -
           ~content:"Hello from OCaml!"

     

       469
       469
       -
           ~topic:"Bots" 

     

       470
       470
       -
           () in

     

       471
       471
       -
         

     

       472
       472
       -
         match Zulip.Messages.send client message with

     

       473
       473
       -
         | Ok response -> 

     

       474
       474
       -
             Printf.printf "Message sent with ID: %d\n" 

     

       475
       475
       -
               (Zulip.Message_response.id response)

     

       476
       476
       -
         | Error error -> 

     

       477
       477
       -
             Printf.printf "Error: %s\n" 

     

       478
       478
       -
               (Zulip.Error.message error)

     

       479
       479
       -
       ```

     

       480
       480
       -
       

     

       481
       481
       -
       ### Simple Bot

     

       482
       482
       -
       ```ocaml

     

       483
       483
       -
       let echo_handler = Zulip.Bot.{

     

       484
       484
       -
         handle_message = (fun ~client ~message ~response ->

     

       485
       485
       -
           let content = extract_content message in

     

       486
       486
       -
           let echo_msg = Message.create 

     

       487
       487
       -
             ~type_:`Direct 

     

       488
       488
       -
             ~to_:[sender_email message]

     

       489
       489
       -
             ~content:("Echo: " ^ content) () in

     

       490
       490
       -
           response echo_msg

     

       491
       491
       -
         );

     

       492
       492
       -
         usage = (fun () -> "Echo bot - repeats your message");

     

       493
       493
       -
         description = (fun () -> "A simple echo bot");

     

       494
       494
       -
       }

     

       495
       495
       -
       

     

       496
       496
       -
       let () =

     

       497
       497
       -
         Eio_main.run @@ fun env ->

     

       498
       498
       -
         let auth = Auth.from_zuliprc () |> Result.get_ok in

     

       499
       499
       -
         

     

       500
       500
       -
         Client.with_client env auth @@ fun client ->

     

       501
       501
       -
         let bot = Bot.create client ~handler:echo_handler () in

     

       502
       502
       -
         Event_loop.run client bot

     

       503
       503
       -
       ```

     

       504
       504
       -
       

     

       505
       505
       -
       ### Multi-Bot Server

     

       506
       506
       -
       ```ocaml

     

       507
       507
       -
       let () =

     

       508
       508
       -
         Eio_main.run @@ fun env ->

     

       509
       509
       -
         let config = Bot_server.Config.from_file "bots.conf" |> Result.get_ok in

     

       510
       510
       -
         

     

       511
       511
       -
         Bot_server.with_server env config @@ fun server ->

     

       512
       512
       -
         Bot_server.run server

     

       513
       513
       -
       ```

     

       514
       514
       -
       

     

       515
       515
       -
       ## Package Dependencies

     

       516
       516
       -
       

     

       517
       517
       -
       - `eio` - Effects-based I/O

     

       518
       518
       -
       - `cohttp-eio` - HTTP client with EIO support  

     

       519
       519
       -
       - `tls-eio` - TLS support for HTTPS

     

       520
       520
       -
       - `jsonm` - Streaming JSON codec

     

       521
       521
       -
       - `uri` - URI parsing and manipulation

     

       522
       522
       -
       - `base64` - Base64 encoding for authentication

     

       523
       523
       -
       

     

       524
       524
       -
       # Architecture Analysis: zulip_bot vs zulip_botserver

     

       525
       525
       -
       

     

       526
       526
       -
       ## Library Separation

     

       527
       527
       -
       

     

       528
       528
       -
       ### `zulip_bot` - Individual Bot Framework

     

       529
       529
       -
       **Purpose**: Library for building and running a single bot instance

     

       530
       530
       -
       

     

       531
       531
       -
       **Key Components**:

     

       532
       532
       -
       - `Bot_handler` - Interface for bot logic with EIO environment access

     

       533
       533
       -
       - `Bot_runner` - Manages lifecycle of one bot (real-time events or webhook mode)

     

       534
       534
       -
       - `Bot_config` - Configuration for a single bot

     

       535
       535
       -
       - `Bot_storage` - Simple in-memory storage for bot state

     

       536
       536
       -
       

     

       537
       537
       -
       **Usage Pattern**:

     

       538
       538
       -
       ```ocaml

     

       539
       539
       -
       (* Run a single bot directly *)

     

       540
       540
       -
       let my_bot = Bot_handler.create (module My_echo_bot) ~config ~storage ~identity in

     

       541
       541
       -
       let runner = Bot_runner.create ~client ~handler:my_bot in

     

       542
       542
       -
       Bot_runner.run_realtime runner  (* Bot connects to Zulip events API directly *)

     

       543
       543
       -
       ```

     

       544
       544
       -
       

     

       545
       545
       -
       ### `zulip_botserver` - Multi-Bot Server Infrastructure  

     

       546
       546
       -
       **Purpose**: HTTP server that manages multiple bots via webhooks

     

       547
       547
       -
       

     

       548
       548
       -
       **Key Components**:

     

       549
       549
       -
       - `Bot_server` - HTTP server receiving webhook events from Zulip

     

       550
       550
       -
       - `Bot_registry` - Manages multiple bot instances  

     

       551
       551
       -
       - `Server_config` - Configuration for multiple bots + server settings

     

       552
       552
       -
       - `Webhook_handler` - Parses incoming webhook requests and routes to appropriate bots

     

       553
       553
       -
       

     

       554
       554
       -
       **Usage Pattern**:

     

       555
       555
       -
       ```ocaml

     

       556
       556
       -
       (* Run a server hosting multiple bots *)

     

       557
       557
       -
       let registry = Bot_registry.create () in

     

       558
       558
       -
       Bot_registry.register registry echo_bot_module;

     

       559
       559
       -
       Bot_registry.register registry weather_bot_module;

     

       560
       560
       -
       

     

       561
       561
       -
       let server = Bot_server.create ~env ~config ~registry in

     

       562
       562
       -
       Bot_server.run server  (* HTTP server waits for webhook calls *)

     

       563
       563
       -
       ```

     

       564
       564
       -
       

     

       565
       565
       -
       ## EIO Environment Requirements

     

       566
       566
       -
       

     

       567
       567
       -
       ### Why Bot Handlers Need Direct EIO Access

     

       568
       568
       -
       

     

       569
       569
       -
       Bot handlers require direct access to the EIO environment for legitimate I/O operations beyond HTTP requests to Zulip:

     

       570
       570
       -
       

     

       571
       571
       -
       1. **Network Operations**: Custom HTTP requests, API calls to external services

     

       572
       572
       -
       2. **File System Operations**: Reading configuration files, CSV dictionaries, logs

     

       573
       573
       -
       3. **Resource Management**: Proper cleanup via structured concurrency

     

       574
       574
       -
       

     

       575
       575
       -
       ### Example: URL Checker Bot

     

       576
       576
       -
       ```ocaml

     

       577
       577
       -
       module Url_checker_bot : Zulip_bot.Bot_handler.Bot_handler = struct

     

       578
       578
       -
         let handle_message ~config ~storage ~identity ~message ~env =

     

       579
       579
       -
           match parse_command message with

     

       580
       580
       -
           | "!check", url ->

     

       581
       581
       -
               (* Direct EIO network access needed *)

     

       582
       582
       -
               Eio.Switch.run @@ fun sw ->

     

       583
       583
       -
               let client = Cohttp_eio.Client.make ~sw env#net in

     

       584
       584
       -
               let response = Cohttp_eio.Client.head ~sw client (Uri.of_string url) in

     

       585
       585
       -
               let status = Cohttp.Code.code_of_status response.status in

     

       586
       586
       -
               Ok (Response.reply ~content:(format_status_message url status))

     

       587
       587
       -
           | _ -> Ok Response.none

     

       588
       588
       -
       end

     

       589
       589
       -
       ```

     

       590
       590
       -
       

     

       591
       591
       -
       ### Example: CSV Dictionary Bot

     

       592
       592
       -
       ```ocaml  

     

       593
       593
       -
       module Csv_dict_bot : Zulip_bot.Bot_handler.Bot_handler = struct

     

       594
       594
       -
         let handle_message ~config ~storage ~identity ~message ~env =

     

       595
       595
       -
           match parse_command message with

     

       596
       596
       -
           | "!lookup", term ->

     

       597
       597
       -
               (* Direct EIO file system access needed *)

     

       598
       598
       -
               let csv_path = Bot_config.get_required config ~key:"csv_file" in

     

       599
       599
       -
               let content = Eio.Path.load env#fs (Eio.Path.parse csv_path) in

     

       600
       600
       -
               let matches = search_csv_content content term in

     

       601
       601
       -
               Ok (Response.reply ~content:(format_matches matches))

     

       602
       602
       -
           | _ -> Ok Response.none

     

       603
       603
       -
       end

     

       604
       604
       -
       ```

     

       605
       605
       -
       

     

       606
       606
       -
       ## Refined Bot Handler Interface

     

       607
       607
       -
       

     

       608
       608
       -
       Based on analysis, the current EIO environment plumbing is **essential** and should be cleaned up:

     

       609
       609
       -
       

     

       610
       610
       -
       ```ocaml

     

       611
       611
       -
       (** Clean bot handler interface with direct EIO access *)

     

       612
       612
       -
       module type Bot_handler = sig

     

       613
       613
       -
         val initialize : Bot_config.t -> (unit, Zulip.Error.t) result

     

       614
       614
       -
         val usage : unit -> string

     

       615
       615
       -
         val description : unit -> string

     

       616
       616
       -
         

     

       617
       617
       -
         (** Handle message with full EIO environment access *)

     

       618
       618
       -
         val handle_message : 

     

       619
       619
       -
           config:Bot_config.t ->

     

       620
       620
       -
           storage:Bot_storage.t ->

     

       621
       621
       -
           identity:Identity.t ->

     

       622
       622
       -
           message:Message_context.t ->

     

       623
       623
       -
           env:#Eio.Env.t ->  (* Essential for custom I/O *)

     

       624
       624
       -
           (Response.t, Zulip.Error.t) result

     

       625
       625
       -
       end

     

       626
       626
       -
       

     

       627
       627
       -
       type t

     

       628
       628
       -
       

     

       629
       629
       -
       (** Single creation interface *)

     

       630
       630
       -
       val create : 

     

       631
       631
       -
         (module Bot_handler) -> 

     

       632
       632
       -
         config:Bot_config.t -> 

     

       633
       633
       -
         storage:Bot_storage.t -> 

     

       634
       634
       -
         identity:Identity.t -> 

     

       635
       635
       -
         t

     

       636
       636
       -
       

     

       637
       637
       -
       (** Single message handler requiring EIO environment *)

     

       638
       638
       -
       val handle_message : t -> #Eio.Env.t -> Message_context.t -> (Response.t, Zulip.Error.t) result

     

       639
       639
       -
       ```

     

       640
       640
       -
       

     

       641
       641
       -
       ## Storage Strategy

     

       642
       642
       -
       

     

       643
       643
       -
       Bot storage can be simplified to in-memory key-value storage since it's server-side:

     

       644
       644
       -
       

     

       645
       645
       -
       ```ocaml

     

       646
       646
       -
       (* In zulip_bot - storage per bot instance *)

     

       647
       647
       -
       module Bot_storage = struct

     

       648
       648
       -
         type t = (string, string) Hashtbl.t  (* Simple in-memory key-value *)

     

       649
       649
       -
         

     

       650
       650
       -
         let create () = Hashtbl.create 16

     

       651
       651
       -
         let get t ~key = Hashtbl.find_opt t key  

     

       652
       652
       -
         let put t ~key ~value = Hashtbl.replace t key value

     

       653
       653
       -
         let contains t ~key = Hashtbl.mem t key

     

       654
       654
       -
       end

     

       655
       655
       -
       

     

       656
       656
       -
       (* In zulip_botserver - storage shared across bots *)

     

       657
       657
       -
       module Server_storage = struct

     

       658
       658
       -
         type t = (string * string, string) Hashtbl.t  (* (bot_email, key) -> value *)

     

       659
       659
       -
         

     

       660
       660
       -
         let create () = Hashtbl.create 64

     

       661
       661
       -
         let get t ~bot_email ~key = Hashtbl.find_opt t (bot_email, key)

     

       662
       662
       -
         let put t ~bot_email ~key ~value = Hashtbl.replace t (bot_email, key) value

     

       663
       663
       -
       end

     

       664
       664
       -
       ```

     

       665
       665
       -
       

     

       666
       666
       -
       ## Interface Cleanup Recommendations

     

       667
       667
       -
       

     

       668
       668
       -
       1. **Remove** the problematic `handle_message` function with mock environment

     

       669
       669
       -
       2. **Keep** `handle_message_with_env` but rename to `handle_message`

     

       670
       670
       -
       3. **Use** `#Eio.Env.t` constraint for clean typing

     

       671
       671
       -
       4. **Document** that bot handlers have full EIO access for custom I/O operations

     

       672
       672
       -
       

     

       673
       673
       -
       This design maintains flexibility for real-world bot functionality while providing clean, type-safe interfaces.

     

       674
       674
       -
       

     

       675
       675
       -
       ## Sources and References

     

       676
       676
       -
       

     

       677
       677
       -
       This design is based on comprehensive analysis of:

     

       678
       678
       -
       

     

       679
       679
       -
       1. **Zulip REST API Documentation**:

     

       680
       680
       -
          - Main API: https://zulip.com/api/rest

     

       681
       681
       -
          - Error Handling: https://zulip.com/api/rest-error-handling  

     

       682
       682
       -
          - Send Message: https://zulip.com/api/send-message

     

       683
       683
       -
       

     

       684
       684
       -
       2. **Python Zulip Library**:

     

       685
       685
       -
          - Main repository: https://github.com/zulip/python-zulip-api

     

       686
       686
       -
          - Bot framework: https://github.com/zulip/python-zulip-api/blob/main/zulip_bots/zulip_bots/lib.py

     

       687
       687
       -
          - Bot server: https://github.com/zulip/python-zulip-api/blob/main/zulip_botserver/zulip_botserver/server.py

     

       688
       688
       -
       

     

       689
       689
       -
       The design adapts these Python patterns to idiomatic OCaml with abstract types, proper error handling, and EIO's structured concurrency for robust, type-safe Zulip integration.

+2 -2

stack/zulip/dune-project

···

       2
       2
        
       

     

       3
       3
        
       (name ocaml-zulip)

     

       4
       4
        
       

     

       5
       5
       +
       (generate_opam_files true)

     

       6
       6
       +
       

     

       5
       7
        
       (package

     

       6
       8
        
        (name zulip)

     

       7
       9
        
        (synopsis "OCaml bindings for the Zulip REST API")

     
···

       11
       13
        
         dune

     

       12
       14
        
         eio

     

       13
       15
        
         requests

     

       14
       14
       -
         ezjsonm

     

       15
       16
        
         uri

     

       16
       17
        
         base64

     

       17
       18
        
         (alcotest :with-test)

     
···

       26
       27
        
         dune

     

       27
       28
        
         zulip

     

       28
       29
        
         eio

     

       29
       29
       -
         ezjsonm

     

       30
       30
        
         (alcotest :with-test)))

     

       31
       31
        
       

     

       32
       32
        
       (package

+2 -5

stack/zulip/examples/example.ml

···

       31
       31
        
           (match Message.topic message with Some t -> t | None -> "None");

     

       32
       32
        
       

     

       33
       33
        
         (* Test JSON serialization *)

     

       34
       34
       -
         let json = Message.to_json message in

     

       35
       35
       -
         Printf.printf "\nMessage JSON: %s\n"

     

       36
       36
       -
           (match json with

     

       37
       37
       -
            | `O _ -> "JSON object (serialized correctly)"

     

       38
       38
       -
            | _ -> "Invalid JSON");

     

       34
       34
       +
         let json_str = Message.to_json_string message in

     

       35
       35
       +
         Printf.printf "\nMessage JSON: %s\n" json_str;

     

       39
       36
        
       

     

       40
       37
        
         (* Create client *)

     

       41
       38
        
         let client = Client.create ~sw env auth in

+4 -3

stack/zulip/examples/test_client.ml

···

       48
       48
        
         | Ok json ->

     

       49
       49
        
             Printf.printf "Fetched messages successfully!\n";

     

       50
       50
        
             (match json with

     

       51
       51
       -
              | `O fields ->

     

       52
       52
       -
                  (match List.assoc_opt "messages" fields with

     

       53
       53
       -
                   | Some (`A messages) ->

     

       51
       51
       +
              | Jsont.Object (fields, _) ->

     

       52
       52
       +
                  let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       53
       53
       +
                  (match List.assoc_opt "messages" assoc with

     

       54
       54
       +
                   | Some (Jsont.Array (messages, _)) ->

     

       54
       55
        
                       Printf.printf "Got %d messages\n" (List.length messages)

     

       55
       56
        
                   | _ -> Printf.printf "No messages field found\n")

     

       56
       57
        
              | _ -> Printf.printf "Unexpected JSON format\n")

+25 -33

stack/zulip/lib/zulip/lib/channel.ml

···

       13
       13
        
       let invite_only t = t.invite_only

     

       14
       14
        
       let history_public_to_subscribers t = t.history_public_to_subscribers

     

       15
       15
        
       

     

       16
       16
       -
       let to_json t = 

     

       17
       17
       -
         `O [

     

       18
       18
       -
           ("name", `String t.name);

     

       19
       19
       -
           ("description", `String t.description);

     

       20
       20
       -
           ("invite_only", `Bool t.invite_only);

     

       21
       21
       -
           ("history_public_to_subscribers", `Bool t.history_public_to_subscribers);

     

       22
       22
       -
         ]

     

       16
       16
       +
       let pp fmt t = Format.fprintf fmt "Channel{name=%s, description=%s}" t.name t.description

     

       23
       17
        
       

     

       24
       24
       -
       let of_json json = 

     

       25
       25
       -
         try

     

       26
       26
       -
           match json with

     

       27
       27
       -
           | `O fields ->

     

       28
       28
       -
               let get_string key = 

     

       29
       29
       -
                 match List.assoc key fields with 

     

       30
       30
       -
                 | `String s -> s 

     

       31
       31
       -
                 | _ -> failwith ("Expected string for " ^ key) in

     

       32
       32
       -
               let get_bool key default = 

     

       33
       33
       -
                 match List.assoc_opt key fields with 

     

       34
       34
       -
                 | Some (`Bool b) -> b 

     

       35
       35
       -
                 | None -> default

     

       36
       36
       -
                 | _ -> failwith ("Expected bool for " ^ key) in

     

       37
       37
       -
               

     

       38
       38
       -
               let name = get_string "name" in

     

       39
       39
       -
               let description = get_string "description" in

     

       40
       40
       -
               let invite_only = get_bool "invite_only" false in

     

       41
       41
       -
               let history_public_to_subscribers = get_bool "history_public_to_subscribers" true in

     

       42
       42
       -
               

     

       43
       43
       -
               Ok { name; description; invite_only; history_public_to_subscribers }

     

       44
       44
       -
           | _ -> 

     

       45
       45
       -
               Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:"Channel JSON must be an object" ())

     

       46
       46
       -
         with

     

       47
       47
       -
         | exn ->

     

       48
       48
       -
             Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:("Channel JSON parsing failed: " ^ Printexc.to_string exn) ())

     

       18
       18
       +
       (* Jsont codec for channel *)

     

       19
       19
       +
       let jsont =

     

       20
       20
       +
         let kind = "Channel" in

     

       21
       21
       +
         let doc = "A Zulip channel (stream)" in

     

       22
       22
       +
         let make name description invite_only history_public_to_subscribers =

     

       23
       23
       +
           { name; description; invite_only; history_public_to_subscribers }

     

       24
       24
       +
         in

     

       25
       25
       +
         Jsont.Object.map ~kind ~doc make

     

       26
       26
       +
         |> Jsont.Object.mem "name" Jsont.string ~enc:name

     

       27
       27
       +
         |> Jsont.Object.mem "description" Jsont.string ~enc:description

     

       28
       28
       +
         |> Jsont.Object.mem "invite_only" Jsont.bool ~enc:invite_only

     

       29
       29
       +
         |> Jsont.Object.mem "history_public_to_subscribers" Jsont.bool ~enc:history_public_to_subscribers

     

       30
       30
       +
         |> Jsont.Object.finish

     

       31
       31
       +
       

     

       32
       32
       +
       (* Decode and encode functions using Encode module *)

     

       33
       33
       +
       let of_json json =

     

       34
       34
       +
         match Encode.from_json jsont json with

     

       35
       35
       +
         | Ok v -> Ok v

     

       36
       36
       +
         | Error msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg ())

     

       37
       37
       +
       

     

       38
       38
       +
       let to_json_string t =

     

       39
       39
       +
         Encode.to_json_string jsont t

     

       49
       40
        
       

     

       50
       50
       -
       let pp fmt t = Format.fprintf fmt "Channel{name=%s, description=%s}" t.name t.description
     

       41
       41
       +
       let to_form_urlencoded t =

     

       42
       42
       +
         Encode.to_form_urlencoded jsont t

+17 -6

stack/zulip/lib/zulip/lib/channel.mli

···

       1
       1
        
       type t

     

       2
       2
        
       

     

       3
       3
       -
       val create : 

     

       4
       4
       -
         name:string -> 

     

       5
       5
       -
         description:string -> 

     

       6
       6
       -
         ?invite_only:bool -> 

     

       7
       7
       -
         ?history_public_to_subscribers:bool -> 

     

       3
       3
       +
       val create :

     

       4
       4
       +
         name:string ->

     

       5
       5
       +
         description:string ->

     

       6
       6
       +
         ?invite_only:bool ->

     

       7
       7
       +
         ?history_public_to_subscribers:bool ->

     

       8
       8
        
         unit -> t

     

       9
       9
        
       

     

       10
       10
        
       val name : t -> string

     

       11
       11
        
       val description : t -> string

     

       12
       12
        
       val invite_only : t -> bool

     

       13
       13
        
       val history_public_to_subscribers : t -> bool

     

       14
       14
       -
       val to_json : t -> Zulip_types.json

     

       14
       14
       +
       

     

       15
       15
       +
       (** Jsont codec for the channel type *)

     

       16
       16
       +
       val jsont : t Jsont.t

     

       17
       17
       +
       

     

       18
       18
       +
       (** Decode from Jsont.json *)

     

       15
       19
        
       val of_json : Zulip_types.json -> (t, Zulip_types.zerror) result

     

       20
       20
       +
       

     

       21
       21
       +
       (** Encode to JSON string *)

     

       22
       22
       +
       val to_json_string : t -> string

     

       23
       23
       +
       

     

       24
       24
       +
       (** Encode to form-urlencoded string *)

     

       25
       25
       +
       val to_form_urlencoded : t -> string

     

       26
       26
       +
       

     

       16
       27
        
       val pp : Format.formatter -> t -> unit

+53 -43

stack/zulip/lib/zulip/lib/channels.ml

···

       1
       1
       -
       let create_channel client channel = 

     

       2
       2
       -
         let body = match Channel.to_json channel with

     

       3
       3
       -
           | `O fields -> 

     

       4
       4
       -
               String.concat "&" (List.map (fun (k, v) -> 

     

       5
       5
       -
                 match v with 

     

       6
       6
       -
                 | `String s -> k ^ "=" ^ Uri.pct_encode s

     

       7
       7
       -
                 | `Bool b -> k ^ "=" ^ string_of_bool b

     

       8
       8
       -
                 | _ -> ""

     

       9
       9
       -
               ) fields)

     

       10
       10
       -
           | _ -> "" in

     

       11
       11
       -
         match Client.request client ~method_:`POST ~path:"/api/v1/streams" ~body () with

     

       1
       1
       +
       let create_channel client channel =

     

       2
       2
       +
         let body = Channel.to_form_urlencoded channel in

     

       3
       3
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       4
       4
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/streams" ~body ~content_type () with

     

       12
       5
        
         | Ok _json -> Ok ()

     

       13
       6
        
         | Error err -> Error err

     

       14
       7
        
       

     

       15
       15
       -
       let delete client ~name = 

     

       8
       8
       +
       let delete client ~name =

     

       16
       9
        
         let encoded_name = Uri.pct_encode name in

     

       17
       10
        
         match Client.request client ~method_:`DELETE ~path:("/api/v1/streams/" ^ encoded_name) () with

     

       18
       11
        
         | Ok _json -> Ok ()

     

       19
       12
        
         | Error err -> Error err

     

       20
       13
        
       

     

       21
       21
       -
       let list client = 

     

       14
       14
       +
       let list client =

     

       15
       15
       +
         (* Define response codec *)

     

       16
       16
       +
         let response_codec =

     

       17
       17
       +
           Jsont.Object.(

     

       18
       18
       +
             map ~kind:"StreamsResponse" (fun streams -> streams)

     

       19
       19
       +
             |> mem "streams" (Jsont.list Channel.jsont) ~enc:(fun x -> x)

     

       20
       20
       +
             |> finish

     

       21
       21
       +
           )

     

       22
       22
       +
         in

     

       23
       23
       +
       

     

       22
       24
        
         match Client.request client ~method_:`GET ~path:"/api/v1/streams" () with

     

       23
       23
       -
         | Ok json -> 

     

       24
       24
       -
             (match json with

     

       25
       25
       -
              | `O fields ->

     

       26
       26
       -
                  (match List.assoc_opt "streams" fields with

     

       27
       27
       -
                   | Some (`A channel_list) ->

     

       28
       28
       -
                       let channels = List.fold_left (fun acc channel_json ->

     

       29
       29
       -
                         match Channel.of_json channel_json with

     

       30
       30
       -
                         | Ok channel -> channel :: acc

     

       31
       31
       -
                         | Error _ -> acc

     

       32
       32
       -
                       ) [] channel_list in

     

       33
       33
       -
                       Ok (List.rev channels)

     

       34
       34
       -
                   | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid streams response format" ()))

     

       35
       35
       -
              | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Streams response must be an object" ()))

     

       25
       25
       +
         | Ok json ->

     

       26
       26
       +
             (match Encode.from_json response_codec json with

     

       27
       27
       +
              | Ok channels -> Ok channels

     

       28
       28
       +
              | Error msg -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))

     

       36
       29
        
         | Error err -> Error err

     

       37
       30
        
       

     

       38
       38
       -
       let subscribe client ~channels = 

     

       39
       39
       -
         let channels_json = `A (List.map (fun name -> `String name) channels) in

     

       40
       40
       -
         let body = "subscriptions=" ^ (match channels_json with

     

       41
       41
       -
           | `A items -> "[" ^ String.concat "," (List.map (function 

     

       42
       42
       -
               | `String s -> "\"" ^ s ^ "\""

     

       43
       43
       -
               | _ -> "") items) ^ "]"

     

       44
       44
       -
           | _ -> "[]") in

     

       45
       45
       -
         match Client.request client ~method_:`POST ~path:"/api/v1/users/me/subscriptions" ~body () with

     

       31
       31
       +
       (* Request types with jsont codecs *)

     

       32
       32
       +
       module Subscribe_request = struct

     

       33
       33
       +
         type t = { subscriptions : string list }

     

       34
       34
       +
       

     

       35
       35
       +
         let codec =

     

       36
       36
       +
           Jsont.Object.(

     

       37
       37
       +
             map ~kind:"SubscribeRequest" (fun subscriptions -> { subscriptions })

     

       38
       38
       +
             |> mem "subscriptions" (Jsont.list Jsont.string) ~enc:(fun r -> r.subscriptions)

     

       39
       39
       +
             |> finish

     

       40
       40
       +
           )

     

       41
       41
       +
       end

     

       42
       42
       +
       

     

       43
       43
       +
       module Unsubscribe_request = struct

     

       44
       44
       +
         type t = { delete : string list }

     

       45
       45
       +
       

     

       46
       46
       +
         let codec =

     

       47
       47
       +
           Jsont.Object.(

     

       48
       48
       +
             map ~kind:"UnsubscribeRequest" (fun delete -> { delete })

     

       49
       49
       +
             |> mem "delete" (Jsont.list Jsont.string) ~enc:(fun r -> r.delete)

     

       50
       50
       +
             |> finish

     

       51
       51
       +
           )

     

       52
       52
       +
       end

     

       53
       53
       +
       

     

       54
       54
       +
       let subscribe client ~channels =

     

       55
       55
       +
         let req = Subscribe_request.{ subscriptions = channels } in

     

       56
       56
       +
         let body = Encode.to_form_urlencoded Subscribe_request.codec req in

     

       57
       57
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       58
       58
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/users/me/subscriptions" ~body ~content_type () with

     

       46
       59
        
         | Ok _json -> Ok ()

     

       47
       60
        
         | Error err -> Error err

     

       48
       61
        
       

     

       49
       49
       -
       let unsubscribe client ~channels = 

     

       50
       50
       -
         let channels_json = `A (List.map (fun name -> `String name) channels) in

     

       51
       51
       -
         let body = "delete=" ^ (match channels_json with

     

       52
       52
       -
           | `A items -> "[" ^ String.concat "," (List.map (function 

     

       53
       53
       -
               | `String s -> "\"" ^ s ^ "\""

     

       54
       54
       -
               | _ -> "") items) ^ "]"

     

       55
       55
       -
           | _ -> "[]") in

     

       56
       56
       -
         match Client.request client ~method_:`DELETE ~path:"/api/v1/users/me/subscriptions" ~body () with

     

       62
       62
       +
       let unsubscribe client ~channels =

     

       63
       63
       +
         let req = Unsubscribe_request.{ delete = channels } in

     

       64
       64
       +
         let body = Encode.to_form_urlencoded Unsubscribe_request.codec req in

     

       65
       65
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       66
       66
       +
         match Client.request client ~method_:`DELETE ~path:"/api/v1/users/me/subscriptions" ~body ~content_type () with

     

       57
       67
        
         | Ok _json -> Ok ()

     

       58
       58
       -
         | Error err -> Error err
     

       68
       68
       +
         | Error err -> Error err

+17 -16

stack/zulip/lib/zulip/lib/client.ml

···

       4
       4
        
       

     

       5
       5
        
       type t = {

     

       6
       6
        
         auth : Auth.t;

     

       7
       7
       -
         session : (float Eio.Time.clock_ty Eio.Resource.t,

     

       8
       8
       -
                    [`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t;

     

       7
       7
       +
         session : Requests.t;

     

       9
       8
        
       }

     

       10
       9
        
       

     

       11
       10
        
       let create ~sw env auth =

     
···

       85
       84
        
           Buffer.contents buf

     

       86
       85
        
         in

     

       87
       86
        
       

     

       88
       88
       -
         (* Parse JSON response using Ezjsonm *)

     

       87
       87
       +
         (* Parse JSON response using Jsont_bytesrw *)

     

       89
       88
        
         let json =

     

       90
       90
       -
           try

     

       91
       91
       -
             Ezjsonm.from_string body_str

     

       92
       92
       -
           with Ezjsonm.Parse_error (_, msg) ->

     

       93
       93
       -
             Log.err (fun m -> m "JSON parse error: %s" msg);

     

       94
       94
       -
             failwith ("JSON parse error: " ^ msg)

     

       89
       89
       +
           match Jsont_bytesrw.decode_string' Jsont.json body_str with

     

       90
       90
       +
           | Ok j -> j

     

       91
       91
       +
           | Error e ->

     

       92
       92
       +
               let msg = Jsont.Error.to_string e in

     

       93
       93
       +
               Log.err (fun m -> m "JSON parse error: %s" msg);

     

       94
       94
       +
               failwith ("JSON parse error: " ^ msg)

     

       95
       95
        
         in

     

       96
       96
        
       

     

       97
       97
        
         (* Check for Zulip error response *)

     

       98
       98
        
         match json with

     

       99
       99
       -
         | `O fields ->

     

       100
       100
       -
             (match List.assoc_opt "result" fields with

     

       101
       101
       -
              | Some (`String "error") ->

     

       102
       102
       -
                  let msg = match List.assoc_opt "msg" fields with

     

       103
       103
       -
                    | Some (`String s) -> s

     

       99
       99
       +
         | Jsont.Object (fields, _) ->

     

       100
       100
       +
             let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       101
       101
       +
             (match List.assoc_opt "result" assoc with

     

       102
       102
       +
              | Some (Jsont.String ("error", _)) ->

     

       103
       103
       +
                  let msg = match List.assoc_opt "msg" assoc with

     

       104
       104
       +
                    | Some (Jsont.String (s, _)) -> s

     

       104
       105
        
                    | _ -> "Unknown error"

     

       105
       106
        
                  in

     

       106
       106
       -
                  let code = match List.assoc_opt "code" fields with

     

       107
       107
       -
                    | Some (`String s) -> Zulip_types.error_code_of_string s

     

       107
       107
       +
                  let code = match List.assoc_opt "code" assoc with

     

       108
       108
       +
                    | Some (Jsont.String (s, _)) -> Zulip_types.error_code_of_string s

     

       108
       109
        
                    | _ -> Zulip_types.Other "unknown"

     

       109
       110
        
                  in

     

       110
       111
        
                  Log.warn (fun m -> m "API error: %s (code: %s)" msg

     
···

       126
       127
        
                        ~msg:"Invalid JSON response" ()))

     

       127
       128
        
       

     

       128
       129
        
       let pp fmt t =

     

       129
       129
       -
         Format.fprintf fmt "Client(server=%s)" (Auth.server_url t.auth)
     

       130
       130
       +
         Format.fprintf fmt "Client(server=%s)" (Auth.server_url t.auth)

+1 -1

stack/zulip/lib/zulip/lib/dune

···

       1
       1
        
       (library

     

       2
       2
        
        (public_name zulip)

     

       3
       3
        
        (name zulip)

     

       4
       4
       -
        (libraries eio requests ezjsonm uri base64 logs))
     

       4
       4
       +
        (libraries eio requests jsont jsont.bytesrw uri base64 logs))

+56

stack/zulip/lib/zulip/lib/encode.ml

···

       1
       1
       +
       (** Encoding utilities for Zulip API requests *)

     

       2
       2
       +
       

     

       3
       3
       +
       (** Convert a jsont-encoded value to JSON string *)

     

       4
       4
       +
       let to_json_string : 'a Jsont.t -> 'a -> string = fun codec value ->

     

       5
       5
       +
         match Jsont_bytesrw.encode_string' codec value with

     

       6
       6
       +
         | Ok s -> s

     

       7
       7
       +
         | Error e -> failwith ("JSON encoding error: " ^ Jsont.Error.to_string e)

     

       8
       8
       +
       

     

       9
       9
       +
       (** Convert a jsont-encoded value to form-urlencoded string *)

     

       10
       10
       +
       let to_form_urlencoded : 'a Jsont.t -> 'a -> string = fun codec value ->

     

       11
       11
       +
         (* First encode to JSON, then extract fields *)

     

       12
       12
       +
         let json_str = to_json_string codec value in

     

       13
       13
       +
         match Jsont_bytesrw.decode_string' Jsont.json json_str with

     

       14
       14
       +
         | Error e -> failwith ("JSON decode error: " ^ Jsont.Error.to_string e)

     

       15
       15
       +
         | Ok (Jsont.Object (fields, _)) ->

     

       16
       16
       +
             (* Convert object fields to form-urlencoded *)

     

       17
       17
       +
             let encode_value = function

     

       18
       18
       +
               | Jsont.String (s, _) -> Some (Uri.pct_encode ~component:`Query_value s)

     

       19
       19
       +
               | Jsont.Bool (b, _) -> Some (string_of_bool b)

     

       20
       20
       +
               | Jsont.Number (n, _) -> Some (string_of_float n)

     

       21
       21
       +
               | Jsont.Null _ -> None

     

       22
       22
       +
               | Jsont.Array (items, _) ->

     

       23
       23
       +
                   (* For arrays, encode as JSON array string *)

     

       24
       24
       +
                   let array_str = "[" ^ String.concat "," (List.filter_map (function

     

       25
       25
       +
                     | Jsont.String (s, _) -> Some ("\"" ^ String.escaped s ^ "\"")

     

       26
       26
       +
                     | Jsont.Number (n, _) -> Some (string_of_float n)

     

       27
       27
       +
                     | Jsont.Bool (b, _) -> Some (string_of_bool b)

     

       28
       28
       +
                     | _ -> None

     

       29
       29
       +
                   ) items) ^ "]" in

     

       30
       30
       +
                   Some array_str

     

       31
       31
       +
               | Jsont.Object _ -> None (* Skip nested objects *)

     

       32
       32
       +
             in

     

       33
       33
       +
       

     

       34
       34
       +
             let params = List.filter_map (fun ((key, _), value) ->

     

       35
       35
       +
               match encode_value value with

     

       36
       36
       +
               | Some encoded -> Some (key ^ "=" ^ encoded)

     

       37
       37
       +
               | None -> None

     

       38
       38
       +
             ) fields in

     

       39
       39
       +
       

     

       40
       40
       +
             String.concat "&" params

     

       41
       41
       +
         | Ok _ ->

     

       42
       42
       +
             failwith "Expected JSON object for form encoding"

     

       43
       43
       +
       

     

       44
       44
       +
       (** Parse JSON string using a jsont codec *)

     

       45
       45
       +
       let from_json_string : 'a Jsont.t -> string -> ('a, string) result = fun codec json_str ->

     

       46
       46
       +
         match Jsont_bytesrw.decode_string' codec json_str with

     

       47
       47
       +
         | Ok v -> Ok v

     

       48
       48
       +
         | Error e -> Error (Jsont.Error.to_string e)

     

       49
       49
       +
       

     

       50
       50
       +
       (** Parse a Jsont.json value using a codec *)

     

       51
       51
       +
       let from_json : 'a Jsont.t -> Jsont.json -> ('a, string) result = fun codec json ->

     

       52
       52
       +
         let json_str = match Jsont_bytesrw.encode_string' Jsont.json json with

     

       53
       53
       +
           | Ok s -> s

     

       54
       54
       +
           | Error e -> failwith ("Failed to re-encode json: " ^ Jsont.Error.to_string e)

     

       55
       55
       +
         in

     

       56
       56
       +
         from_json_string codec json_str

+21

stack/zulip/lib/zulip/lib/encode.mli

···

       1
       1
       +
       (** Encoding utilities for Zulip API requests *)

     

       2
       2
       +
       

     

       3
       3
       +
       (** Convert a value to JSON string using its jsont codec *)

     

       4
       4
       +
       val to_json_string : 'a Jsont.t -> 'a -> string

     

       5
       5
       +
       

     

       6
       6
       +
       (** Convert a value to application/x-www-form-urlencoded string using its jsont codec

     

       7
       7
       +
       

     

       8
       8
       +
           The codec should represent a JSON object. Fields will be converted to key=value pairs:

     

       9
       9
       +
           - Strings: URL-encoded

     

       10
       10
       +
           - Booleans: "true"/"false"

     

       11
       11
       +
           - Numbers: string representation

     

       12
       12
       +
           - Arrays: JSON array string "[...]"

     

       13
       13
       +
           - Null: omitted

     

       14
       14
       +
           - Nested objects: omitted *)

     

       15
       15
       +
       val to_form_urlencoded : 'a Jsont.t -> 'a -> string

     

       16
       16
       +
       

     

       17
       17
       +
       (** Parse JSON string using a jsont codec *)

     

       18
       18
       +
       val from_json_string : 'a Jsont.t -> string -> ('a, string) result

     

       19
       19
       +
       

     

       20
       20
       +
       (** Parse a Jsont.json value using a codec *)

     

       21
       21
       +
       val from_json : 'a Jsont.t -> Jsont.json -> ('a, string) result

+35 -24

stack/zulip/lib/zulip/lib/event.ml

···

       8
       8
        
       let type_ t = t.type_

     

       9
       9
        
       let data t = t.data

     

       10
       10
        
       

     

       11
       11
       -
       let of_json json = 

     

       11
       11
       +
       let pp fmt t = Format.fprintf fmt "Event{id=%d, type=%a}" t.id Event_type.pp t.type_

     

       12
       12
       +
       

     

       13
       13
       +
       (* Helper to extract fields from Jsont.json *)

     

       14
       14
       +
       let get_int_field json name =

     

       15
       15
       +
         match json with

     

       16
       16
       +
         | Jsont.Object (fields, _) ->

     

       17
       17
       +
             let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       18
       18
       +
             (match List.assoc_opt name assoc with

     

       19
       19
       +
              | Some (Jsont.Number (n, _)) -> int_of_float n

     

       20
       20
       +
              | _ -> Jsont.Error.msg Jsont.Meta.none

     

       21
       21
       +
                  (Format.sprintf "Field '%s' not found or not an int" name))

     

       22
       22
       +
         | _ -> Jsont.Error.msg Jsont.Meta.none "Expected JSON object"

     

       23
       23
       +
       

     

       24
       24
       +
       let get_string_field json name =

     

       25
       25
       +
         match json with

     

       26
       26
       +
         | Jsont.Object (fields, _) ->

     

       27
       27
       +
             let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       28
       28
       +
             (match List.assoc_opt name assoc with

     

       29
       29
       +
              | Some (Jsont.String (s, _)) -> s

     

       30
       30
       +
              | _ -> Jsont.Error.msg Jsont.Meta.none

     

       31
       31
       +
                  (Format.sprintf "Field '%s' not found or not a string" name))

     

       32
       32
       +
         | _ -> Jsont.Error.msg Jsont.Meta.none "Expected JSON object"

     

       33
       33
       +
       

     

       34
       34
       +
       (* Simple decoder that extracts id and type, keeping full JSON as data *)

     

       35
       35
       +
       let of_json_direct json =

     

       12
       36
        
         try

     

       13
       13
       -
           match json with

     

       14
       14
       -
           | `O fields ->

     

       15
       15
       -
               let get_int key = 

     

       16
       16
       -
                 match List.assoc key fields with 

     

       17
       17
       -
                 | `Float f -> int_of_float f

     

       18
       18
       -
                 | _ -> failwith ("Expected int for " ^ key) in

     

       19
       19
       -
               let get_string key = 

     

       20
       20
       -
                 match List.assoc key fields with 

     

       21
       21
       -
                 | `String s -> s 

     

       22
       22
       -
                 | _ -> failwith ("Expected string for " ^ key) in

     

       23
       23
       -
               let id = get_int "id" in

     

       24
       24
       -
               let type_str = get_string "type" in

     

       25
       25
       -
               let type_ = Event_type.of_string type_str in

     

       26
       26
       -
               (* The whole event is the data - store it all *)

     

       27
       27
       -
               let data = json in

     

       37
       37
       +
           let id = get_int_field json "id" in

     

       38
       38
       +
           let type_str = get_string_field json "type" in

     

       39
       39
       +
           let type_ = Event_type.of_string type_str in

     

       40
       40
       +
           Ok { id; type_; data = json }

     

       41
       41
       +
         with e ->

     

       42
       42
       +
           Error (Zulip_types.create_error ~code:(Other "json_parse_error")

     

       43
       43
       +
             ~msg:("Event JSON parsing failed: " ^ Printexc.to_string e) ())

     

       28
       44
        
       

     

       29
       29
       -
               Ok { id; type_; data }

     

       30
       30
       -
           | _ -> 

     

       31
       31
       -
               Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:"Event JSON must be an object" ())

     

       32
       32
       -
         with

     

       33
       33
       -
         | exn ->

     

       34
       34
       -
             Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:("Event JSON parsing failed: " ^ Printexc.to_string exn) ())

     

       35
       35
       -
       

     

       36
       36
       -
       let pp fmt t = Format.fprintf fmt "Event{id=%d, type=%a}" t.id Event_type.pp t.type_
     

       45
       45
       +
       (* Decode function *)

     

       46
       46
       +
       let of_json json =

     

       47
       47
       +
         of_json_direct json

+76 -42

stack/zulip/lib/zulip/lib/event_queue.ml

···

       6
       6
        
         id : string;

     

       7
       7
        
       }

     

       8
       8
        
       

     

       9
       9
       +
       (* Request/response codecs *)

     

       10
       10
       +
       module Register_request = struct

     

       11
       11
       +
         type t = { event_types : string list option }

     

       12
       12
       +
       

     

       13
       13
       +
         let codec =

     

       14
       14
       +
           Jsont.Object.(

     

       15
       15
       +
             map ~kind:"RegisterRequest" (fun event_types -> { event_types })

     

       16
       16
       +
             |> opt_mem "event_types" (Jsont.list Jsont.string) ~enc:(fun r -> r.event_types)

     

       17
       17
       +
             |> finish

     

       18
       18
       +
           )

     

       19
       19
       +
       end

     

       20
       20
       +
       

     

       21
       21
       +
       module Register_response = struct

     

       22
       22
       +
         type t = { queue_id : string }

     

       23
       23
       +
       

     

       24
       24
       +
         let codec =

     

       25
       25
       +
           Jsont.Object.(

     

       26
       26
       +
             map ~kind:"RegisterResponse" (fun queue_id -> { queue_id })

     

       27
       27
       +
             |> mem "queue_id" Jsont.string ~enc:(fun r -> r.queue_id)

     

       28
       28
       +
             |> finish

     

       29
       29
       +
           )

     

       30
       30
       +
       end

     

       31
       31
       +
       

     

       9
       32
        
       let register client ?event_types () =

     

       10
       10
       -
         let params = match event_types with

     

       11
       11
       -
           | None -> []

     

       12
       12
       -
           | Some types ->

     

       13
       13
       -
               let types_json = "[" ^

     

       14
       14
       -
                 String.concat "," (List.map (fun t -> "\"" ^ Event_type.to_string t ^ "\"") types) ^

     

       15
       15
       -
                 "]"

     

       16
       16
       -
               in

     

       17
       17
       -
               Log.debug (fun m -> m "Registering with event_types: %s" types_json);

     

       18
       18
       -
               [("event_types", types_json)]

     

       19
       19
       -
         in

     

       20
       20
       -
         match Client.request client ~method_:`POST ~path:"/api/v1/register" ~params () with

     

       21
       21
       -
         | Ok json -> 

     

       22
       22
       -
             (match json with

     

       23
       23
       -
              | `O fields ->

     

       24
       24
       -
                  (match List.assoc_opt "queue_id" fields with

     

       25
       25
       -
                   | Some (`String queue_id) -> Ok { id = queue_id }

     

       26
       26
       -
                   | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid register response: missing queue_id" ()))

     

       27
       27
       -
              | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Register response must be an object" ()))

     

       33
       33
       +
         let event_types_str = Option.map (List.map Event_type.to_string) event_types in

     

       34
       34
       +
         let req = Register_request.{ event_types = event_types_str } in

     

       35
       35
       +
         let body = Encode.to_form_urlencoded Register_request.codec req in

     

       36
       36
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       37
       37
       +
       

     

       38
       38
       +
         (match event_types_str with

     

       39
       39
       +
          | Some types -> Log.debug (fun m -> m "Registering with event_types: %s" (String.concat "," types))

     

       40
       40
       +
          | None -> ());

     

       41
       41
       +
       

     

       42
       42
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/register" ~body ~content_type () with

     

       43
       43
       +
         | Ok json ->

     

       44
       44
       +
             (match Encode.from_json Register_response.codec json with

     

       45
       45
       +
              | Ok response -> Ok { id = response.queue_id }

     

       46
       46
       +
              | Error msg -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))

     

       28
       47
        
         | Error err -> Error err

     

       29
       48
        
       

     

       30
       49
        
       let id t = t.id

     

       31
       50
        
       

     

       32
       32
       -
       let get_events t client ?last_event_id () = 

     

       33
       33
       -
         let params = [("queue_id", t.id)] @ 

     

       51
       51
       +
       (* Events response codec - events field is optional (may not be present) *)

     

       52
       52
       +
       module Events_response = struct

     

       53
       53
       +
         type t = { events : Event.t list }

     

       54
       54
       +
       

     

       55
       55
       +
         let codec =

     

       56
       56
       +
           (* Use keep_unknown pattern to handle the whole object and extract events manually *)

     

       57
       57
       +
           let make raw_json =

     

       58
       58
       +
             match raw_json with

     

       59
       59
       +
             | Jsont.Object (fields, _) ->

     

       60
       60
       +
                 let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       61
       61
       +
                 (match List.assoc_opt "events" assoc with

     

       62
       62
       +
                  | Some (Jsont.Array (items, _)) ->

     

       63
       63
       +
                      (* Parse each event, skipping failures *)

     

       64
       64
       +
                      let events = List.fold_left (fun acc item ->

     

       65
       65
       +
                        match Event.of_json item with

     

       66
       66
       +
                        | Ok event -> event :: acc

     

       67
       67
       +
                        | Error _ -> acc

     

       68
       68
       +
                      ) [] items |> List.rev in

     

       69
       69
       +
                      { events }

     

       70
       70
       +
                  | Some _ -> { events = [] }

     

       71
       71
       +
                  | None -> { events = [] })

     

       72
       72
       +
             | _ -> { events = [] }

     

       73
       73
       +
           in

     

       74
       74
       +
           Jsont.Object.map ~kind:"EventsResponse" make

     

       75
       75
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> Jsont.Object ([], Jsont.Meta.none))

     

       76
       76
       +
           |> Jsont.Object.finish

     

       77
       77
       +
       end

     

       78
       78
       +
       

     

       79
       79
       +
       let get_events t client ?last_event_id () =

     

       80
       80
       +
         let params = [("queue_id", t.id)] @

     

       34
       81
        
           (match last_event_id with

     

       35
       82
        
            | None -> []

     

       36
       83
        
            | Some event_id -> [("last_event_id", string_of_int event_id)]) in

     

       37
       84
        
         match Client.request client ~method_:`GET ~path:"/api/v1/events" ~params () with

     

       38
       38
       -
         | Ok json -> 

     

       39
       39
       -
             (match json with

     

       40
       40
       -
              | `O fields ->

     

       41
       41
       -
                  (match List.assoc_opt "events" fields with

     

       42
       42
       -
                   | Some (`A event_list) ->

     

       43
       43
       -
                       Log.debug (fun m -> m "Got %d raw events from API" (List.length event_list));

     

       44
       44
       -
                       let events = List.fold_left (fun acc event_json ->

     

       45
       45
       -
                         match Event.of_json event_json with

     

       46
       46
       -
                         | Ok event -> event :: acc

     

       47
       47
       -
                         | Error e ->

     

       48
       48
       -
                             Log.warn (fun m -> m "Failed to parse event: %s" (Zulip_types.error_message e));

     

       49
       49
       -
                             acc

     

       50
       50
       -
                       ) [] event_list in

     

       51
       51
       -
                       Ok (List.rev events)

     

       52
       52
       -
                   | Some _other ->

     

       53
       53
       -
                       Log.warn (fun m -> m "Events field is not an array");

     

       54
       54
       -
                       Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid events response format" ())

     

       55
       55
       -
                   | None ->

     

       56
       56
       -
                       Log.debug (fun m -> m "No events field in response");

     

       57
       57
       -
                       Ok [])

     

       58
       58
       -
              | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Events response must be an object" ()))

     

       85
       85
       +
         | Ok json ->

     

       86
       86
       +
             (match Encode.from_json Events_response.codec json with

     

       87
       87
       +
              | Ok response ->

     

       88
       88
       +
                  Log.debug (fun m -> m "Got %d events from API" (List.length response.events));

     

       89
       89
       +
                  Ok response.events

     

       90
       90
       +
              | Error msg ->

     

       91
       91
       +
                  Log.warn (fun m -> m "Failed to parse events response: %s" msg);

     

       92
       92
       +
                  Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))

     

       59
       93
        
         | Error err -> Error err

     

       60
       94
        
       

     

       61
       61
       -
       let delete t client = 

     

       95
       95
       +
       let delete t client =

     

       62
       96
        
         let params = [("queue_id", t.id)] in

     

       63
       97
        
         match Client.request client ~method_:`DELETE ~path:"/api/v1/events" ~params () with

     

       64
       98
        
         | Ok _json -> Ok ()

-206

stack/zulip/lib/zulip/lib/jsonu.ml

···

       1
       1
       -
       (** JSON utility functions for Zulip API *)

     

       2
       2
       -
       

     

       3
       3
       -
       type json = Zulip_types.json

     

       4
       4
       -
       

     

       5
       5
       -
       (** {1 Field extraction utilities} *)

     

       6
       6
       -
       

     

       7
       7
       -
       let get_string fields key =

     

       8
       8
       -
         match List.assoc_opt key fields with

     

       9
       9
       -
         | Some (`String s) -> Ok s

     

       10
       10
       -
         | Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a string" key) ())

     

       11
       11
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())

     

       12
       12
       -
       

     

       13
       13
       -
       let get_string_default fields key default =

     

       14
       14
       -
         match get_string fields key with

     

       15
       15
       -
         | Ok s -> s

     

       16
       16
       -
         | Error _ -> default

     

       17
       17
       -
       

     

       18
       18
       -
       let get_string_opt fields key =

     

       19
       19
       -
         match List.assoc_opt key fields with

     

       20
       20
       -
         | Some (`String s) -> Some s

     

       21
       21
       -
         | _ -> None

     

       22
       22
       -
       

     

       23
       23
       -
       let to_int_flex = function

     

       24
       24
       -
         | `Float f -> int_of_float f

     

       25
       25
       -
         | `String s -> (try int_of_string s with _ -> failwith "Invalid integer string")

     

       26
       26
       -
         | json -> failwith (Printf.sprintf "Expected int or float, got %s" (match json with

     

       27
       27
       -
           | `Null -> "null"

     

       28
       28
       -
           | `Bool _ -> "bool"

     

       29
       29
       -
           | `O _ -> "object"

     

       30
       30
       -
           | `A _ -> "array"

     

       31
       31
       -
           | _ -> "unknown"))

     

       32
       32
       -
       

     

       33
       33
       -
       let get_int fields key =

     

       34
       34
       -
         match List.assoc_opt key fields with

     

       35
       35
       -
         | Some json ->

     

       36
       36
       -
             (try Ok (to_int_flex json) with

     

       37
       37
       -
              | Failure msg -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg ()))

     

       38
       38
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())

     

       39
       39
       -
       

     

       40
       40
       -
       let get_int_default fields key default =

     

       41
       41
       -
         match get_int fields key with

     

       42
       42
       -
         | Ok i -> i

     

       43
       43
       -
         | Error _ -> default

     

       44
       44
       -
       

     

       45
       45
       -
       let get_int_opt fields key =

     

       46
       46
       -
         match List.assoc_opt key fields with

     

       47
       47
       -
         | Some json -> (try Some (to_int_flex json) with _ -> None)

     

       48
       48
       -
         | None -> None

     

       49
       49
       -
       

     

       50
       50
       -
       let get_float fields key =

     

       51
       51
       -
         match List.assoc_opt key fields with

     

       52
       52
       -
         | Some (`Float f) -> Ok f

     

       53
       53
       -
         | Some (`String s) ->

     

       54
       54
       -
             (try Ok (float_of_string s) with

     

       55
       55
       -
              | _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a valid float" key) ()))

     

       56
       56
       -
         | Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a float" key) ())

     

       57
       57
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())

     

       58
       58
       -
       

     

       59
       59
       -
       let get_float_default fields key default =

     

       60
       60
       -
         match get_float fields key with

     

       61
       61
       -
         | Ok f -> f

     

       62
       62
       -
         | Error _ -> default

     

       63
       63
       -
       

     

       64
       64
       -
       let get_bool fields key =

     

       65
       65
       -
         match List.assoc_opt key fields with

     

       66
       66
       -
         | Some (`Bool b) -> Ok b

     

       67
       67
       -
         | Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a boolean" key) ())

     

       68
       68
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())

     

       69
       69
       -
       

     

       70
       70
       -
       let get_bool_default fields key default =

     

       71
       71
       -
         match get_bool fields key with

     

       72
       72
       -
         | Ok b -> b

     

       73
       73
       -
         | Error _ -> default

     

       74
       74
       -
       

     

       75
       75
       -
       let get_bool_opt fields key =

     

       76
       76
       -
         match List.assoc_opt key fields with

     

       77
       77
       -
         | Some (`Bool b) -> Some b

     

       78
       78
       -
         | _ -> None

     

       79
       79
       -
       

     

       80
       80
       -
       let get_object fields key =

     

       81
       81
       -
         match List.assoc_opt key fields with

     

       82
       82
       -
         | Some (`O obj) -> Ok obj

     

       83
       83
       -
         | Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not an object" key) ())

     

       84
       84
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())

     

       85
       85
       -
       

     

       86
       86
       -
       let get_object_opt fields key =

     

       87
       87
       -
         match List.assoc_opt key fields with

     

       88
       88
       -
         | Some (`O obj) -> Some obj

     

       89
       89
       -
         | _ -> None

     

       90
       90
       -
       

     

       91
       91
       -
       let get_array fields key =

     

       92
       92
       -
         match List.assoc_opt key fields with

     

       93
       93
       -
         | Some (`A arr) -> Ok arr

     

       94
       94
       -
         | Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not an array" key) ())

     

       95
       95
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())

     

       96
       96
       -
       

     

       97
       97
       -
       let get_array_opt fields key =

     

       98
       98
       -
         match List.assoc_opt key fields with

     

       99
       99
       -
         | Some (`A arr) -> Some arr

     

       100
       100
       -
         | _ -> None

     

       101
       101
       -
       

     

       102
       102
       -
       (** {1 Type conversion utilities} *)

     

       103
       103
       -
       

     

       104
       104
       -
       let to_int_safe = function

     

       105
       105
       -
         | `Float f -> Some (int_of_float f)

     

       106
       106
       -
         | `String s -> (try Some (int_of_string s) with _ -> None)

     

       107
       107
       -
         | _ -> None

     

       108
       108
       -
       

     

       109
       109
       -
       let to_string_safe = function

     

       110
       110
       -
         | `String s -> Some s

     

       111
       111
       -
         | _ -> None

     

       112
       112
       -
       

     

       113
       113
       -
       let to_bool_safe = function

     

       114
       114
       -
         | `Bool b -> Some b

     

       115
       115
       -
         | _ -> None

     

       116
       116
       -
       

     

       117
       117
       -
       let to_float_safe = function

     

       118
       118
       -
         | `Float f -> Some f

     

       119
       119
       -
         | `String s -> (try Some (float_of_string s) with _ -> None)

     

       120
       120
       -
         | _ -> None

     

       121
       121
       -
       

     

       122
       122
       -
       (** {1 Object parsing utilities} *)

     

       123
       123
       -
       

     

       124
       124
       -
       let with_object context f = function

     

       125
       125
       -
         | `O fields -> f fields

     

       126
       126
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "%s: expected JSON object" context) ())

     

       127
       127
       -
       

     

       128
       128
       -
       let with_array context f json =

     

       129
       129
       -
         match json with

     

       130
       130
       -
         | `A items ->

     

       131
       131
       -
             let rec process acc = function

     

       132
       132
       -
               | [] -> Ok (List.rev acc)

     

       133
       133
       -
               | item :: rest ->

     

       134
       134
       -
                   match f item with

     

       135
       135
       -
                   | Ok v -> process (v :: acc) rest

     

       136
       136
       -
                   | Error e -> Error e

     

       137
       137
       -
             in

     

       138
       138
       -
             process [] items

     

       139
       139
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "%s: expected JSON array" context) ())

     

       140
       140
       -
       

     

       141
       141
       -
       (** {1 Construction utilities} *)

     

       142
       142
       -
       

     

       143
       143
       -
       let optional_field key encoder = function

     

       144
       144
       -
         | Some value -> Some (key, encoder value)

     

       145
       145
       -
         | None -> None

     

       146
       146
       -
       

     

       147
       147
       -
       let optional_fields fields =

     

       148
       148
       -
         List.filter_map (fun x -> x) fields

     

       149
       149
       -
       

     

       150
       150
       -
       let string_array strings =

     

       151
       151
       -
         `A (List.map (fun s -> `String s) strings)

     

       152
       152
       -
       

     

       153
       153
       -
       let int_array ints =

     

       154
       154
       -
         `A (List.map (fun i -> `Float (float_of_int i)) ints)

     

       155
       155
       -
       

     

       156
       156
       -
       (** {1 Error handling} *)

     

       157
       157
       -
       

     

       158
       158
       -
       let json_error msg =

     

       159
       159
       -
         Zulip_types.create_error ~code:(Other "json_error") ~msg ()

     

       160
       160
       -
       

     

       161
       161
       -
       let field_missing_error field =

     

       162
       162
       -
         Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Required field '%s' not found" field) ()

     

       163
       163
       -
       

     

       164
       164
       -
       let type_mismatch_error field expected =

     

       165
       165
       -
         Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' type mismatch: expected %s" field expected) ()

     

       166
       166
       -
       

     

       167
       167
       -
       let parse_with_error context f =

     

       168
       168
       -
         try f ()

     

       169
       169
       -
         with

     

       170
       170
       -
         | Failure msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:(Printf.sprintf "%s: %s" context msg) ())

     

       171
       171
       -
         | exn -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:(Printf.sprintf "%s: %s" context (Printexc.to_string exn)) ())

     

       172
       172
       -
       

     

       173
       173
       -
       

     

       174
       174
       -
       (** {1 Debugging utilities} *)

     

       175
       175
       -
       

     

       176
       176
       -
       let to_string_pretty json =

     

       177
       177
       -
         let rec aux indent = function

     

       178
       178
       -
           | `Null -> "null"

     

       179
       179
       -
           | `Bool b -> string_of_bool b

     

       180
       180
       -
           | `Float f ->

     

       181
       181
       -
               if float_of_int (int_of_float f) = f then

     

       182
       182
       -
                 string_of_int (int_of_float f)

     

       183
       183
       -
               else

     

       184
       184
       -
                 string_of_float f

     

       185
       185
       -
           | `String s -> Printf.sprintf "%S" s

     

       186
       186
       -
           | `A [] -> "[]"

     

       187
       187
       -
           | `A lst ->

     

       188
       188
       -
               let items = List.map (aux (indent ^ "  ")) lst in

     

       189
       189
       -
               Printf.sprintf "[\n%s%s\n%s]"

     

       190
       190
       -
                 (indent ^ "  ")

     

       191
       191
       -
                 (String.concat (",\n" ^ indent ^ "  ") items)

     

       192
       192
       -
                 indent

     

       193
       193
       -
           | `O [] -> "{}"

     

       194
       194
       -
           | `O fields ->

     

       195
       195
       -
               let items = List.map (fun (k, v) ->

     

       196
       196
       -
                 Printf.sprintf "%S: %s" k (aux (indent ^ "  ") v)

     

       197
       197
       -
               ) fields in

     

       198
       198
       -
               Printf.sprintf "{\n%s%s\n%s}"

     

       199
       199
       -
                 (indent ^ "  ")

     

       200
       200
       -
                 (String.concat (",\n" ^ indent ^ "  ") items)

     

       201
       201
       -
                 indent

     

       202
       202
       -
         in

     

       203
       203
       -
         aux "" json

     

       204
       204
       -
       

     

       205
       205
       -
       let pp fmt json =

     

       206
       206
       -
         Format.pp_print_string fmt (to_string_pretty json)

-117

stack/zulip/lib/zulip/lib/jsonu.mli

···

       1
       1
       -
       (** JSON utility functions for Zulip API

     

       2
       2
       -
       

     

       3
       3
       -
           This module provides common utilities for working with JSON in the Zulip API,

     

       4
       4
       -
           reducing boilerplate and providing consistent error handling. *)

     

       5
       5
       -
       

     

       6
       6
       -
       (** {1 Type definitions} *)

     

       7
       7
       -
       

     

       8
       8
       -
       type json = Zulip_types.json

     

       9
       9
       -
       

     

       10
       10
       -
       (** {1 Field extraction utilities} *)

     

       11
       11
       -
       

     

       12
       12
       -
       (** Extract a string field from a JSON object *)

     

       13
       13
       -
       val get_string : (string * json) list -> string -> (string, Zulip_types.zerror) result

     

       14
       14
       -
       

     

       15
       15
       -
       (** Extract a string field with a default value *)

     

       16
       16
       -
       val get_string_default : (string * json) list -> string -> string -> string

     

       17
       17
       -
       

     

       18
       18
       -
       (** Extract an optional string field *)

     

       19
       19
       -
       val get_string_opt : (string * json) list -> string -> string option

     

       20
       20
       -
       

     

       21
       21
       -
       (** Extract an integer field (handles both int and float representations) *)

     

       22
       22
       -
       val get_int : (string * json) list -> string -> (int, Zulip_types.zerror) result

     

       23
       23
       -
       

     

       24
       24
       -
       (** Extract an integer field with a default value *)

     

       25
       25
       -
       val get_int_default : (string * json) list -> string -> int -> int

     

       26
       26
       -
       

     

       27
       27
       -
       (** Extract an optional integer field *)

     

       28
       28
       -
       val get_int_opt : (string * json) list -> string -> int option

     

       29
       29
       -
       

     

       30
       30
       -
       (** Extract a float field *)

     

       31
       31
       -
       val get_float : (string * json) list -> string -> (float, Zulip_types.zerror) result

     

       32
       32
       -
       

     

       33
       33
       -
       (** Extract a float field with a default value *)

     

       34
       34
       -
       val get_float_default : (string * json) list -> string -> float -> float

     

       35
       35
       -
       

     

       36
       36
       -
       (** Extract a boolean field *)

     

       37
       37
       -
       val get_bool : (string * json) list -> string -> (bool, Zulip_types.zerror) result

     

       38
       38
       -
       

     

       39
       39
       -
       (** Extract a boolean field with a default value *)

     

       40
       40
       -
       val get_bool_default : (string * json) list -> string -> bool -> bool

     

       41
       41
       -
       

     

       42
       42
       -
       (** Extract an optional boolean field *)

     

       43
       43
       -
       val get_bool_opt : (string * json) list -> string -> bool option

     

       44
       44
       -
       

     

       45
       45
       -
       (** Extract a JSON object field *)

     

       46
       46
       -
       val get_object : (string * json) list -> string -> ((string * json) list, Zulip_types.zerror) result

     

       47
       47
       -
       

     

       48
       48
       -
       (** Extract an optional JSON object field *)

     

       49
       49
       -
       val get_object_opt : (string * json) list -> string -> (string * json) list option

     

       50
       50
       -
       

     

       51
       51
       -
       (** Extract a JSON array field *)

     

       52
       52
       -
       val get_array : (string * json) list -> string -> (json list, Zulip_types.zerror) result

     

       53
       53
       -
       

     

       54
       54
       -
       (** Extract an optional JSON array field *)

     

       55
       55
       -
       val get_array_opt : (string * json) list -> string -> json list option

     

       56
       56
       -
       

     

       57
       57
       -
       (** {1 Type conversion utilities} *)

     

       58
       58
       -
       

     

       59
       59
       -
       (** Convert JSON to int, handling both int and float representations *)

     

       60
       60
       -
       val to_int_flex : json -> int

     

       61
       61
       -
       

     

       62
       62
       -
       (** Safely convert JSON to int *)

     

       63
       63
       -
       val to_int_safe : json -> int option

     

       64
       64
       -
       

     

       65
       65
       -
       (** Convert JSON to string *)

     

       66
       66
       -
       val to_string_safe : json -> string option

     

       67
       67
       -
       

     

       68
       68
       -
       (** Convert JSON to bool *)

     

       69
       69
       -
       val to_bool_safe : json -> bool option

     

       70
       70
       -
       

     

       71
       71
       -
       (** Convert JSON to float *)

     

       72
       72
       -
       val to_float_safe : json -> float option

     

       73
       73
       -
       

     

       74
       74
       -
       (** {1 Object parsing utilities} *)

     

       75
       75
       -
       

     

       76
       76
       -
       (** Parse a JSON value as an object, applying a function to its fields *)

     

       77
       77
       -
       val with_object : string -> ((string * json) list -> ('a, Zulip_types.zerror) result) -> json -> ('a, Zulip_types.zerror) result

     

       78
       78
       -
       

     

       79
       79
       -
       (** Parse a JSON value as an array, applying a function to each element *)

     

       80
       80
       -
       val with_array : string -> (json -> ('a, Zulip_types.zerror) result) -> json -> ('a list, Zulip_types.zerror) result

     

       81
       81
       -
       

     

       82
       82
       -
       (** {1 Construction utilities} *)

     

       83
       83
       -
       

     

       84
       84
       -
       (** Create an optional field for JSON object construction *)

     

       85
       85
       -
       val optional_field : string -> ('a -> json) -> 'a option -> (string * json) option

     

       86
       86
       -
       

     

       87
       87
       -
       (** Create a list of optional fields, filtering out None values *)

     

       88
       88
       -
       val optional_fields : (string * json) option list -> (string * json) list

     

       89
       89
       -
       

     

       90
       90
       -
       (** Convert a string list to a JSON array *)

     

       91
       91
       -
       val string_array : string list -> json

     

       92
       92
       -
       

     

       93
       93
       -
       (** Convert an int list to a JSON array *)

     

       94
       94
       -
       val int_array : int list -> json

     

       95
       95
       -
       

     

       96
       96
       -
       (** {1 Error handling} *)

     

       97
       97
       -
       

     

       98
       98
       -
       (** Create a JSON parsing error *)

     

       99
       99
       -
       val json_error : string -> Zulip_types.zerror

     

       100
       100
       -
       

     

       101
       101
       -
       (** Create a field missing error *)

     

       102
       102
       -
       val field_missing_error : string -> Zulip_types.zerror

     

       103
       103
       -
       

     

       104
       104
       -
       (** Create a type mismatch error *)

     

       105
       105
       -
       val type_mismatch_error : string -> string -> Zulip_types.zerror

     

       106
       106
       -
       

     

       107
       107
       -
       (** Wrap a parsing function with exception handling *)

     

       108
       108
       -
       val parse_with_error : string -> (unit -> ('a, Zulip_types.zerror) result) -> ('a, Zulip_types.zerror) result

     

       109
       109
       -
       

     

       110
       110
       -
       

     

       111
       111
       -
       (** {1 Debugging utilities} *)

     

       112
       112
       -
       

     

       113
       113
       -
       (** Convert JSON to a pretty-printed string *)

     

       114
       114
       -
       val to_string_pretty : json -> string

     

       115
       115
       -
       

     

       116
       116
       -
       (** Print JSON value for debugging *)

     

       117
       117
       -
       val pp : Format.formatter -> json -> unit

-144

stack/zulip/lib/zulip/lib/jsonu_syntax.ml

···

       1
       1
       -
       (** Syntax module for monadic and applicative JSON parsing *)

     

       2
       2
       -
       

     

       3
       3
       -
       type json = Zulip_types.json

     

       4
       4
       -
       type 'a parser = json -> ('a, Zulip_types.zerror) result

     

       5
       5
       -
       

     

       6
       6
       -
       (** Monadic bind operator for sequential parsing with error handling *)

     

       7
       7
       -
       let ( let* ) = Result.bind

     

       8
       8
       -
       

     

       9
       9
       -
       (** Map operator for transforming successful results *)

     

       10
       10
       -
       let ( let+ ) x f = Result.map f x

     

       11
       11
       -
       

     

       12
       12
       -
       (** Applicative parallel composition *)

     

       13
       13
       -
       let ( and+ ) x y =

     

       14
       14
       -
         match x, y with

     

       15
       15
       -
         | Ok x, Ok y -> Ok (x, y)

     

       16
       16
       -
         | Error e, _ | _, Error e -> Error e

     

       17
       17
       -
       

     

       18
       18
       -
       (** Applicative parallel composition for 3 values *)

     

       19
       19
       -
       let ( and++ ) xy z =

     

       20
       20
       -
         match xy, z with

     

       21
       21
       -
         | Ok (x, y), Ok z -> Ok (x, y, z)

     

       22
       22
       -
         | Error e, _ | _, Error e -> Error e

     

       23
       23
       -
       

     

       24
       24
       -
       (** Applicative parallel composition for 4 values *)

     

       25
       25
       -
       let ( and+++ ) xyz w =

     

       26
       26
       -
         match xyz, w with

     

       27
       27
       -
         | Ok (x, y, z), Ok w -> Ok (x, y, z, w)

     

       28
       28
       -
         | Error e, _ | _, Error e -> Error e

     

       29
       29
       -
       

     

       30
       30
       -
       (** Applicative parallel composition for 5 values *)

     

       31
       31
       -
       let ( and++++ ) xyzw v =

     

       32
       32
       -
         match xyzw, v with

     

       33
       33
       -
         | Ok (x, y, z, w), Ok v -> Ok (x, y, z, w, v)

     

       34
       34
       -
         | Error e, _ | _, Error e -> Error e

     

       35
       35
       -
       

     

       36
       36
       -
       (** Alternative operator - try first, if fails try second *)

     

       37
       37
       -
       let ( <|> ) x y =

     

       38
       38
       -
         match x with

     

       39
       39
       -
         | Ok _ -> x

     

       40
       40
       -
         | Error _ -> y

     

       41
       41
       -
       

     

       42
       42
       -
       (** Provide a default value if parsing fails *)

     

       43
       43
       -
       let ( |? ) x default =

     

       44
       44
       -
         match x with

     

       45
       45
       -
         | Ok v -> v

     

       46
       46
       -
         | Error _ -> default

     

       47
       47
       -
       

     

       48
       48
       -
       (** Convert option to result with error message *)

     

       49
       49
       -
       let required name = function

     

       50
       50
       -
         | Some v -> Ok v

     

       51
       51
       -
         | None -> Error (Zulip_types.create_error ~code:(Other "missing_field") ~msg:(Printf.sprintf "Required field '%s' not found" name) ())

     

       52
       52
       -
       

     

       53
       53
       -
       (** Convert option to result with default *)

     

       54
       54
       -
       let default v = function

     

       55
       55
       -
         | Some x -> x

     

       56
       56
       -
         | None -> v

     

       57
       57
       -
       

     

       58
       58
       -
       (** Lift a pure value into parser context *)

     

       59
       59
       -
       let pure x = Ok x

     

       60
       60
       -
       

     

       61
       61
       -
       (** Fail with an error message *)

     

       62
       62
       -
       let fail msg = Error (Zulip_types.create_error ~code:(Other "parse_error") ~msg ())

     

       63
       63
       -
       

     

       64
       64
       -
       (** Map over a list with error handling *)

     

       65
       65
       -
       let traverse f lst =

     

       66
       66
       -
         let rec go acc = function

     

       67
       67
       -
           | [] -> Ok (List.rev acc)

     

       68
       68
       -
           | x :: xs ->

     

       69
       69
       -
               let* v = f x in

     

       70
       70
       -
               go (v :: acc) xs

     

       71
       71
       -
         in

     

       72
       72
       -
         go [] lst

     

       73
       73
       -
       

     

       74
       74
       -
       (** Filter and map over a list, dropping errors *)

     

       75
       75
       -
       let filter_map f lst =

     

       76
       76
       -
         List.filter_map (fun x ->

     

       77
       77
       -
           match f x with

     

       78
       78
       -
           | Ok v -> Some v

     

       79
       79
       -
           | Error _ -> None

     

       80
       80
       -
         ) lst

     

       81
       81
       -
       

     

       82
       82
       -
       (** Parse a field with a custom parser *)

     

       83
       83
       -
       let field fields key parser =

     

       84
       84
       -
         match List.assoc_opt key fields with

     

       85
       85
       -
         | Some json -> parser json

     

       86
       86
       -
         | None -> Error (Jsonu.field_missing_error key)

     

       87
       87
       -
       

     

       88
       88
       -
       (** Parse an optional field with a custom parser *)

     

       89
       89
       -
       let field_opt fields key parser =

     

       90
       90
       -
         match List.assoc_opt key fields with

     

       91
       91
       -
         | Some json ->

     

       92
       92
       -
             (match parser json with

     

       93
       93
       -
              | Ok v -> Ok (Some v)

     

       94
       94
       -
              | Error _ -> Ok None)

     

       95
       95
       -
         | None -> Ok None

     

       96
       96
       -
       

     

       97
       97
       -
       (** Parse a field with a default value if missing or fails *)

     

       98
       98
       -
       let field_or fields key parser default =

     

       99
       99
       -
         match List.assoc_opt key fields with

     

       100
       100
       -
         | Some json ->

     

       101
       101
       -
             (match parser json with

     

       102
       102
       -
              | Ok v -> Ok v

     

       103
       103
       -
              | Error _ -> Ok default)

     

       104
       104
       -
         | None -> Ok default

     

       105
       105
       -
       

     

       106
       106
       -
       (** Common parsers *)

     

       107
       107
       -
       let string = function

     

       108
       108
       -
         | `String s -> Ok s

     

       109
       109
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected string" ())

     

       110
       110
       -
       

     

       111
       111
       -
       let int = function

     

       112
       112
       -
         | `Float f -> Ok (int_of_float f)

     

       113
       113
       -
         | `String s ->

     

       114
       114
       -
             (try Ok (int_of_string s)

     

       115
       115
       -
              with _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected integer" ()))

     

       116
       116
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected integer" ())

     

       117
       117
       -
       

     

       118
       118
       -
       let float = function

     

       119
       119
       -
         | `Float f -> Ok f

     

       120
       120
       -
         | `String s ->

     

       121
       121
       -
             (try Ok (float_of_string s)

     

       122
       122
       -
              with _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected float" ()))

     

       123
       123
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected float" ())

     

       124
       124
       -
       

     

       125
       125
       -
       let bool = function

     

       126
       126
       -
         | `Bool b -> Ok b

     

       127
       127
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected boolean" ())

     

       128
       128
       -
       

     

       129
       129
       -
       let array parser = function

     

       130
       130
       -
         | `A items -> traverse parser items

     

       131
       131
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected array" ())

     

       132
       132
       -
       

     

       133
       133
       -
       let object_ = function

     

       134
       134
       -
         | `O fields -> Ok fields

     

       135
       135
       -
         | _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected object" ())

     

       136
       136
       -
       

     

       137
       137
       -
       (** Run a parser on JSON *)

     

       138
       138
       -
       let parse parser json = parser json

     

       139
       139
       -
       

     

       140
       140
       -
       (** Run a parser with error context *)

     

       141
       141
       -
       let with_context ctx parser json =

     

       142
       142
       -
         match parser json with

     

       143
       143
       -
         | Ok v -> Ok v

     

       144
       144
       -
         | Error e -> Error (Zulip_types.create_error ~code:(Zulip_types.error_code e) ~msg:(Printf.sprintf "%s: %s" ctx (Zulip_types.error_message e)) ())

-96

stack/zulip/lib/zulip/lib/jsonu_syntax.mli

···

       1
       1
       -
       (** Syntax module for monadic and applicative JSON parsing

     

       2
       2
       -
       

     

       3
       3
       -
           This module provides binding operators and combinators to make JSON parsing

     

       4
       4
       -
           more ergonomic and composable. It enables code like:

     

       5
       5
       -
       

     

       6
       6
       -
           {[

     

       7
       7
       -
             let parse_user json =

     

       8
       8
       -
               with_object "user" @@ fun fields ->

     

       9
       9
       -
               let+ user_id = field fields "user_id" int

     

       10
       10
       -
               and+ email = field fields "email" string

     

       11
       11
       -
               and+ full_name = field fields "full_name" string in

     

       12
       12
       -
               { user_id; email; full_name }

     

       13
       13
       -
           ]}

     

       14
       14
       -
       *)

     

       15
       15
       -
       

     

       16
       16
       -
       type json = Zulip_types.json

     

       17
       17
       -
       type 'a parser = json -> ('a, Zulip_types.zerror) result

     

       18
       18
       -
       

     

       19
       19
       -
       (** {1 Binding Operators} *)

     

       20
       20
       -
       

     

       21
       21
       -
       (** Monadic bind operator for sequential parsing with error handling *)

     

       22
       22
       -
       val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result

     

       23
       23
       -
       

     

       24
       24
       -
       (** Map operator for transforming successful results *)

     

       25
       25
       -
       val ( let+ ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result

     

       26
       26
       -
       

     

       27
       27
       -
       (** Applicative parallel composition for independent field extraction *)

     

       28
       28
       -
       val ( and+ ) : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e) result

     

       29
       29
       -
       val ( and++ ) : ('a * 'b, 'e) result -> ('c, 'e) result -> ('a * 'b * 'c, 'e) result

     

       30
       30
       -
       val ( and+++ ) : ('a * 'b * 'c, 'e) result -> ('d, 'e) result -> ('a * 'b * 'c * 'd, 'e) result

     

       31
       31
       -
       val ( and++++ ) : ('a * 'b * 'c * 'd, 'e) result -> ('f, 'e) result -> ('a * 'b * 'c * 'd * 'f, 'e) result

     

       32
       32
       -
       

     

       33
       33
       -
       (** {1 Alternative and Default Operators} *)

     

       34
       34
       -
       

     

       35
       35
       -
       (** Alternative operator - try first parser, if fails try second *)

     

       36
       36
       -
       val ( <|> ) : ('a, 'e) result -> ('a, 'e) result -> ('a, 'e) result

     

       37
       37
       -
       

     

       38
       38
       -
       (** Provide a default value if parsing fails *)

     

       39
       39
       -
       val ( |? ) : ('a, 'e) result -> 'a -> 'a

     

       40
       40
       -
       

     

       41
       41
       -
       (** {1 Field Extraction} *)

     

       42
       42
       -
       

     

       43
       43
       -
       (** Parse a required field with a custom parser *)

     

       44
       44
       -
       val field : (string * json) list -> string -> 'a parser -> ('a, Zulip_types.zerror) result

     

       45
       45
       -
       

     

       46
       46
       -
       (** Parse an optional field with a custom parser *)

     

       47
       47
       -
       val field_opt : (string * json) list -> string -> 'a parser -> ('a option, Zulip_types.zerror) result

     

       48
       48
       -
       

     

       49
       49
       -
       (** Parse a field with a default value if missing or fails *)

     

       50
       50
       -
       val field_or : (string * json) list -> string -> 'a parser -> 'a -> ('a, Zulip_types.zerror) result

     

       51
       51
       -
       

     

       52
       52
       -
       (** {1 Basic Parsers} *)

     

       53
       53
       -
       

     

       54
       54
       -
       (** Parse a JSON string *)

     

       55
       55
       -
       val string : string parser

     

       56
       56
       -
       

     

       57
       57
       -
       (** Parse a JSON number as integer (handles both int and float) *)

     

       58
       58
       -
       val int : int parser

     

       59
       59
       -
       

     

       60
       60
       -
       (** Parse a JSON number as float *)

     

       61
       61
       -
       val float : float parser

     

       62
       62
       -
       

     

       63
       63
       -
       (** Parse a JSON boolean *)

     

       64
       64
       -
       val bool : bool parser

     

       65
       65
       -
       

     

       66
       66
       -
       (** Parse a JSON array with a parser for elements *)

     

       67
       67
       -
       val array : 'a parser -> 'a list parser

     

       68
       68
       -
       

     

       69
       69
       -
       (** Parse a JSON object to get its fields *)

     

       70
       70
       -
       val object_ : json -> ((string * json) list, Zulip_types.zerror) result

     

       71
       71
       -
       

     

       72
       72
       -
       (** {1 Utility Functions} *)

     

       73
       73
       -
       

     

       74
       74
       -
       (** Convert option to result with error message *)

     

       75
       75
       -
       val required : string -> 'a option -> ('a, Zulip_types.zerror) result

     

       76
       76
       -
       

     

       77
       77
       -
       (** Get value from option with default *)

     

       78
       78
       -
       val default : 'a -> 'a option -> 'a

     

       79
       79
       -
       

     

       80
       80
       -
       (** Lift a pure value into parser context *)

     

       81
       81
       -
       val pure : 'a -> ('a, 'e) result

     

       82
       82
       -
       

     

       83
       83
       -
       (** Fail with an error message *)

     

       84
       84
       -
       val fail : string -> ('a, Zulip_types.zerror) result

     

       85
       85
       -
       

     

       86
       86
       -
       (** Map over a list with error handling *)

     

       87
       87
       -
       val traverse : ('a -> ('b, Zulip_types.zerror) result) -> 'a list -> ('b list, Zulip_types.zerror) result

     

       88
       88
       -
       

     

       89
       89
       -
       (** Filter and map over a list, dropping errors *)

     

       90
       90
       -
       val filter_map : ('a -> ('b, Zulip_types.zerror) result) -> 'a list -> 'b list

     

       91
       91
       -
       

     

       92
       92
       -
       (** Run a parser on JSON *)

     

       93
       93
       -
       val parse : 'a parser -> json -> ('a, Zulip_types.zerror) result

     

       94
       94
       -
       

     

       95
       95
       -
       (** Run a parser with error context *)

     

       96
       96
       -
       val with_context : string -> 'a parser -> 'a parser

+35 -21

stack/zulip/lib/zulip/lib/message.ml

···

       19
       19
        
       let local_id t = t.local_id

     

       20
       20
        
       let read_by_sender t = t.read_by_sender

     

       21
       21
        
       

     

       22
       22
       -
       let to_json t =

     

       23
       23
       -
         let base_fields = [

     

       24
       24
       -
           ("type", `String (Message_type.to_string t.type_));

     

       25
       25
       -
           ("to", `A (List.map (fun s -> `String s) t.to_));

     

       26
       26
       -
           ("content", `String t.content);

     

       27
       27
       -
           ("read_by_sender", `Bool t.read_by_sender);

     

       28
       28
       -
         ] in

     

       29
       29
       -
         let with_topic = match t.topic with

     

       30
       30
       -
           | Some topic -> ("topic", `String topic) :: base_fields

     

       31
       31
       -
           | None -> base_fields in

     

       32
       32
       -
         let with_queue_id = match t.queue_id with

     

       33
       33
       -
           | Some qid -> ("queue_id", `String qid) :: with_topic

     

       34
       34
       -
           | None -> with_topic in

     

       35
       35
       -
         let with_local_id = match t.local_id with

     

       36
       36
       -
           | Some lid -> ("local_id", `String lid) :: with_queue_id

     

       37
       37
       -
           | None -> with_queue_id in

     

       38
       38
       -
         `O with_local_id

     

       22
       22
       +
       let pp fmt t = Format.fprintf fmt "Message{type=%a, to=%s, content=%s}"

     

       23
       23
       +
         Message_type.pp t.type_

     

       24
       24
       +
         (String.concat "," t.to_)

     

       25
       25
       +
         t.content

     

       39
       26
        
       

     

       40
       40
       -
       let pp fmt t = Format.fprintf fmt "Message{type=%a, to=%s, content=%s}" 

     

       41
       41
       -
         Message_type.pp t.type_ 

     

       42
       42
       -
         (String.concat "," t.to_) 

     

       43
       43
       -
         t.content
     

       27
       27
       +
       (* Jsont codec for Message_type.t *)

     

       28
       28
       +
       let message_type_jsont =

     

       29
       29
       +
         let of_string s = match Message_type.of_string s with

     

       30
       30
       +
           | Some t -> Ok t

     

       31
       31
       +
           | None -> Error (Format.sprintf "Invalid message type: %s" s)

     

       32
       32
       +
         in

     

       33
       33
       +
         Jsont.of_of_string ~kind:"Message_type.t" of_string ~enc:Message_type.to_string

     

       34
       34
       +
       

     

       35
       35
       +
       (* Jsont codec for the message *)

     

       36
       36
       +
       let jsont =

     

       37
       37
       +
         let kind = "Message" in

     

       38
       38
       +
         let doc = "A Zulip message to be sent" in

     

       39
       39
       +
         let make type_ to_ content topic queue_id local_id read_by_sender =

     

       40
       40
       +
           { type_; to_; content; topic; queue_id; local_id; read_by_sender }

     

       41
       41
       +
         in

     

       42
       42
       +
         Jsont.Object.map ~kind ~doc make

     

       43
       43
       +
         |> Jsont.Object.mem "type" message_type_jsont ~enc:type_

     

       44
       44
       +
         |> Jsont.Object.mem "to" (Jsont.list Jsont.string) ~enc:to_

     

       45
       45
       +
         |> Jsont.Object.mem "content" Jsont.string ~enc:content

     

       46
       46
       +
         |> Jsont.Object.opt_mem "topic" Jsont.string ~enc:topic

     

       47
       47
       +
         |> Jsont.Object.opt_mem "queue_id" Jsont.string ~enc:queue_id

     

       48
       48
       +
         |> Jsont.Object.opt_mem "local_id" Jsont.string ~enc:local_id

     

       49
       49
       +
         |> Jsont.Object.mem "read_by_sender" Jsont.bool ~enc:read_by_sender

     

       50
       50
       +
         |> Jsont.Object.finish

     

       51
       51
       +
       

     

       52
       52
       +
       (* Encoding functions *)

     

       53
       53
       +
       let to_json_string t =

     

       54
       54
       +
         Encode.to_json_string jsont t

     

       55
       55
       +
       

     

       56
       56
       +
       let to_form_urlencoded t =

     

       57
       57
       +
         Encode.to_form_urlencoded jsont t

+18 -9

stack/zulip/lib/zulip/lib/message.mli

···

       1
       1
        
       type t

     

       2
       2
        
       

     

       3
       3
       -
       val create : 

     

       4
       4
       -
         type_:Message_type.t -> 

     

       5
       5
       -
         to_:string list -> 

     

       6
       6
       -
         content:string -> 

     

       7
       7
       -
         ?topic:string -> 

     

       8
       8
       -
         ?queue_id:string -> 

     

       9
       9
       -
         ?local_id:string -> 

     

       10
       10
       -
         ?read_by_sender:bool -> 

     

       3
       3
       +
       val create :

     

       4
       4
       +
         type_:Message_type.t ->

     

       5
       5
       +
         to_:string list ->

     

       6
       6
       +
         content:string ->

     

       7
       7
       +
         ?topic:string ->

     

       8
       8
       +
         ?queue_id:string ->

     

       9
       9
       +
         ?local_id:string ->

     

       10
       10
       +
         ?read_by_sender:bool ->

     

       11
       11
        
         unit -> t

     

       12
       12
        
       

     

       13
       13
        
       val type_ : t -> Message_type.t

     
···

       17
       17
        
       val queue_id : t -> string option

     

       18
       18
        
       val local_id : t -> string option

     

       19
       19
        
       val read_by_sender : t -> bool

     

       20
       20
       -
       val to_json : t -> Zulip_types.json

     

       20
       20
       +
       

     

       21
       21
       +
       (** Jsont codec for the message type *)

     

       22
       22
       +
       val jsont : t Jsont.t

     

       23
       23
       +
       

     

       24
       24
       +
       (** Encode to JSON string *)

     

       25
       25
       +
       val to_json_string : t -> string

     

       26
       26
       +
       

     

       27
       27
       +
       (** Encode to form-urlencoded string *)

     

       28
       28
       +
       val to_form_urlencoded : t -> string

     

       29
       29
       +
       

     

       21
       30
        
       val pp : Format.formatter -> t -> unit

+20 -8

stack/zulip/lib/zulip/lib/message_response.ml

···

       6
       6
        
       let id t = t.id

     

       7
       7
        
       let automatic_new_visibility_policy t = t.automatic_new_visibility_policy

     

       8
       8
        
       

     

       9
       9
       +
       let pp fmt t = Format.fprintf fmt "MessageResponse{id=%d}" t.id

     

       10
       10
       +
       

     

       11
       11
       +
       (* Jsont codec for message response *)

     

       12
       12
       +
       let jsont =

     

       13
       13
       +
         let kind = "MessageResponse" in

     

       14
       14
       +
         let doc = "A Zulip message response" in

     

       15
       15
       +
         let make id automatic_new_visibility_policy =

     

       16
       16
       +
           { id; automatic_new_visibility_policy }

     

       17
       17
       +
         in

     

       18
       18
       +
         Jsont.Object.map ~kind ~doc make

     

       19
       19
       +
         |> Jsont.Object.mem "id" Jsont.int ~enc:id

     

       20
       20
       +
         |> Jsont.Object.opt_mem "automatic_new_visibility_policy" Jsont.string ~enc:automatic_new_visibility_policy

     

       21
       21
       +
         |> Jsont.Object.finish

     

       22
       22
       +
       

     

       23
       23
       +
       (* Decode and encode functions using Encode module *)

     

       9
       24
        
       let of_json json =

     

       10
       10
       -
         Jsonu.with_object "message_response" (fun fields ->

     

       11
       11
       -
           match Jsonu.get_int fields "id" with

     

       12
       12
       -
           | Error e -> Error e

     

       13
       13
       -
           | Ok id ->

     

       14
       14
       -
               let automatic_new_visibility_policy = Jsonu.get_string_opt fields "automatic_new_visibility_policy" in

     

       15
       15
       -
               Ok { id; automatic_new_visibility_policy }

     

       16
       16
       -
         ) json

     

       25
       25
       +
         match Encode.from_json jsont json with

     

       26
       26
       +
         | Ok v -> Ok v

     

       27
       27
       +
         | Error msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg ())

     

       17
       28
        
       

     

       18
       18
       -
       let pp fmt t = Format.fprintf fmt "MessageResponse{id=%d}" t.id
     

       29
       29
       +
       let to_json_string t =

     

       30
       30
       +
         Encode.to_json_string jsont t

stack/zulip/lib/zulip/lib/message_response.mli

···

       2
       2
        
       

     

       3
       3
        
       val id : t -> int

     

       4
       4
        
       val automatic_new_visibility_policy : t -> string option

     

       5
       5
       +
       

     

       6
       6
       +
       (** Jsont codec for message response *)

     

       7
       7
       +
       val jsont : t Jsont.t

     

       8
       8
       +
       

     

       5
       9
        
       val of_json : Zulip_types.json -> (t, Zulip_types.zerror) result

     

       10
       10
       +
       val to_json_string : t -> string

     

       6
       11
        
       val pp : Format.formatter -> t -> unit

+15 -62

stack/zulip/lib/zulip/lib/messages.ml

···

       1
       1
        
       let send client message =

     

       2
       2
       -
         let json = Message.to_json message in

     

       3
       3
       -
         let params = match json with

     

       4
       4
       -
           | `O fields ->

     

       5
       5
       -
               List.fold_left (fun acc (key, value) ->

     

       6
       6
       -
                 let str_value = match value with

     

       7
       7
       -
                   | `String s -> s

     

       8
       8
       -
                   | `Bool true -> "true"

     

       9
       9
       -
                   | `Bool false -> "false"

     

       10
       10
       -
                   | `A arr -> String.concat "," (List.map (function `String s -> s | _ -> "") arr)

     

       11
       11
       -
                   | _ -> ""

     

       12
       12
       -
                 in

     

       13
       13
       -
                 (key, str_value) :: acc

     

       14
       14
       -
               ) [] fields

     

       15
       15
       -
           | _ -> [] in

     

       16
       16
       -
         

     

       17
       17
       -
         match Client.request client ~method_:`POST ~path:"/api/v1/messages" ~params () with

     

       2
       2
       +
         (* Use form-urlencoded encoding for the message *)

     

       3
       3
       +
         let body = Message.to_form_urlencoded message in

     

       4
       4
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       5
       5
       +
       

     

       6
       6
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/messages" ~body ~content_type () with

     

       18
       7
        
         | Ok response -> Message_response.of_json response

     

       19
       8
        
         | Error err -> Error err

     

       20
       9
        
       

     

       21
       10
        
       let edit client ~message_id ?content ?topic () =

     

       22
       22
       -
         let params = 

     

       11
       11
       +
         let params =

     

       23
       12
        
           (("message_id", string_of_int message_id) ::

     

       24
       13
        
            (match content with Some c -> [("content", c)] | None -> []) @

     

       25
       14
        
            (match topic with Some t -> [("topic", t)] | None -> [])) in

     

       26
       26
       -
         

     

       15
       15
       +
       

     

       27
       16
        
         match Client.request client ~method_:`PATCH ~path:("/api/v1/messages/" ^ string_of_int message_id) ~params () with

     

       28
       17
        
         | Ok _ -> Ok ()

     

       29
       18
        
         | Error err -> Error err

     
···

       48
       37
        
       let add_reaction client ~message_id ~emoji_name =

     

       49
       38
        
         let params = [

     

       50
       39
        
           ("emoji_name", emoji_name);

     

       51
       51
       -
           ("reaction_type", "unicode_emoji");

     

       52
       40
        
         ] in

     

       53
       41
        
         match Client.request client ~method_:`POST

     

       54
       54
       -
           ~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions")

     

       55
       55
       -
           ~params () with

     

       56
       56
       -
         | Ok _ -> Ok ()

     

       42
       42
       +
                 ~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions") ~params () with

     

       43
       43
       +
         | Ok _json -> Ok ()

     

       57
       44
        
         | Error err -> Error err

     

       58
       45
        
       

     

       59
       46
        
       let remove_reaction client ~message_id ~emoji_name =

     

       60
       47
        
         let params = [

     

       61
       48
        
           ("emoji_name", emoji_name);

     

       62
       62
       -
           ("reaction_type", "unicode_emoji");

     

       63
       49
        
         ] in

     

       64
       50
        
         match Client.request client ~method_:`DELETE

     

       65
       65
       -
           ~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions")

     

       66
       66
       -
           ~params () with

     

       67
       67
       -
         | Ok _ -> Ok ()

     

       51
       51
       +
                 ~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions") ~params () with

     

       52
       52
       +
         | Ok _json -> Ok ()

     

       68
       53
        
         | Error err -> Error err

     

       69
       54
        
       

     

       70
       70
       -
       let upload_file client ~filename =

     

       71
       71
       -
         (* Read file contents *)

     

       72
       72
       -
         let ic = open_in_bin filename in

     

       73
       73
       -
         let len = in_channel_length ic in

     

       74
       74
       -
         let content = really_input_string ic len in

     

       75
       75
       -
         close_in ic;

     

       76
       76
       -
       

     

       77
       77
       -
         (* Extract just the filename from the path *)

     

       78
       78
       -
         let basename = Filename.basename filename in

     

       79
       79
       -
       

     

       80
       80
       -
         (* Create multipart form data boundary *)

     

       81
       81
       -
         let boundary = "----OCamlZulipBoundary" ^ string_of_float (Unix.gettimeofday ()) in

     

       82
       82
       -
       

     

       83
       83
       -
         (* Build multipart body *)

     

       84
       84
       -
         let body = Buffer.create (len + 1024) in

     

       85
       85
       -
         Buffer.add_string body ("--" ^ boundary ^ "\r\n");

     

       86
       86
       -
         Buffer.add_string body ("Content-Disposition: form-data; name=\"file\"; filename=\"" ^ basename ^ "\"\r\n");

     

       87
       87
       -
         Buffer.add_string body "Content-Type: application/octet-stream\r\n";

     

       88
       88
       -
         Buffer.add_string body "\r\n";

     

       89
       89
       -
         Buffer.add_string body content;

     

       90
       90
       -
         Buffer.add_string body ("\r\n--" ^ boundary ^ "--\r\n");

     

       91
       91
       -
       

     

       92
       92
       -
         let body_str = Buffer.contents body in

     

       93
       93
       -
         let content_type = "multipart/form-data; boundary=" ^ boundary in

     

       94
       94
       -
       

     

       95
       95
       -
         match Client.request client ~method_:`POST ~path:"/api/v1/user_uploads"

     

       96
       96
       -
           ~body:body_str ~content_type () with

     

       97
       97
       -
         | Ok json ->

     

       98
       98
       -
             (* Parse response to extract URI *)

     

       99
       99
       -
             (match json with

     

       100
       100
       -
              | `O fields ->

     

       101
       101
       -
                  (match Jsonu.get_string fields "uri" with

     

       102
       102
       -
                   | Ok uri -> Ok uri

     

       103
       103
       -
                   | Error e -> Error e)

     

       104
       104
       -
              | _ -> Error (Zulip_types.create_error ~code:(Zulip_types.Other "upload_error") ~msg:"Failed to parse upload response" ()))

     

       105
       105
       -
         | Error err -> Error err
     

       55
       55
       +
       let upload_file _client ~filename:_ =

     

       56
       56
       +
         (* TODO: Implement file upload using multipart/form-data *)

     

       57
       57
       +
         Error (Zulip_types.create_error ~code:(Other "not_implemented")

     

       58
       58
       +
           ~msg:"File upload not yet implemented" ())

+25 -18

stack/zulip/lib/zulip/lib/user.ml

···

       15
       15
        
       let is_admin t = t.is_admin

     

       16
       16
        
       let is_bot t = t.is_bot

     

       17
       17
        
       

     

       18
       18
       -
       let to_json t = 

     

       19
       19
       -
         `O [

     

       20
       20
       -
           ("email", `String t.email);

     

       21
       21
       -
           ("full_name", `String t.full_name);

     

       22
       22
       -
           ("is_active", `Bool t.is_active);

     

       23
       23
       -
           ("is_admin", `Bool t.is_admin);

     

       24
       24
       -
           ("is_bot", `Bool t.is_bot);

     

       25
       25
       -
         ]

     

       18
       18
       +
       let pp fmt t = Format.fprintf fmt "User{email=%s, full_name=%s}" t.email t.full_name

     

       19
       19
       +
       

     

       20
       20
       +
       (* Jsont codec for user *)

     

       21
       21
       +
       let jsont =

     

       22
       22
       +
         let kind = "User" in

     

       23
       23
       +
         let doc = "A Zulip user" in

     

       24
       24
       +
         let make email full_name is_active is_admin is_bot =

     

       25
       25
       +
           { email; full_name; is_active; is_admin; is_bot }

     

       26
       26
       +
         in

     

       27
       27
       +
         Jsont.Object.map ~kind ~doc make

     

       28
       28
       +
         |> Jsont.Object.mem "email" Jsont.string ~enc:email

     

       29
       29
       +
         |> Jsont.Object.mem "full_name" Jsont.string ~enc:full_name

     

       30
       30
       +
         |> Jsont.Object.mem "is_active" Jsont.bool ~enc:is_active

     

       31
       31
       +
         |> Jsont.Object.mem "is_admin" Jsont.bool ~enc:is_admin

     

       32
       32
       +
         |> Jsont.Object.mem "is_bot" Jsont.bool ~enc:is_bot

     

       33
       33
       +
         |> Jsont.Object.finish

     

       26
       34
        
       

     

       35
       35
       +
       (* Decode and encode functions using Encode module *)

     

       27
       36
        
       let of_json json =

     

       28
       28
       -
         Jsonu.with_object "user" (fun fields ->

     

       29
       29
       -
           match Jsonu.get_string fields "email", Jsonu.get_string fields "full_name" with

     

       30
       30
       -
           | Ok email, Ok full_name ->

     

       31
       31
       -
               let is_active = Jsonu.get_bool_default fields "is_active" true in

     

       32
       32
       -
               let is_admin = Jsonu.get_bool_default fields "is_admin" false in

     

       33
       33
       -
               let is_bot = Jsonu.get_bool_default fields "is_bot" false in

     

       34
       34
       -
               Ok { email; full_name; is_active; is_admin; is_bot }

     

       35
       35
       -
           | Error e, _ | _, Error e -> Error e

     

       36
       36
       -
         ) json

     

       37
       37
       +
         match Encode.from_json jsont json with

     

       38
       38
       +
         | Ok v -> Ok v

     

       39
       39
       +
         | Error msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg ())

     

       40
       40
       +
       

     

       41
       41
       +
       let to_json_string t =

     

       42
       42
       +
         Encode.to_json_string jsont t

     

       37
       43
        
       

     

       38
       38
       -
       let pp fmt t = Format.fprintf fmt "User{email=%s, full_name=%s}" t.email t.full_name
     

       44
       44
       +
       let to_form_urlencoded t =

     

       45
       45
       +
         Encode.to_form_urlencoded jsont t

+18 -7

stack/zulip/lib/zulip/lib/user.mli

···

       1
       1
        
       type t

     

       2
       2
        
       

     

       3
       3
       -
       val create : 

     

       4
       4
       -
         email:string -> 

     

       5
       5
       -
         full_name:string -> 

     

       6
       6
       -
         ?is_active:bool -> 

     

       7
       7
       -
         ?is_admin:bool -> 

     

       8
       8
       -
         ?is_bot:bool -> 

     

       3
       3
       +
       val create :

     

       4
       4
       +
         email:string ->

     

       5
       5
       +
         full_name:string ->

     

       6
       6
       +
         ?is_active:bool ->

     

       7
       7
       +
         ?is_admin:bool ->

     

       8
       8
       +
         ?is_bot:bool ->

     

       9
       9
        
         unit -> t

     

       10
       10
        
       

     

       11
       11
        
       val email : t -> string

     
···

       13
       13
        
       val is_active : t -> bool

     

       14
       14
        
       val is_admin : t -> bool

     

       15
       15
        
       val is_bot : t -> bool

     

       16
       16
       -
       val to_json : t -> Zulip_types.json

     

       16
       16
       +
       

     

       17
       17
       +
       (** Jsont codec for the user type *)

     

       18
       18
       +
       val jsont : t Jsont.t

     

       19
       19
       +
       

     

       20
       20
       +
       (** Decode from Jsont.json *)

     

       17
       21
        
       val of_json : Zulip_types.json -> (t, Zulip_types.zerror) result

     

       22
       22
       +
       

     

       23
       23
       +
       (** Encode to JSON string *)

     

       24
       24
       +
       val to_json_string : t -> string

     

       25
       25
       +
       

     

       26
       26
       +
       (** Encode to form-urlencoded string *)

     

       27
       27
       +
       val to_form_urlencoded : t -> string

     

       28
       28
       +
       

     

       18
       29
        
       val pp : Format.formatter -> t -> unit

+32 -28

stack/zulip/lib/zulip/lib/users.ml

···

       1
       1
       -
       let list client = 

     

       1
       1
       +
       let list client =

     

       2
       2
       +
         (* Define response codec *)

     

       3
       3
       +
         let response_codec =

     

       4
       4
       +
           Jsont.Object.(

     

       5
       5
       +
             map ~kind:"UsersResponse" (fun members -> members)

     

       6
       6
       +
             |> mem "members" (Jsont.list User.jsont) ~enc:(fun x -> x)

     

       7
       7
       +
             |> finish

     

       8
       8
       +
           )

     

       9
       9
       +
         in

     

       10
       10
       +
       

     

       2
       11
        
         match Client.request client ~method_:`GET ~path:"/api/v1/users" () with

     

       3
       3
       -
         | Ok json -> 

     

       4
       4
       -
             (match json with

     

       5
       5
       -
              | `O fields ->

     

       6
       6
       -
                  (match List.assoc_opt "members" fields with

     

       7
       7
       -
                   | Some (`A user_list) ->

     

       8
       8
       -
                       let users = List.fold_left (fun acc user_json ->

     

       9
       9
       -
                         match User.of_json user_json with

     

       10
       10
       -
                         | Ok user -> user :: acc

     

       11
       11
       -
                         | Error _ -> acc

     

       12
       12
       -
                       ) [] user_list in

     

       13
       13
       -
                       Ok (List.rev users)

     

       14
       14
       -
                   | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid users response format" ()))

     

       15
       15
       -
              | _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Users response must be an object" ()))

     

       12
       12
       +
         | Ok json ->

     

       13
       13
       +
             (match Encode.from_json response_codec json with

     

       14
       14
       +
              | Ok users -> Ok users

     

       15
       15
       +
              | Error msg -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))

     

       16
       16
        
         | Error err -> Error err

     

       17
       17
        
       

     

       18
       18
        
       let get client ~email = 

     
···

       23
       23
        
              | Error err -> Error err)

     

       24
       24
        
         | Error err -> Error err

     

       25
       25
        
       

     

       26
       26
       -
       let create_user client ~email ~full_name = 

     

       27
       27
       -
         let body_json = `O [

     

       28
       28
       -
           ("email", `String email);

     

       29
       29
       -
           ("full_name", `String full_name);

     

       30
       30
       -
         ] in

     

       31
       31
       -
         let body = match body_json with

     

       32
       32
       -
           | `O fields -> 

     

       33
       33
       -
               String.concat "&" (List.map (fun (k, v) -> 

     

       34
       34
       -
                 match v with 

     

       35
       35
       -
                 | `String s -> k ^ "=" ^ s 

     

       36
       36
       -
                 | _ -> ""

     

       37
       37
       -
               ) fields)

     

       38
       38
       -
           | _ -> "" in

     

       39
       39
       -
         match Client.request client ~method_:`POST ~path:"/api/v1/users" ~body () with

     

       26
       26
       +
       (* Request type for create_user *)

     

       27
       27
       +
       module Create_user_request = struct

     

       28
       28
       +
         type t = { email : string; full_name : string }

     

       29
       29
       +
       

     

       30
       30
       +
         let codec =

     

       31
       31
       +
           Jsont.Object.(

     

       32
       32
       +
             map ~kind:"CreateUserRequest" (fun email full_name -> { email; full_name })

     

       33
       33
       +
             |> mem "email" Jsont.string ~enc:(fun r -> r.email)

     

       34
       34
       +
             |> mem "full_name" Jsont.string ~enc:(fun r -> r.full_name)

     

       35
       35
       +
             |> finish

     

       36
       36
       +
           )

     

       37
       37
       +
       end

     

       38
       38
       +
       

     

       39
       39
       +
       let create_user client ~email ~full_name =

     

       40
       40
       +
         let req = Create_user_request.{ email; full_name } in

     

       41
       41
       +
         let body = Encode.to_form_urlencoded Create_user_request.codec req in

     

       42
       42
       +
         let content_type = "application/x-www-form-urlencoded" in

     

       43
       43
       +
         match Client.request client ~method_:`POST ~path:"/api/v1/users" ~body ~content_type () with

     

       40
       44
        
         | Ok _json -> Ok ()

     

       41
       45
        
         | Error err -> Error err

     

       42
       46

+1 -5

stack/zulip/lib/zulip/lib/zulip.ml

···

       41
       41
        
       module Event = Event

     

       42
       42
        
       module Event_type = Event_type

     

       43
       43
        
       module Event_queue = Event_queue

     

       44
       44
       -
       

     

       45
       45
       -
       (** JSON utilities with short alias *)

     

       46
       46
       -
       module J = Jsonu

     

       47
       47
       -
       module Jsonu_syntax = Jsonu_syntax

     

       48
       48
       -
       module Jsonu = Jsonu
     

       44
       44
       +
       module Encode = Encode

+2 -10

stack/zulip/lib/zulip/lib/zulip.mli

···

       65
       65
        
       module Event_type = Event_type

     

       66
       66
        
       module Event_queue = Event_queue

     

       67
       67
        
       

     

       68
       68
       -
       (** {1 JSON Utilities} *)

     

       69
       69
       -
       

     

       70
       70
       -
       (** JSON utility functions (abbreviated as J for convenience) *)

     

       71
       71
       -
       module J = Jsonu

     

       72
       72
       -
       

     

       73
       73
       -
       (** JSON parsing syntax extensions *)

     

       74
       74
       -
       module Jsonu_syntax = Jsonu_syntax

     

       75
       75
       -
       

     

       76
       76
       -
       (** Full JSON utilities module *)

     

       77
       77
       -
       module Jsonu = Jsonu

     

       68
       68
       +
       (** JSON encoding/decoding utilities *)

     

       69
       69
       +
       module Encode = Encode

     

       78
       70

+32 -15

stack/zulip/lib/zulip/lib/zulip_types.ml

···

       1
       1
        
       (** Core types for Zulip API *)

     

       2
       2
        
       

     

       3
       3
        
       (** JSON type used throughout the API *)

     

       4
       4
       -
       type json = [`Null | `Bool of bool | `Float of float | `String of string | `A of json list | `O of (string * json) list]

     

       4
       4
       +
       type json = Jsont.json

     

       5
       5
        
       

     

       6
       6
        
       (** Error codes returned by Zulip API *)

     

       7
       7
        
       type error_code =

     
···

       45
       45
        
       let pp_error fmt t = Format.fprintf fmt "Error(%s): %s"

     

       46
       46
        
         (error_code_to_string t.code) t.message

     

       47
       47
        
       

     

       48
       48
       +
       (* Jsont codec for error_code *)

     

       49
       49
       +
       let error_code_jsont =

     

       50
       50
       +
         let of_string s = Ok (error_code_of_string s) in

     

       51
       51
       +
         Jsont.of_of_string ~kind:"ErrorCode" of_string ~enc:error_code_to_string

     

       52
       52
       +
       

     

       53
       53
       +
       (* Jsont codec for zerror *)

     

       54
       54
       +
       let zerror_jsont =

     

       55
       55
       +
         let kind = "ZulipError" in

     

       56
       56
       +
         let make code msg =

     

       57
       57
       +
           (* Extra fields handled by keep_unknown - we'll extract them separately *)

     

       58
       58
       +
           { code = error_code_of_string code; message = msg; extra = [] }

     

       59
       59
       +
         in

     

       60
       60
       +
         let code t = error_code_to_string t.code in

     

       61
       61
       +
         let msg t = t.message in

     

       62
       62
       +
         Jsont.Object.(

     

       63
       63
       +
           map ~kind make

     

       64
       64
       +
           |> mem "code" Jsont.string ~enc:code

     

       65
       65
       +
           |> mem "msg" Jsont.string ~enc:msg

     

       66
       66
       +
           |> finish

     

       67
       67
       +
         )

     

       68
       68
       +
       

     

       48
       69
        
       let error_of_json json =

     

       49
       49
       -
         match json with

     

       50
       50
       -
         | `O fields ->

     

       51
       51
       -
             (try

     

       52
       52
       -
               let code_str = match List.assoc "code" fields with

     

       53
       53
       -
                 | `String s -> s

     

       54
       54
       -
                 | _ -> "OTHER" in

     

       55
       55
       -
               let msg = match List.assoc "msg" fields with

     

       56
       56
       -
                 | `String s -> s

     

       57
       57
       -
                 | _ -> "Unknown error" in

     

       58
       58
       -
               let code = error_code_of_string code_str in

     

       59
       59
       -
               let extra = List.filter (fun (k, _) -> k <> "code" && k <> "msg" && k <> "result") fields in

     

       60
       60
       -
               Some (create_error ~code ~msg ~extra ())

     

       61
       61
       -
             with Not_found -> None)

     

       62
       62
       -
         | _ -> None
     

       70
       70
       +
         match Encode.from_json zerror_jsont json with

     

       71
       71
       +
         | Ok err ->

     

       72
       72
       +
             (* Extract extra fields by getting all fields except code, msg, result *)

     

       73
       73
       +
             (match json with

     

       74
       74
       +
              | Jsont.Object (fields, _) ->

     

       75
       75
       +
                  let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       76
       76
       +
                  let extra = List.filter (fun (k, _) -> k <> "code" && k <> "msg" && k <> "result") assoc in

     

       77
       77
       +
                  Some { err with extra }

     

       78
       78
       +
              | _ -> Some err)

     

       79
       79
       +
         | Error _ -> None

+6 -1

stack/zulip/lib/zulip/lib/zulip_types.mli

···

       1
       1
        
       (** Core types for Zulip API *)

     

       2
       2
        
       

     

       3
       3
        
       (** JSON type used throughout the API *)

     

       4
       4
       -
       type json = [`Null | `Bool of bool | `Float of float | `String of string | `A of json list | `O of (string * json) list]

     

       4
       4
       +
       type json = Jsont.json

     

       5
       5
        
       

     

       6
       6
        
       (** Error codes returned by Zulip API *)

     

       7
       7
        
       type error_code =

     
···

       27
       27
        
       val error_message : zerror -> string

     

       28
       28
        
       val error_extra : zerror -> (string * json) list

     

       29
       29
        
       val pp_error : Format.formatter -> zerror -> unit

     

       30
       30
       +
       

     

       31
       31
       +
       (** Jsont codecs *)

     

       32
       32
       +
       val error_code_jsont : error_code Jsont.t

     

       33
       33
       +
       val zerror_jsont : zerror Jsont.t

     

       34
       34
       +
       

     

       30
       35
        
       val error_of_json : json -> zerror option

+6 -5

stack/zulip/lib/zulip_bot/lib/bot_runner.ml

···

       45
       45
        
             (* Extract the actual message from the event *)

     

       46
       46
        
             let message_json, flags =

     

       47
       47
        
               match event_data with

     

       48
       48
       -
               | `O fields ->

     

       49
       49
       -
                   let msg = match List.assoc_opt "message" fields with

     

       48
       48
       +
               | Jsont.Object (fields, _) ->

     

       49
       49
       +
                   let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       50
       50
       +
                   let msg = match List.assoc_opt "message" assoc with

     

       50
       51
        
                     | Some m -> m

     

       51
       52
        
                     | None -> event_data (* Fallback if structure is different *)

     

       52
       53
        
                   in

     

       53
       53
       -
                   let flgs = match List.assoc_opt "flags" fields with

     

       54
       54
       -
                     | Some (`A f) -> f

     

       54
       54
       +
                   let flgs = match List.assoc_opt "flags" assoc with

     

       55
       55
       +
                     | Some (Jsont.Array (f, _)) -> f

     

       55
       56
        
                     | _ -> []

     

       56
       57
        
                   in

     

       57
       58
        
                   (msg, flgs)

     
···

       73
       74
        
       

     

       74
       75
        
                  (* Check if mentioned *)

     

       75
       76
        
                  let is_mentioned =

     

       76
       76
       -
                    List.exists (function `String "mentioned" -> true | _ -> false) flags ||

     

       77
       77
       +
                    List.exists (function Jsont.String ("mentioned", _) -> true | _ -> false) flags ||

     

       77
       78
        
                    Message.is_mentioned message ~user_email:bot_email in

     

       78
       79
        
       

     

       79
       80
        
                  (* Check if it's a private message *)

+54 -30

stack/zulip/lib/zulip_bot/lib/bot_storage.ml

···

       9
       9
        
         mutable dirty_keys : string list;

     

       10
       10
        
       }

     

       11
       11
        
       

     

       12
       12
       +
       (** {1 JSON Codecs for Bot Storage} *)

     

       13
       13
       +
       

     

       14
       14
       +
       (* String map for storage values *)

     

       15
       15
       +
       module String_map = Map.Make (String)

     

       16
       16
       +
       

     

       17
       17
       +
       (* Storage response type - {"storage": {...}} *)

     

       18
       18
       +
       type storage_response = {

     

       19
       19
       +
         storage : string String_map.t;

     

       20
       20
       +
         unknown : Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       21
       21
       +
       }

     

       22
       22
       +
       

     

       23
       23
       +
       (* Codec for storage response using Jsont.Object with keep_unknown *)

     

       24
       24
       +
       let storage_response_jsont : storage_response Jsont.t =

     

       25
       25
       +
         let make storage unknown = { storage; unknown } in

     

       26
       26
       +
         let storage_map_jsont =

     

       27
       27
       +
           Jsont.Object.map ~kind:"StorageMap" Fun.id

     

       28
       28
       +
           |> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map Jsont.string) ~enc:Fun.id

     

       29
       29
       +
           |> Jsont.Object.finish

     

       30
       30
       +
         in

     

       31
       31
       +
         Jsont.Object.map ~kind:"StorageResponse" make

     

       32
       32
       +
         |> Jsont.Object.mem "storage" storage_map_jsont ~enc:(fun r -> r.storage)

     

       33
       33
       +
           ~dec_absent:String_map.empty

     

       34
       34
       +
         |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)

     

       35
       35
       +
         |> Jsont.Object.finish

     

       36
       36
       +
       

     

       12
       37
        
       let create client ~bot_email =

     

       13
       38
        
         Log.info (fun m -> m "Creating bot storage for %s" bot_email);

     

       14
       39
        
         let cache = Hashtbl.create 16 in

     
···

       19
       44
        
                 ~path:"/api/v1/bot_storage"

     

       20
       45
        
                 () with

     

       21
       46
        
         | Ok json ->

     

       22
       22
       -
             (match Zulip.Jsonu.get_object_opt (match json with `O f -> f | _ -> []) "storage" with

     

       23
       23
       -
              | Some storage_fields ->

     

       24
       24
       -
                  List.iter (fun (k, v) ->

     

       25
       25
       -
                    match Zulip.Jsonu.to_string_safe v with

     

       26
       26
       -
                    | Some value ->

     

       27
       27
       -
                        Log.debug (fun m -> m "Loaded key from server: %s" k);

     

       28
       28
       -
                        Hashtbl.add cache k value

     

       29
       29
       -
                    | None -> ()

     

       30
       30
       -
                  ) storage_fields

     

       31
       31
       -
              | None -> ())

     

       47
       47
       +
             (match Zulip.Encode.from_json storage_response_jsont json with

     

       48
       48
       +
              | Ok response ->

     

       49
       49
       +
                  String_map.iter (fun k v ->

     

       50
       50
       +
                    Log.debug (fun m -> m "Loaded key from server: %s" k);

     

       51
       51
       +
                    Hashtbl.add cache k v

     

       52
       52
       +
                  ) response.storage

     

       53
       53
       +
              | Error msg ->

     

       54
       54
       +
                  Log.warn (fun m -> m "Failed to parse storage response: %s" msg))

     

       32
       55
        
         | Error e ->

     

       33
       56
        
             Log.warn (fun m -> m "Failed to load existing storage: %s" (Zulip.error_message e)));

     

       34
       57
        
       

     
···

       43
       66
        
       let encode_storage_update keys_values =

     

       44
       67
        
         (* Build the storage object as JSON - the API expects storage={"key": "value"} *)

     

       45
       68
        
         let storage_obj =

     

       46
       46
       -
           List.map (fun (k, v) -> (k, `String v)) keys_values

     

       69
       69
       +
           List.map (fun (k, v) -> ((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))) keys_values

     

       47
       70
        
         in

     

       48
       48
       -
         let json_obj = `O storage_obj in

     

       71
       71
       +
         let json_obj = Jsont.Object (storage_obj, Jsont.Meta.none) in

     

       49
       72
        
       

     

       50
       50
       -
         (* Convert to JSON string using Ezjsonm *)

     

       51
       51
       -
         let json_str = Ezjsonm.to_string json_obj in

     

       73
       73
       +
         (* Convert to JSON string using Jsont_bytesrw *)

     

       74
       74
       +
         let json_str = Jsont_bytesrw.encode_string' Jsont.json json_obj |> Result.get_ok in

     

       52
       75
        
       

     

       53
       76
        
         (* Return as form-encoded body: storage=<url-encoded-json> *)

     

       54
       77
        
         "storage=" ^ Uri.pct_encode json_str

     
···

       68
       91
        
                     ~path:"/api/v1/bot_storage"

     

       69
       92
        
                     ~params () with

     

       70
       93
        
             | Ok json ->

     

       71
       71
       -
                 (match Zulip.Jsonu.get_object_opt (match json with `O f -> f | _ -> []) "storage" with

     

       72
       72
       -
                  | Some storage_fields ->

     

       73
       73
       -
                      (match Zulip.Jsonu.get_string_opt storage_fields key with

     

       94
       94
       +
                 (match Zulip.Encode.from_json storage_response_jsont json with

     

       95
       95
       +
                  | Ok response ->

     

       96
       96
       +
                      (match String_map.find_opt key response.storage with

     

       74
       97
        
                       | Some value ->

     

       75
       98
        
                           (* Cache the value *)

     

       76
       99
        
                           Log.debug (fun m -> m "Retrieved key from API: %s" key);

     
···

       79
       102
        
                       | None ->

     

       80
       103
        
                           Log.debug (fun m -> m "Key not found in API: %s" key);

     

       81
       104
        
                           None)

     

       82
       82
       -
                  | None -> None)

     

       105
       105
       +
                  | Error msg ->

     

       106
       106
       +
                      Log.warn (fun m -> m "Failed to parse storage response: %s" msg);

     

       107
       107
       +
                      None)

     

       83
       108
        
             | Error e ->

     

       84
       109
        
                 Log.warn (fun m -> m "Error fetching key %s: %s" key (Zulip.error_message e));

     

       85
       110
        
                 None

     
···

       140
       165
        
                 ~path:"/api/v1/bot_storage"

     

       141
       166
        
                 () with

     

       142
       167
        
         | Ok json ->

     

       143
       143
       -
             (match json with

     

       144
       144
       -
              | `O fields ->

     

       145
       145
       -
                  (match List.assoc_opt "storage" fields with

     

       146
       146
       -
                   | Some (`O storage_fields) ->

     

       147
       147
       -
                       let api_keys = List.map fst storage_fields in

     

       148
       148
       -
                       (* Merge with cache keys *)

     

       149
       149
       -
                       let cache_keys = Hashtbl.fold (fun k _ acc -> k :: acc) t.cache [] in

     

       150
       150
       -
                       let all_keys = List.sort_uniq String.compare (api_keys @ cache_keys) in

     

       151
       151
       -
                       Ok all_keys

     

       152
       152
       -
                   | _ -> Ok [])

     

       153
       153
       -
              | _ -> Ok [])

     

       168
       168
       +
             (match Zulip.Encode.from_json storage_response_jsont json with

     

       169
       169
       +
              | Ok response ->

     

       170
       170
       +
                  let api_keys = String_map.fold (fun k _ acc -> k :: acc) response.storage [] in

     

       171
       171
       +
                  (* Merge with cache keys *)

     

       172
       172
       +
                  let cache_keys = Hashtbl.fold (fun k _ acc -> k :: acc) t.cache [] in

     

       173
       173
       +
                  let all_keys = List.sort_uniq String.compare (api_keys @ cache_keys) in

     

       174
       174
       +
                  Ok all_keys

     

       175
       175
       +
              | Error msg ->

     

       176
       176
       +
                  Log.warn (fun m -> m "Failed to parse storage response: %s" msg);

     

       177
       177
       +
                  Ok [])

     

       154
       178
        
         | Error e -> Error e

     

       155
       179
        
       

     

       156
       180
        
       (* Flush all dirty keys to API *)

     
···

       182
       206
        
             | Error e ->

     

       183
       207
        
                 Log.err (fun m -> m "Failed to flush storage: %s" (Zulip.error_message e));

     

       184
       208
        
                 Error e

     

       185
       185
       -
           end
     

       209
       209
       +
           end

+1 -1

stack/zulip/lib/zulip_bot/lib/dune

···

       2
       2
        
        (public_name zulip_bot)

     

       3
       3
        
        (name zulip_bot)

     

       4
       4
        
        (wrapped true)

     

       5
       5
       -
        (libraries zulip unix eio ezjsonm logs mirage-crypto-rng fmt)

     

       5
       5
       +
        (libraries zulip unix eio jsont jsont.bytesrw logs mirage-crypto-rng fmt)

     

       6
       6
        
        (flags (:standard -warn-error -3)))

+192 -88

stack/zulip/lib/zulip_bot/lib/message.ml

···

       1
       1
       -
       (* Use Jsonm exclusively via Zulip.Jsonu utilities *)

     

       1
       1
       +
       (* Message parsing using Jsont codecs *)

     

       2
       2
        
       

     

       3
       3
        
       let logs_src = Logs.Src.create "zulip_bot.message"

     

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

     
···

       10
       10
        
           email: string;

     

       11
       11
        
           full_name: string;

     

       12
       12
        
           short_name: string option;

     

       13
       13
       +
           unknown: Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       13
       14
        
         }

     

       14
       15
        
       

     

       15
       16
        
         let user_id t = t.user_id

     
···

       17
       18
        
         let full_name t = t.full_name

     

       18
       19
        
         let short_name t = t.short_name

     

       19
       20
        
       

     

       21
       21
       +
         (* Jsont codec for User - handles both user_id and id fields *)

     

       22
       22
       +
         let jsont : t Jsont.t =

     

       23
       23
       +
           let make email full_name short_name unknown =

     

       24
       24
       +
             (* user_id will be extracted in a custom way from the object *)

     

       25
       25
       +
             fun user_id_opt id_opt ->

     

       26
       26
       +
               let user_id = match user_id_opt, id_opt with

     

       27
       27
       +
                 | Some uid, _ -> uid

     

       28
       28
       +
                 | None, Some id -> id

     

       29
       29
       +
                 | None, None -> Jsont.Error.msgf Jsont.Meta.none "Missing user_id or id field"

     

       30
       30
       +
               in

     

       31
       31
       +
               { user_id; email; full_name; short_name; unknown }

     

       32
       32
       +
           in

     

       33
       33
       +
           Jsont.Object.map ~kind:"User" make

     

       34
       34
       +
           |> Jsont.Object.mem "email" Jsont.string ~enc:email

     

       35
       35
       +
           |> Jsont.Object.mem "full_name" Jsont.string ~enc:full_name

     

       36
       36
       +
           |> Jsont.Object.opt_mem "short_name" Jsont.string ~enc:short_name

     

       37
       37
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)

     

       38
       38
       +
           |> Jsont.Object.opt_mem "user_id" Jsont.int ~enc:(fun t -> Some t.user_id)

     

       39
       39
       +
           |> Jsont.Object.opt_mem "id" Jsont.int ~enc:(fun _ -> None)

     

       40
       40
       +
           |> Jsont.Object.finish

     

       41
       41
       +
       

     

       20
       42
        
         let of_json (json : Zulip.json) : (t, Zulip.zerror) result =

     

       21
       21
       -
           let open Zulip.Jsonu_syntax in

     

       22
       22
       -
           (Zulip.Jsonu.with_object "user" @@ fun fields ->

     

       23
       23
       -
           let* user_id = (field fields "user_id" int) <|> (field fields "id" int) in

     

       24
       24
       -
           let* email = field fields "email" string in

     

       25
       25
       -
           let* full_name = field fields "full_name" string in

     

       26
       26
       -
           let* short_name = field_opt fields "short_name" string in

     

       27
       27
       -
           Ok { user_id; email; full_name; short_name }) json

     

       43
       43
       +
           match Zulip.Encode.from_json jsont json with

     

       44
       44
       +
           | Ok v -> Ok v

     

       45
       45
       +
           | Error msg -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg ())

     

       28
       46
        
       end

     

       29
       47
        
       

     

       30
       48
        
       (** Reaction representation *)

     
···

       34
       52
        
           emoji_code: string;

     

       35
       53
        
           reaction_type: string;

     

       36
       54
        
           user_id: int;

     

       55
       55
       +
           unknown: Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       37
       56
        
         }

     

       38
       57
        
       

     

       39
       58
        
         let emoji_name t = t.emoji_name

     
···

       41
       60
        
         let reaction_type t = t.reaction_type

     

       42
       61
        
         let user_id t = t.user_id

     

       43
       62
        
       

     

       63
       63
       +
         (* Jsont codec for Reaction - handles user_id in different locations *)

     

       64
       64
       +
         let jsont : t Jsont.t =

     

       65
       65
       +
           (* Helper codec for nested user object - extracts just the user_id *)

     

       66
       66
       +
           let user_obj_codec =

     

       67
       67
       +
             Jsont.Object.map ~kind:"ReactionUser" Fun.id

     

       68
       68
       +
             |> Jsont.Object.mem "user_id" Jsont.int ~enc:Fun.id

     

       69
       69
       +
             |> Jsont.Object.finish

     

       70
       70
       +
           in

     

       71
       71
       +
           let make emoji_name emoji_code reaction_type unknown =

     

       72
       72
       +
             fun user_id_direct user_obj_nested ->

     

       73
       73
       +
               let user_id = match user_id_direct, user_obj_nested with

     

       74
       74
       +
                 | Some uid, _ -> uid

     

       75
       75
       +
                 | None, Some uid -> uid

     

       76
       76
       +
                 | None, None -> Jsont.Error.msgf Jsont.Meta.none "Missing user_id field"

     

       77
       77
       +
               in

     

       78
       78
       +
               { emoji_name; emoji_code; reaction_type; user_id; unknown }

     

       79
       79
       +
           in

     

       80
       80
       +
           Jsont.Object.map ~kind:"Reaction" make

     

       81
       81
       +
           |> Jsont.Object.mem "emoji_name" Jsont.string ~enc:emoji_name

     

       82
       82
       +
           |> Jsont.Object.mem "emoji_code" Jsont.string ~enc:emoji_code

     

       83
       83
       +
           |> Jsont.Object.mem "reaction_type" Jsont.string ~enc:reaction_type

     

       84
       84
       +
           |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)

     

       85
       85
       +
           |> Jsont.Object.opt_mem "user_id" Jsont.int ~enc:(fun t -> Some t.user_id)

     

       86
       86
       +
           |> Jsont.Object.opt_mem "user" user_obj_codec ~enc:(fun _ -> None)

     

       87
       87
       +
           |> Jsont.Object.finish

     

       88
       88
       +
       

     

       44
       89
        
         let of_json (json : Zulip.json) : (t, Zulip.zerror) result =

     

       45
       45
       -
           let open Zulip.Jsonu_syntax in

     

       46
       46
       -
           (Zulip.Jsonu.with_object "reaction" @@ fun fields ->

     

       47
       47
       -
           let* emoji_name = field fields "emoji_name" string in

     

       48
       48
       -
           let* emoji_code = field fields "emoji_code" string in

     

       49
       49
       -
           let* reaction_type = field fields "reaction_type" string in

     

       50
       50
       -
           let* user_id =

     

       51
       51
       -
             (field fields "user_id" int) <|>

     

       52
       52
       -
             (match field fields "user" object_ with

     

       53
       53
       -
              | Ok user_obj -> field user_obj "user_id" int

     

       54
       54
       -
              | Error _ -> fail "user_id not found") in

     

       55
       55
       -
           Ok { emoji_name; emoji_code; reaction_type; user_id }) json

     

       90
       90
       +
           match Zulip.Encode.from_json jsont json with

     

       91
       91
       +
           | Ok v -> Ok v

     

       92
       92
       +
           | Error msg -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg ())

     

       56
       93
        
       end

     

       57
       94
        
       

     

       58
       95
        
       let parse_reaction_json json = Reaction.of_json json

     
···

       96
       133
        
       

     

       97
       134
        
       (** Helper function to parse common fields *)

     

       98
       135
        
       let parse_common json =

     

       99
       99
       -
         Zulip.Jsonu.parse_with_error "common fields" @@ fun () ->

     

       100
       100
       -
         (Zulip.Jsonu.with_object "message" @@ fun fields ->

     

       101
       101
       -
         let open Zulip.Jsonu_syntax in

     

       102
       102
       -
         let* id = field fields "id" int in

     

       103
       103
       -
         let* sender_id = field fields "sender_id" int in

     

       104
       104
       -
         let* sender_email = field fields "sender_email" string in

     

       105
       105
       -
         let* sender_full_name = field fields "sender_full_name" string in

     

       106
       106
       -
         let sender_short_name = field_opt fields "sender_short_name" string |? None in

     

       107
       107
       -
         let timestamp = field_or fields "timestamp" float 0.0 |? 0.0 in

     

       108
       108
       -
         let content = field_or fields "content" string "" |? "" in

     

       109
       109
       -
         let content_type = field_or fields "content_type" string "text/html" |? "text/html" in

     

       136
       136
       +
         match json with

     

       137
       137
       +
         | Jsont.Object (fields, _) ->

     

       138
       138
       +
             let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       139
       139
       +
             let get_int key =

     

       140
       140
       +
               match List.assoc_opt key assoc with

     

       141
       141
       +
               | Some (Jsont.Number (f, _)) -> Some (int_of_float f)

     

       142
       142
       +
               | _ -> None

     

       143
       143
       +
             in

     

       144
       144
       +
             let get_string key =

     

       145
       145
       +
               match List.assoc_opt key assoc with

     

       146
       146
       +
               | Some (Jsont.String (s, _)) -> Some s

     

       147
       147
       +
               | _ -> None

     

       148
       148
       +
             in

     

       149
       149
       +
             let get_float key default =

     

       150
       150
       +
               match List.assoc_opt key assoc with

     

       151
       151
       +
               | Some (Jsont.Number (f, _)) -> f

     

       152
       152
       +
               | _ -> default

     

       153
       153
       +
             in

     

       154
       154
       +
             let get_bool key default =

     

       155
       155
       +
               match List.assoc_opt key assoc with

     

       156
       156
       +
               | Some (Jsont.Bool (b, _)) -> b

     

       157
       157
       +
               | _ -> default

     

       158
       158
       +
             in

     

       159
       159
       +
             let get_array key =

     

       160
       160
       +
               match List.assoc_opt key assoc with

     

       161
       161
       +
               | Some (Jsont.Array (arr, _)) -> Some arr

     

       162
       162
       +
               | _ -> None

     

       163
       163
       +
             in

     

       110
       164
        
       

     

       111
       111
       -
         let reactions =

     

       112
       112
       -
           match Zulip.Jsonu.get_array_opt fields "reactions" with

     

       113
       113
       -
           | Some reactions_json ->

     

       114
       114
       -
               List.filter_map (fun r ->

     

       115
       115
       -
                 match parse_reaction_json r with

     

       116
       116
       -
                 | Ok reaction -> Some reaction

     

       117
       117
       -
                 | Error err ->

     

       118
       118
       -
                     Log.warn (fun m -> m "Failed to parse reaction: %s" (Zulip.error_message err));

     

       119
       119
       -
                     None

     

       120
       120
       -
               ) reactions_json

     

       121
       121
       -
           | None -> []

     

       122
       122
       -
         in

     

       165
       165
       +
             (match (get_int "id", get_int "sender_id", get_string "sender_email", get_string "sender_full_name") with

     

       166
       166
       +
              | (Some id, Some sender_id, Some sender_email, Some sender_full_name) ->

     

       167
       167
       +
                  let sender_short_name = get_string "sender_short_name" in

     

       168
       168
       +
                  let timestamp = get_float "timestamp" 0.0 in

     

       169
       169
       +
                  let content = get_string "content" |> Option.value ~default:"" in

     

       170
       170
       +
                  let content_type = get_string "content_type" |> Option.value ~default:"text/html" in

     

       123
       171
        
       

     

       124
       124
       -
         let submessages = Zulip.Jsonu.get_array_opt fields "submessages" |> Option.value ~default:[] in

     

       172
       172
       +
                  let reactions =

     

       173
       173
       +
                    match get_array "reactions" with

     

       174
       174
       +
                    | Some reactions_json ->

     

       175
       175
       +
                        List.filter_map (fun r ->

     

       176
       176
       +
                          match parse_reaction_json r with

     

       177
       177
       +
                          | Ok reaction -> Some reaction

     

       178
       178
       +
                          | Error err ->

     

       179
       179
       +
                              Log.warn (fun m -> m "Failed to parse reaction: %s" (Zulip.error_message err));

     

       180
       180
       +
                              None

     

       181
       181
       +
                        ) reactions_json

     

       182
       182
       +
                    | None -> []

     

       183
       183
       +
                  in

     

       125
       184
        
       

     

       126
       126
       -
         let flags =

     

       127
       127
       -
           match Zulip.Jsonu.get_array_opt fields "flags" with

     

       128
       128
       -
           | Some flags_json -> List.filter_map Zulip.Jsonu.to_string_safe flags_json

     

       129
       129
       -
           | None -> []

     

       130
       130
       -
         in

     

       185
       185
       +
                  let submessages = get_array "submessages" |> Option.value ~default:[] in

     

       131
       186
        
       

     

       132
       132
       -
         let is_me_message = field_or fields "is_me_message" bool false |? false in

     

       133
       133
       -
         let client = field_or fields "client" string "" |? "" in

     

       134
       134
       -
         let gravatar_hash = field_or fields "gravatar_hash" string "" |? "" in

     

       135
       135
       -
         let avatar_url = field_opt fields "avatar_url" string |? None in

     

       187
       187
       +
                  let flags =

     

       188
       188
       +
                    match get_array "flags" with

     

       189
       189
       +
                    | Some flags_json ->

     

       190
       190
       +
                        List.filter_map (fun f ->

     

       191
       191
       +
                          match f with

     

       192
       192
       +
                          | Jsont.String (s, _) -> Some s

     

       193
       193
       +
                          | _ -> None

     

       194
       194
       +
                        ) flags_json

     

       195
       195
       +
                    | None -> []

     

       196
       196
       +
                  in

     

       136
       197
        
       

     

       137
       137
       -
         Ok {

     

       138
       138
       -
           id; sender_id; sender_email; sender_full_name; sender_short_name;

     

       139
       139
       -
           timestamp; content; content_type; reactions; submessages;

     

       140
       140
       -
           flags; is_me_message; client; gravatar_hash; avatar_url

     

       141
       141
       -
         }) json

     

       198
       198
       +
                  let is_me_message = get_bool "is_me_message" false in

     

       199
       199
       +
                  let client = get_string "client" |> Option.value ~default:"" in

     

       200
       200
       +
                  let gravatar_hash = get_string "gravatar_hash" |> Option.value ~default:"" in

     

       201
       201
       +
                  let avatar_url = get_string "avatar_url" in

     

       202
       202
       +
       

     

       203
       203
       +
                  Ok {

     

       204
       204
       +
                    id; sender_id; sender_email; sender_full_name; sender_short_name;

     

       205
       205
       +
                    timestamp; content; content_type; reactions; submessages;

     

       206
       206
       +
                    flags; is_me_message; client; gravatar_hash; avatar_url

     

       207
       207
       +
                  }

     

       208
       208
       +
              | _ -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg:"Missing required message fields" ()))

     

       209
       209
       +
         | _ -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg:"Expected JSON object for message" ())

     

       142
       210
        
       

     

       143
       211
        
       (** JSON parsing *)

     

       144
       212
        
       let of_json json =

     

       145
       145
       -
         Log.debug (fun m -> m "Parsing message JSON: %s" (Zulip.Jsonu.to_string_pretty json));

     

       213
       213
       +
         (* Helper to pretty print JSON without using jsonu *)

     

       214
       214
       +
         let json_str =

     

       215
       215
       +
           match Jsont_bytesrw.encode_string' Jsont.json json with

     

       216
       216
       +
           | Ok s -> s

     

       217
       217
       +
           | Error _ -> "<error encoding json>"

     

       218
       218
       +
         in

     

       219
       219
       +
         Log.debug (fun m -> m "Parsing message JSON: %s" json_str);

     

       146
       220
        
       

     

       147
       147
       -
         let open Zulip.Jsonu_syntax in

     

       148
       221
        
         match parse_common json with

     

       149
       222
        
         | Error err -> Error (Zulip.error_message err)

     

       150
       223
        
         | Ok common ->

     

       151
       151
       -
             (Zulip.Jsonu.parse_with_error "message type" @@ fun () ->

     

       152
       152
       -
             (Zulip.Jsonu.with_object "message" @@ fun fields ->

     

       153
       153
       -
             match Zulip.Jsonu.get_string fields "type" with

     

       154
       154
       -
             | Ok "private" ->

     

       155
       155
       -
                 let* recipient_json = field fields "display_recipient" (array (fun x -> Ok x)) in

     

       156
       156
       -
                 let users = List.filter_map (fun u ->

     

       157
       157
       -
                   match parse_user_json u with

     

       158
       158
       -
                   | Ok user -> Some user

     

       159
       159
       -
                   | Error err ->

     

       160
       160
       -
                       Log.warn (fun m -> m "Failed to parse user in display_recipient: %s" (Zulip.error_message err));

     

       161
       161
       -
                       None

     

       162
       162
       -
                 ) recipient_json in

     

       224
       224
       +
             match json with

     

       225
       225
       +
             | Jsont.Object (fields, _) ->

     

       226
       226
       +
                 let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in

     

       227
       227
       +
                 let msg_type =

     

       228
       228
       +
                   match List.assoc_opt "type" assoc with

     

       229
       229
       +
                   | Some (Jsont.String (s, _)) -> Some s

     

       230
       230
       +
                   | _ -> None

     

       231
       231
       +
                 in

     

       232
       232
       +
                 (match msg_type with

     

       233
       233
       +
                  | Some "private" ->

     

       234
       234
       +
                      (match List.assoc_opt "display_recipient" assoc with

     

       235
       235
       +
                       | Some (Jsont.Array (recipient_json, _)) ->

     

       236
       236
       +
                           let users = List.filter_map (fun u ->

     

       237
       237
       +
                             match parse_user_json u with

     

       238
       238
       +
                             | Ok user -> Some user

     

       239
       239
       +
                             | Error err ->

     

       240
       240
       +
                                 Log.warn (fun m -> m "Failed to parse user in display_recipient: %s" (Zulip.error_message err));

     

       241
       241
       +
                                 None

     

       242
       242
       +
                           ) recipient_json in

     

       163
       243
        
       

     

       164
       164
       -
                 if List.length users = 0 && List.length recipient_json > 0 then

     

       165
       165
       -
                   fail "Failed to parse any users in display_recipient"

     

       166
       166
       -
                 else

     

       167
       167
       -
                   Ok (Private { common; display_recipient = users })

     

       244
       244
       +
                           if List.length users = 0 && List.length recipient_json > 0 then

     

       245
       245
       +
                             Error "Failed to parse any users in display_recipient"

     

       246
       246
       +
                           else

     

       247
       247
       +
                             Ok (Private { common; display_recipient = users })

     

       248
       248
       +
                       | _ ->

     

       249
       249
       +
                           Log.warn (fun m -> m "display_recipient is not an array for private message");

     

       250
       250
       +
                           Ok (Unknown { common; raw_json = json }))

     

       168
       251
        
       

     

       169
       169
       -
             | Ok "stream" ->

     

       170
       170
       -
                 let* display_recipient = field fields "display_recipient" string in

     

       171
       171
       -
                 let* stream_id = field fields "stream_id" int in

     

       172
       172
       -
                 let* subject = field fields "subject" string in

     

       173
       173
       -
                 Ok (Stream { common; display_recipient; stream_id; subject })

     

       252
       252
       +
                  | Some "stream" ->

     

       253
       253
       +
                      let display_recipient =

     

       254
       254
       +
                        match List.assoc_opt "display_recipient" assoc with

     

       255
       255
       +
                        | Some (Jsont.String (s, _)) -> Some s

     

       256
       256
       +
                        | _ -> None

     

       257
       257
       +
                      in

     

       258
       258
       +
                      let stream_id =

     

       259
       259
       +
                        match List.assoc_opt "stream_id" assoc with

     

       260
       260
       +
                        | Some (Jsont.Number (f, _)) -> Some (int_of_float f)

     

       261
       261
       +
                        | _ -> None

     

       262
       262
       +
                      in

     

       263
       263
       +
                      let subject =

     

       264
       264
       +
                        match List.assoc_opt "subject" assoc with

     

       265
       265
       +
                        | Some (Jsont.String (s, _)) -> Some s

     

       266
       266
       +
                        | _ -> None

     

       267
       267
       +
                      in

     

       268
       268
       +
                      (match (display_recipient, stream_id, subject) with

     

       269
       269
       +
                       | (Some display_recipient, Some stream_id, Some subject) ->

     

       270
       270
       +
                           Ok (Stream { common; display_recipient; stream_id; subject })

     

       271
       271
       +
                       | _ ->

     

       272
       272
       +
                           Log.warn (fun m -> m "Missing required fields for stream message");

     

       273
       273
       +
                           Ok (Unknown { common; raw_json = json }))

     

       174
       274
        
       

     

       175
       175
       -
             | Ok unknown_type ->

     

       176
       176
       -
                 Log.warn (fun m -> m "Unknown message type: %s" unknown_type);

     

       177
       177
       -
                 Ok (Unknown { common; raw_json = json })

     

       275
       275
       +
                  | Some unknown_type ->

     

       276
       276
       +
                      Log.warn (fun m -> m "Unknown message type: %s" unknown_type);

     

       277
       277
       +
                      Ok (Unknown { common; raw_json = json })

     

       178
       278
        
       

     

       179
       179
       -
             | Error _ ->

     

       180
       180
       -
                 Log.warn (fun m -> m "No message type field found");

     

       181
       181
       -
                 Ok (Unknown { common; raw_json = json })

     

       182
       182
       -
             ) json) |> Result.map_error Zulip.error_message

     

       279
       279
       +
                  | None ->

     

       280
       280
       +
                      Log.warn (fun m -> m "No message type field found");

     

       281
       281
       +
                      Ok (Unknown { common; raw_json = json }))

     

       282
       282
       +
             | _ -> Error "Expected JSON object for message"

     

       183
       283
        
       

     

       184
       284
        
       (** Accessor functions *)

     

       185
       285
        
       let get_common = function

     
···

       363
       463
        
       (** Pretty print JSON for debugging *)

     

       364
       464
        
       let pp_json_debug ppf json =

     

       365
       465
        
         let open Fmt in

     

       366
       366
       -
         let json_str = Zulip.Jsonu.to_string_pretty json in

     

       466
       466
       +
         let json_str =

     

       467
       467
       +
           match Jsont_bytesrw.encode_string' Jsont.json json with

     

       468
       468
       +
           | Ok s -> s

     

       469
       469
       +
           | Error _ -> "<error encoding json>"

     

       470
       470
       +
         in

     

       367
       471
        
         pf ppf "@[<v>%a@.%a@]"

     

       368
       472
        
           (styled `Bold (styled (`Fg `Blue) string)) "Raw JSON:"

     

       369
       473
        
           (styled (`Fg `Black) string) json_str

+10

stack/zulip/lib/zulip_bot/lib/message.mli

···

       7
       7
        
           email: string;

     

       8
       8
        
           full_name: string;

     

       9
       9
        
           short_name: string option;

     

       10
       10
       +
           unknown: Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       10
       11
        
         }

     

       11
       12
        
       

     

       12
       13
        
         val user_id : t -> int

     

       13
       14
        
         val email : t -> string

     

       14
       15
        
         val full_name : t -> string

     

       15
       16
        
         val short_name : t -> string option

     

       17
       17
       +
       

     

       18
       18
       +
         (** Jsont codec for User *)

     

       19
       19
       +
         val jsont : t Jsont.t

     

       20
       20
       +
       

     

       16
       21
        
         val of_json : Zulip.json -> (t, Zulip.zerror) result

     

       17
       22
        
       end

     

       18
       23
        
       

     
···

       23
       28
        
           emoji_code: string;

     

       24
       29
        
           reaction_type: string;

     

       25
       30
        
           user_id: int;

     

       31
       31
       +
           unknown: Jsont.json;  (** Unknown/extra JSON fields preserved during parsing *)

     

       26
       32
        
         }

     

       27
       33
        
       

     

       28
       34
        
         val emoji_name : t -> string

     

       29
       35
        
         val emoji_code : t -> string

     

       30
       36
        
         val reaction_type : t -> string

     

       31
       37
        
         val user_id : t -> int

     

       38
       38
       +
       

     

       39
       39
       +
         (** Jsont codec for Reaction *)

     

       40
       40
       +
         val jsont : t Jsont.t

     

       41
       41
       +
       

     

       32
       42
        
         val of_json : Zulip.json -> (t, Zulip.zerror) result

     

       33
       43
        
       end

     

       34
       44

+30

stack/zulip/zulip.opam

···

       1
       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       +
       opam-version: "2.0"

     

       3
       3
       +
       synopsis: "OCaml bindings for the Zulip REST API"

     

       4
       4
       +
       description:

     

       5
       5
       +
         "High-quality OCaml bindings to the Zulip REST API using EIO for async operations"

     

       6
       6
       +
       depends: [

     

       7
       7
       +
         "ocaml"

     

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

     

       9
       9
       +
         "eio"

     

       10
       10
       +
         "requests"

     

       11
       11
       +
         "uri"

     

       12
       12
       +
         "base64"

     

       13
       13
       +
         "alcotest" {with-test}

     

       14
       14
       +
         "eio_main" {with-test}

     

       15
       15
       +
         "odoc" {with-doc}

     

       16
       16
       +
       ]

     

       17
       17
       +
       build: [

     

       18
       18
       +
         ["dune" "subst"] {dev}

     

       19
       19
       +
         [

     

       20
       20
       +
           "dune"

     

       21
       21
       +
           "build"

     

       22
       22
       +
           "-p"

     

       23
       23
       +
           name

     

       24
       24
       +
           "-j"

     

       25
       25
       +
           jobs

     

       26
       26
       +
           "@install"

     

       27
       27
       +
           "@runtest" {with-test}

     

       28
       28
       +
           "@doc" {with-doc}

     

       29
       29
       +
         ]

     

       30
       30
       +
       ]

+26

stack/zulip/zulip_bot.opam

···

       1
       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       +
       opam-version: "2.0"

     

       3
       3
       +
       synopsis: "OCaml bot framework for Zulip"

     

       4
       4
       +
       description: "Interactive bot framework built on the OCaml Zulip library"

     

       5
       5
       +
       depends: [

     

       6
       6
       +
         "ocaml"

     

       7
       7
       +
         "dune" {>= "3.0"}

     

       8
       8
       +
         "zulip"

     

       9
       9
       +
         "eio"

     

       10
       10
       +
         "alcotest" {with-test}

     

       11
       11
       +
         "odoc" {with-doc}

     

       12
       12
       +
       ]

     

       13
       13
       +
       build: [

     

       14
       14
       +
         ["dune" "subst"] {dev}

     

       15
       15
       +
         [

     

       16
       16
       +
           "dune"

     

       17
       17
       +
           "build"

     

       18
       18
       +
           "-p"

     

       19
       19
       +
           name

     

       20
       20
       +
           "-j"

     

       21
       21
       +
           jobs

     

       22
       22
       +
           "@install"

     

       23
       23
       +
           "@runtest" {with-test}

     

       24
       24
       +
           "@doc" {with-doc}

     

       25
       25
       +
         ]

     

       26
       26
       +
       ]

+29

stack/zulip/zulip_botserver.opam

···

       1
       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       2
       +
       opam-version: "2.0"

     

       3
       3
       +
       synopsis: "OCaml bot server for running multiple Zulip bots"

     

       4
       4
       +
       description:

     

       5
       5
       +
         "HTTP server for running multiple Zulip bots with webhook support"

     

       6
       6
       +
       depends: [

     

       7
       7
       +
         "ocaml"

     

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

     

       9
       9
       +
         "zulip"

     

       10
       10
       +
         "zulip_bot"

     

       11
       11
       +
         "eio"

     

       12
       12
       +
         "requests"

     

       13
       13
       +
         "alcotest" {with-test}

     

       14
       14
       +
         "odoc" {with-doc}

     

       15
       15
       +
       ]

     

       16
       16
       +
       build: [

     

       17
       17
       +
         ["dune" "subst"] {dev}

     

       18
       18
       +
         [

     

       19
       19
       +
           "dune"

     

       20
       20
       +
           "build"

     

       21
       21
       +
           "-p"

     

       22
       22
       +
           name

     

       23
       23
       +
           "-j"

     

       24
       24
       +
           jobs

     

       25
       25
       +
           "@install"

     

       26
       26
       +
           "@runtest" {with-test}

     

       27
       27
       +
           "@doc" {with-doc}

     

       28
       28
       +
         ]

     

       29
       29
       +
       ]

Compare changes