commit 1fbdf0019b69a99d2090c000860631a6c44178b2 · anil.recoil.org/ocaml-jmap

-300

jmap-email/jmap_email.ml

···

       1
       -
       (* JMAP Mail Extension Library (RFC 8621). *)

     

       2
       -
       

     

       3
       -
       (* Core Types *)

     

       4
       -
       module Types = Jmap_email_types

     

       5
       -
       

     

       6
       -
       (* Mailbox *)

     

       7
       -
       module Mailbox = Jmap_mailbox

     

       8
       -
       

     

       9
       -
       (* Thread *)

     

       10
       -
       module Thread = Jmap_thread

     

       11
       -
       

     

       12
       -
       (* Search Snippet *)

     

       13
       -
       module SearchSnippet = Jmap_search_snippet

     

       14
       -
       

     

       15
       -
       (* Identity *)

     

       16
       -
       module Identity = Jmap_identity

     

       17
       -
       

     

       18
       -
       (* Email Submission *)

     

       19
       -
       module Submission = Jmap_submission

     

       20
       -
       

     

       21
       -
       (* Vacation Response *)

     

       22
       -
       module Vacation = Jmap_vacation

     

       23
       -
       

     

       24
       -
       (* Capability URI for JMAP Mail. *)

     

       25
       -
       let capability_mail = "urn:ietf:params:jmap:mail"

     

       26
       -
       

     

       27
       -
       (* Capability URI for JMAP Submission. *)

     

       28
       -
       let capability_submission = "urn:ietf:params:jmap:submission"

     

       29
       -
       

     

       30
       -
       (* Capability URI for JMAP Vacation Response. *)

     

       31
       -
       let capability_vacationresponse = "urn:ietf:params:jmap:vacationresponse"

     

       32
       -
       

     

       33
       -
       (* Type name for EmailDelivery push notifications. *)

     

       34
       -
       let push_event_type_email_delivery = "EmailDelivery"

     

       35
       -
       

     

       36
       -
       (* JMAP keywords corresponding to IMAP system flags. *)

     

       37
       -
       let keyword_draft = "$draft"

     

       38
       -
       let keyword_seen = "$seen"

     

       39
       -
       let keyword_flagged = "$flagged"

     

       40
       -
       let keyword_answered = "$answered"

     

       41
       -
       

     

       42
       -
       (* Common JMAP keywords from RFC 5788. *)

     

       43
       -
       let keyword_forwarded = "$forwarded"

     

       44
       -
       let keyword_phishing = "$phishing"

     

       45
       -
       let keyword_junk = "$junk"

     

       46
       -
       let keyword_notjunk = "$notjunk"

     

       47
       -
       

     

       48
       -
       (* Functions to manipulate email flags/keywords *)

     

       49
       -
       module Keyword_ops = struct

     

       50
       -
         let add email keyword =

     

       51
       -
           match Types.Email.keywords email with

     

       52
       -
           | None -> 

     

       53
       -
               Types.Email.create 

     

       54
       -
                 ?id:(Types.Email.id email) 

     

       55
       -
                 ?blob_id:(Types.Email.blob_id email) 

     

       56
       -
                 ?thread_id:(Types.Email.thread_id email) 

     

       57
       -
                 ?mailbox_ids:(Types.Email.mailbox_ids email) 

     

       58
       -
                 ~keywords:(Types.Keywords.of_list [keyword])

     

       59
       -
                 ?size:(Types.Email.size email) 

     

       60
       -
                 ?received_at:(Types.Email.received_at email)

     

       61
       -
                 ?subject:(Types.Email.subject email) 

     

       62
       -
                 ?preview:(Types.Email.preview email)

     

       63
       -
                 ?from:(Types.Email.from email) 

     

       64
       -
                 ?to_:(Types.Email.to_ email) 

     

       65
       -
                 ?cc:(Types.Email.cc email)

     

       66
       -
                 ?message_id:(Types.Email.message_id email) 

     

       67
       -
                 ?has_attachment:(Types.Email.has_attachment email)

     

       68
       -
                 ?text_body:(Types.Email.text_body email) 

     

       69
       -
                 ?html_body:(Types.Email.html_body email)

     

       70
       -
                 ?attachments:(Types.Email.attachments email)

     

       71
       -
                 ()

     

       72
       -
           | Some kws -> 

     

       73
       -
               Types.Email.create 

     

       74
       -
                 ?id:(Types.Email.id email) 

     

       75
       -
                 ?blob_id:(Types.Email.blob_id email) 

     

       76
       -
                 ?thread_id:(Types.Email.thread_id email) 

     

       77
       -
                 ?mailbox_ids:(Types.Email.mailbox_ids email) 

     

       78
       -
                 ~keywords:(Types.Keywords.add kws keyword)

     

       79
       -
                 ?size:(Types.Email.size email) 

     

       80
       -
                 ?received_at:(Types.Email.received_at email)

     

       81
       -
                 ?subject:(Types.Email.subject email) 

     

       82
       -
                 ?preview:(Types.Email.preview email)

     

       83
       -
                 ?from:(Types.Email.from email) 

     

       84
       -
                 ?to_:(Types.Email.to_ email) 

     

       85
       -
                 ?cc:(Types.Email.cc email)

     

       86
       -
                 ?message_id:(Types.Email.message_id email) 

     

       87
       -
                 ?has_attachment:(Types.Email.has_attachment email)

     

       88
       -
                 ?text_body:(Types.Email.text_body email) 

     

       89
       -
                 ?html_body:(Types.Email.html_body email)

     

       90
       -
                 ?attachments:(Types.Email.attachments email)

     

       91
       -
                 ()

     

       92
       -
         

     

       93
       -
         let remove email keyword =

     

       94
       -
           match Types.Email.keywords email with

     

       95
       -
           | None -> email

     

       96
       -
           | Some kws -> 

     

       97
       -
               Types.Email.create 

     

       98
       -
                 ?id:(Types.Email.id email) 

     

       99
       -
                 ?blob_id:(Types.Email.blob_id email) 

     

       100
       -
                 ?thread_id:(Types.Email.thread_id email) 

     

       101
       -
                 ?mailbox_ids:(Types.Email.mailbox_ids email) 

     

       102
       -
                 ~keywords:(Types.Keywords.remove kws keyword)

     

       103
       -
                 ?size:(Types.Email.size email) 

     

       104
       -
                 ?received_at:(Types.Email.received_at email)

     

       105
       -
                 ?subject:(Types.Email.subject email) 

     

       106
       -
                 ?preview:(Types.Email.preview email)

     

       107
       -
                 ?from:(Types.Email.from email) 

     

       108
       -
                 ?to_:(Types.Email.to_ email) 

     

       109
       -
                 ?cc:(Types.Email.cc email)

     

       110
       -
                 ?message_id:(Types.Email.message_id email) 

     

       111
       -
                 ?has_attachment:(Types.Email.has_attachment email)

     

       112
       -
                 ?text_body:(Types.Email.text_body email) 

     

       113
       -
                 ?html_body:(Types.Email.html_body email)

     

       114
       -
                 ?attachments:(Types.Email.attachments email)

     

       115
       -
                 ()

     

       116
       -
         

     

       117
       -
         let mark_as_seen email = add email Types.Keywords.Seen

     

       118
       -
         

     

       119
       -
         let mark_as_unseen email = remove email Types.Keywords.Seen

     

       120
       -
         

     

       121
       -
         let mark_as_flagged email = add email Types.Keywords.Flagged

     

       122
       -
         

     

       123
       -
         let unmark_flagged email = remove email Types.Keywords.Flagged

     

       124
       -
         

     

       125
       -
         let mark_as_draft email = add email Types.Keywords.Draft

     

       126
       -
         

     

       127
       -
         let unmark_draft email = remove email Types.Keywords.Draft

     

       128
       -
         

     

       129
       -
         let mark_as_answered email = add email Types.Keywords.Answered

     

       130
       -
         

     

       131
       -
         let unmark_answered email = remove email Types.Keywords.Answered

     

       132
       -
         

     

       133
       -
         let mark_as_forwarded email = add email Types.Keywords.Forwarded

     

       134
       -
         

     

       135
       -
         let mark_as_junk email = add email Types.Keywords.Junk

     

       136
       -
         

     

       137
       -
         let mark_as_not_junk email = add email Types.Keywords.NotJunk

     

       138
       -
         

     

       139
       -
         let mark_as_phishing email = add email Types.Keywords.Phishing

     

       140
       -
         

     

       141
       -
         let add_custom email custom_kw = 

     

       142
       -
           add email (Types.Keywords.Custom custom_kw)

     

       143
       -
         

     

       144
       -
         let remove_custom email custom_kw = 

     

       145
       -
           remove email (Types.Keywords.Custom custom_kw)

     

       146
       -
       

     

       147
       -
         let add_keyword_patch keyword =

     

       148
       -
           [("keywords/" ^ Types.Keywords.to_string keyword, `Bool true)]

     

       149
       -
       

     

       150
       -
         let remove_keyword_patch keyword =

     

       151
       -
           [("keywords/" ^ Types.Keywords.to_string keyword, `Null)]

     

       152
       -
       

     

       153
       -
         let mark_seen_patch () =

     

       154
       -
           add_keyword_patch Types.Keywords.Seen

     

       155
       -
       

     

       156
       -
         let mark_unseen_patch () =

     

       157
       -
           remove_keyword_patch Types.Keywords.Seen

     

       158
       -
       end

     

       159
       -
       

     

       160
       -
       (* Conversion functions for JMAP/IMAP compatibility *)

     

       161
       -
       module Conversion = struct

     

       162
       -
         let keyword_to_imap_flag = function

     

       163
       -
           | Types.Keywords.Draft -> "\\Draft"

     

       164
       -
           | Types.Keywords.Seen -> "\\Seen"

     

       165
       -
           | Types.Keywords.Flagged -> "\\Flagged"

     

       166
       -
           | Types.Keywords.Answered -> "\\Answered"

     

       167
       -
           | Types.Keywords.Forwarded -> "$Forwarded"

     

       168
       -
           | Types.Keywords.Phishing -> "$Phishing"

     

       169
       -
           | Types.Keywords.Junk -> "$Junk"

     

       170
       -
           | Types.Keywords.NotJunk -> "$NotJunk"

     

       171
       -
           | Types.Keywords.Custom c -> c

     

       172
       -
         

     

       173
       -
         let imap_flag_to_keyword = function

     

       174
       -
           | "\\Draft" -> Types.Keywords.Draft

     

       175
       -
           | "\\Seen" -> Types.Keywords.Seen

     

       176
       -
           | "\\Flagged" -> Types.Keywords.Flagged

     

       177
       -
           | "\\Answered" -> Types.Keywords.Answered

     

       178
       -
           | "$Forwarded" -> Types.Keywords.Forwarded

     

       179
       -
           | "$Phishing" -> Types.Keywords.Phishing

     

       180
       -
           | "$Junk" -> Types.Keywords.Junk

     

       181
       -
           | "$NotJunk" -> Types.Keywords.NotJunk

     

       182
       -
           | c -> Types.Keywords.Custom c

     

       183
       -
         

     

       184
       -
         let is_valid_custom_keyword s =

     

       185
       -
           String.length s > 0 && s.[0] <> '$' &&

     

       186
       -
           String.for_all (fun c -> 

     

       187
       -
             (c >= 'a' && c <= 'z') || 

     

       188
       -
             (c >= 'A' && c <= 'Z') || 

     

       189
       -
             (c >= '0' && c <= '9') || 

     

       190
       -
             c = '-' || c = '_') s

     

       191
       -
         

     

       192
       -
         let keyword_to_string = Types.Keywords.to_string

     

       193
       -
         

     

       194
       -
         let string_to_keyword = Types.Keywords.of_string

     

       195
       -
       end

     

       196
       -
       

     

       197
       -
       (* Email query filter helpers *)

     

       198
       -
       module Email_filter = struct

     

       199
       -
         let in_mailbox mailbox_id =

     

       200
       -
           let prop_name = "mailboxIds/" ^ mailbox_id in

     

       201
       -
           Jmap.Methods.Filter.property_equals prop_name (`Bool true)

     

       202
       -
         

     

       203
       -
         let has_keyword keyword =

     

       204
       -
           let prop_name = "keywords/" ^ Types.Keywords.to_string keyword in

     

       205
       -
           Jmap.Methods.Filter.property_equals prop_name (`Bool true)

     

       206
       -
         

     

       207
       -
         let not_has_keyword keyword =

     

       208
       -
           let prop_name = "keywords/" ^ Types.Keywords.to_string keyword in

     

       209
       -
           Jmap.Methods.Filter.property_equals prop_name (`Bool false)

     

       210
       -
         

     

       211
       -
         let unread () =

     

       212
       -
           not_has_keyword Types.Keywords.Seen

     

       213
       -
         

     

       214
       -
         let subject subject_text =

     

       215
       -
           Jmap.Methods.Filter.text_contains "subject" subject_text

     

       216
       -
         

     

       217
       -
         let from email =

     

       218
       -
           Jmap.Methods.Filter.text_contains "from" email

     

       219
       -
         

     

       220
       -
         let to_ email =

     

       221
       -
           Jmap.Methods.Filter.text_contains "to" email

     

       222
       -
         

     

       223
       -
         let has_attachment () =

     

       224
       -
           Jmap.Methods.Filter.property_equals "hasAttachment" (`Bool true)

     

       225
       -
         

     

       226
       -
         let before date =

     

       227
       -
           Jmap.Methods.Filter.property_lt "receivedAt" (`Float date)

     

       228
       -
         

     

       229
       -
         let after date =

     

       230
       -
           Jmap.Methods.Filter.property_gt "receivedAt" (`Float date)

     

       231
       -
         

     

       232
       -
         let larger_than size =

     

       233
       -
           Jmap.Methods.Filter.property_gt "size" (`Int size)

     

       234
       -
         

     

       235
       -
         let smaller_than size =

     

       236
       -
           Jmap.Methods.Filter.property_lt "size" (`Int size)

     

       237
       -
       end

     

       238
       -
       

     

       239
       -
       (* Common email sorting comparators *)

     

       240
       -
       module Email_sort = struct

     

       241
       -
         let received_newest_first () =

     

       242
       -
           Jmap.Methods.Comparator.v 

     

       243
       -
             ~property:"receivedAt" 

     

       244
       -
             ~is_ascending:false

     

       245
       -
             ()

     

       246
       -
         

     

       247
       -
         let received_oldest_first () =

     

       248
       -
           Jmap.Methods.Comparator.v 

     

       249
       -
             ~property:"receivedAt" 

     

       250
       -
             ~is_ascending:true

     

       251
       -
             ()

     

       252
       -
         

     

       253
       -
         let sent_newest_first () =

     

       254
       -
           Jmap.Methods.Comparator.v 

     

       255
       -
             ~property:"sentAt" 

     

       256
       -
             ~is_ascending:false

     

       257
       -
             ()

     

       258
       -
         

     

       259
       -
         let sent_oldest_first () =

     

       260
       -
           Jmap.Methods.Comparator.v 

     

       261
       -
             ~property:"sentAt" 

     

       262
       -
             ~is_ascending:true

     

       263
       -
             ()

     

       264
       -
         

     

       265
       -
         let subject_asc () =

     

       266
       -
           Jmap.Methods.Comparator.v 

     

       267
       -
             ~property:"subject" 

     

       268
       -
             ~is_ascending:true

     

       269
       -
             ()

     

       270
       -
         

     

       271
       -
         let subject_desc () =

     

       272
       -
           Jmap.Methods.Comparator.v 

     

       273
       -
             ~property:"subject" 

     

       274
       -
             ~is_ascending:false

     

       275
       -
             ()

     

       276
       -
         

     

       277
       -
         let size_largest_first () =

     

       278
       -
           Jmap.Methods.Comparator.v 

     

       279
       -
             ~property:"size" 

     

       280
       -
             ~is_ascending:false

     

       281
       -
             ()

     

       282
       -
         

     

       283
       -
         let size_smallest_first () =

     

       284
       -
           Jmap.Methods.Comparator.v 

     

       285
       -
             ~property:"size" 

     

       286
       -
             ~is_ascending:true

     

       287
       -
             ()

     

       288
       -
         

     

       289
       -
         let from_asc () =

     

       290
       -
           Jmap.Methods.Comparator.v 

     

       291
       -
             ~property:"from" 

     

       292
       -
             ~is_ascending:true

     

       293
       -
             ()

     

       294
       -
         

     

       295
       -
         let from_desc () =

     

       296
       -
           Jmap.Methods.Comparator.v 

     

       297
       -
             ~property:"from" 

     

       298
       -
             ~is_ascending:false

     

       299
       -
             ()

     

       300
       -
       end

-405

jmap-email/jmap_email_types.ml

···

       1
       -
       (* Common types for JMAP Mail (RFC 8621). *)

     

       2
       -
       

     

       3
       -
       open Jmap.Types

     

       4
       -
       

     

       5
       -
       (* Represents an email address with an optional name. *)

     

       6
       -
       module Email_address = struct

     

       7
       -
         type t = {

     

       8
       -
           name: string option;

     

       9
       -
           email: string;

     

       10
       -
         }

     

       11
       -
       

     

       12
       -
         let name t = t.name

     

       13
       -
         let email t = t.email

     

       14
       -
         

     

       15
       -
         let v ?name ~email () = { name; email }

     

       16
       -
       end

     

       17
       -
       

     

       18
       -
       (* Represents a group of email addresses. *)

     

       19
       -
       module Email_address_group = struct

     

       20
       -
         type t = {

     

       21
       -
           name: string option;

     

       22
       -
           addresses: Email_address.t list;

     

       23
       -
         }

     

       24
       -
         

     

       25
       -
         let name t = t.name

     

       26
       -
         let addresses t = t.addresses

     

       27
       -
         

     

       28
       -
         let v ?name ~addresses () = { name; addresses }

     

       29
       -
       end

     

       30
       -
       

     

       31
       -
       (* Represents a header field (name and raw value). *)

     

       32
       -
       module Email_header = struct

     

       33
       -
         type t = {

     

       34
       -
           name: string;

     

       35
       -
           value: string;

     

       36
       -
         }

     

       37
       -
         

     

       38
       -
         let name t = t.name

     

       39
       -
         let value t = t.value

     

       40
       -
         

     

       41
       -
         let v ~name ~value () = { name; value }

     

       42
       -
       end

     

       43
       -
       

     

       44
       -
       (* Represents a body part within an Email's MIME structure. *)

     

       45
       -
       module Email_body_part = struct

     

       46
       -
         type t = {

     

       47
       -
           id: string option;

     

       48
       -
           blob_id: id option;

     

       49
       -
           size: uint;

     

       50
       -
           headers: Email_header.t list;

     

       51
       -
           name: string option;

     

       52
       -
           mime_type: string;

     

       53
       -
           charset: string option;

     

       54
       -
           disposition: string option;

     

       55
       -
           cid: string option;

     

       56
       -
           language: string list option;

     

       57
       -
           location: string option;

     

       58
       -
           sub_parts: t list option;

     

       59
       -
           other_headers: Yojson.Safe.t string_map;

     

       60
       -
         }

     

       61
       -
         

     

       62
       -
         let id t = t.id

     

       63
       -
         let blob_id t = t.blob_id

     

       64
       -
         let size t = t.size

     

       65
       -
         let headers t = t.headers

     

       66
       -
         let name t = t.name

     

       67
       -
         let mime_type t = t.mime_type

     

       68
       -
         let charset t = t.charset

     

       69
       -
         let disposition t = t.disposition

     

       70
       -
         let cid t = t.cid

     

       71
       -
         let language t = t.language

     

       72
       -
         let location t = t.location

     

       73
       -
         let sub_parts t = t.sub_parts

     

       74
       -
         let other_headers t = t.other_headers

     

       75
       -
         

     

       76
       -
         let v ?id ?blob_id ~size ~headers ?name ~mime_type ?charset

     

       77
       -
             ?disposition ?cid ?language ?location ?sub_parts

     

       78
       -
             ?(other_headers=Hashtbl.create 0) () =

     

       79
       -
           { id; blob_id; size; headers; name; mime_type; charset;

     

       80
       -
             disposition; cid; language; location; sub_parts; other_headers }

     

       81
       -
       end

     

       82
       -
       

     

       83
       -
       (* Represents the decoded value of a text body part. *)

     

       84
       -
       module Email_body_value = struct

     

       85
       -
         type t = {

     

       86
       -
           value: string;

     

       87
       -
           has_encoding_problem: bool;

     

       88
       -
           is_truncated: bool;

     

       89
       -
         }

     

       90
       -
         

     

       91
       -
         let value t = t.value

     

       92
       -
         let has_encoding_problem t = t.has_encoding_problem

     

       93
       -
         let is_truncated t = t.is_truncated

     

       94
       -
         

     

       95
       -
         let v ~value ?(encoding_problem=false) ?(truncated=false) () =

     

       96
       -
           { value; has_encoding_problem = encoding_problem; is_truncated = truncated }

     

       97
       -
       end

     

       98
       -
       

     

       99
       -
       (* Type to represent email message flags/keywords. *)

     

       100
       -
       module Keywords = struct

     

       101
       -
         type keyword =

     

       102
       -
           | Draft      (* "$draft": The Email is a draft the user is composing *)

     

       103
       -
           | Seen       (* "$seen": The Email has been read *)

     

       104
       -
           | Flagged    (* "$flagged": The Email has been flagged for urgent/special attention *)

     

       105
       -
           | Answered   (* "$answered": The Email has been replied to *)

     

       106
       -
           

     

       107
       -
           (* Common extension keywords from RFC 5788 *)

     

       108
       -
           | Forwarded  (* "$forwarded": The Email has been forwarded *)

     

       109
       -
           | Phishing   (* "$phishing": The Email is likely to be phishing *)

     

       110
       -
           | Junk       (* "$junk": The Email is spam/junk *)

     

       111
       -
           | NotJunk    (* "$notjunk": The Email is explicitly marked as not spam/junk *)

     

       112
       -
           | Custom of string  (* Arbitrary user-defined keyword *)

     

       113
       -
       

     

       114
       -
         type t = keyword list

     

       115
       -
       

     

       116
       -
         let is_draft keywords =

     

       117
       -
           List.exists (function Draft -> true | _ -> false) keywords

     

       118
       -
         

     

       119
       -
         let is_seen keywords =

     

       120
       -
           List.exists (function Seen -> true | _ -> false) keywords

     

       121
       -
         

     

       122
       -
         let is_unread keywords =

     

       123
       -
           not (is_seen keywords || is_draft keywords)

     

       124
       -
         

     

       125
       -
         let is_flagged keywords =

     

       126
       -
           List.exists (function Flagged -> true | _ -> false) keywords

     

       127
       -
         

     

       128
       -
         let is_answered keywords =

     

       129
       -
           List.exists (function Answered -> true | _ -> false) keywords

     

       130
       -
         

     

       131
       -
         let is_forwarded keywords =

     

       132
       -
           List.exists (function Forwarded -> true | _ -> false) keywords

     

       133
       -
         

     

       134
       -
         let is_phishing keywords =

     

       135
       -
           List.exists (function Phishing -> true | _ -> false) keywords

     

       136
       -
         

     

       137
       -
         let is_junk keywords =

     

       138
       -
           List.exists (function Junk -> true | _ -> false) keywords

     

       139
       -
         

     

       140
       -
         let is_not_junk keywords =

     

       141
       -
           List.exists (function NotJunk -> true | _ -> false) keywords

     

       142
       -
         

     

       143
       -
         let has_keyword keywords custom_keyword =

     

       144
       -
           List.exists (function Custom k when k = custom_keyword -> true | _ -> false) keywords

     

       145
       -
         

     

       146
       -
         let custom_keywords keywords =

     

       147
       -
           List.fold_left (fun acc kw ->

     

       148
       -
             match kw with

     

       149
       -
             | Custom k -> k :: acc

     

       150
       -
             | _ -> acc

     

       151
       -
           ) [] keywords

     

       152
       -
         

     

       153
       -
         let add keywords keyword =

     

       154
       -
           if List.exists (fun k -> k = keyword) keywords then

     

       155
       -
             keywords

     

       156
       -
           else

     

       157
       -
             keyword :: keywords

     

       158
       -
         

     

       159
       -
         let remove keywords keyword =

     

       160
       -
           List.filter (fun k -> k <> keyword) keywords

     

       161
       -
         

     

       162
       -
         let empty () = []

     

       163
       -
         

     

       164
       -
         let of_list keywords = keywords

     

       165
       -
         

     

       166
       -
         let to_string = function

     

       167
       -
           | Draft -> "$draft"

     

       168
       -
           | Seen -> "$seen"

     

       169
       -
           | Flagged -> "$flagged"

     

       170
       -
           | Answered -> "$answered"

     

       171
       -
           | Forwarded -> "$forwarded"

     

       172
       -
           | Phishing -> "$phishing"

     

       173
       -
           | Junk -> "$junk"

     

       174
       -
           | NotJunk -> "$notjunk"

     

       175
       -
           | Custom k -> k

     

       176
       -
         

     

       177
       -
         let of_string s =

     

       178
       -
           match s with

     

       179
       -
           | "$draft" -> Draft

     

       180
       -
           | "$seen" -> Seen

     

       181
       -
           | "$flagged" -> Flagged

     

       182
       -
           | "$answered" -> Answered

     

       183
       -
           | "$forwarded" -> Forwarded

     

       184
       -
           | "$phishing" -> Phishing

     

       185
       -
           | "$junk" -> Junk

     

       186
       -
           | "$notjunk" -> NotJunk

     

       187
       -
           | k -> Custom k

     

       188
       -
         

     

       189
       -
         let to_map keywords =

     

       190
       -
           let map = Hashtbl.create (List.length keywords) in

     

       191
       -
           List.iter (fun kw ->

     

       192
       -
             Hashtbl.add map (to_string kw) true

     

       193
       -
           ) keywords;

     

       194
       -
           map

     

       195
       -
       end

     

       196
       -
       

     

       197
       -
       (* Email properties enum. *)

     

       198
       -
       type email_property =

     

       199
       -
         | Id               (* The id of the email *)

     

       200
       -
         | BlobId           (* The id of the blob containing the raw message *)

     

       201
       -
         | ThreadId         (* The id of the thread this email belongs to *)

     

       202
       -
         | MailboxIds       (* The mailboxes this email belongs to *)

     

       203
       -
         | Keywords         (* The keywords/flags for this email *)

     

       204
       -
         | Size             (* Size of the message in bytes *)

     

       205
       -
         | ReceivedAt       (* When the message was received by the server *)

     

       206
       -
         | MessageId        (* Value of the Message-ID header *)

     

       207
       -
         | InReplyTo        (* Value of the In-Reply-To header *)

     

       208
       -
         | References       (* Value of the References header *)

     

       209
       -
         | Sender           (* Value of the Sender header *)

     

       210
       -
         | From             (* Value of the From header *)

     

       211
       -
         | To               (* Value of the To header *)

     

       212
       -
         | Cc               (* Value of the Cc header *)

     

       213
       -
         | Bcc              (* Value of the Bcc header *)

     

       214
       -
         | ReplyTo          (* Value of the Reply-To header *)

     

       215
       -
         | Subject          (* Value of the Subject header *)

     

       216
       -
         | SentAt           (* Value of the Date header *)

     

       217
       -
         | HasAttachment    (* Whether the email has attachments *)

     

       218
       -
         | Preview          (* Preview text of the email *)

     

       219
       -
         | BodyStructure    (* MIME structure of the email *)

     

       220
       -
         | BodyValues       (* Decoded body part values *)

     

       221
       -
         | TextBody         (* Text body parts *)

     

       222
       -
         | HtmlBody         (* HTML body parts *)

     

       223
       -
         | Attachments      (* Attachments *)

     

       224
       -
         | Header of string (* Specific header *)

     

       225
       -
         | Other of string  (* Extension property *)

     

       226
       -
       

     

       227
       -
       (* Represents an Email object. *)

     

       228
       -
       module Email = struct

     

       229
       -
         type t = {

     

       230
       -
           id: id option;

     

       231
       -
           blob_id: id option;

     

       232
       -
           thread_id: id option;

     

       233
       -
           mailbox_ids: bool id_map option;

     

       234
       -
           keywords: Keywords.t option;

     

       235
       -
           size: uint option;

     

       236
       -
           received_at: date option;

     

       237
       -
           subject: string option;

     

       238
       -
           preview: string option;

     

       239
       -
           from: Email_address.t list option;

     

       240
       -
           to_: Email_address.t list option;

     

       241
       -
           cc: Email_address.t list option;

     

       242
       -
           message_id: string list option;

     

       243
       -
           has_attachment: bool option;

     

       244
       -
           text_body: Email_body_part.t list option;

     

       245
       -
           html_body: Email_body_part.t list option;

     

       246
       -
           attachments: Email_body_part.t list option;

     

       247
       -
         }

     

       248
       -
         

     

       249
       -
         let id t = t.id

     

       250
       -
         let blob_id t = t.blob_id

     

       251
       -
         let thread_id t = t.thread_id

     

       252
       -
         let mailbox_ids t = t.mailbox_ids

     

       253
       -
         let keywords t = t.keywords

     

       254
       -
         let size t = t.size

     

       255
       -
         let received_at t = t.received_at

     

       256
       -
         let subject t = t.subject

     

       257
       -
         let preview t = t.preview

     

       258
       -
         let from t = t.from

     

       259
       -
         let to_ t = t.to_

     

       260
       -
         let cc t = t.cc

     

       261
       -
         let message_id t = t.message_id

     

       262
       -
         let has_attachment t = t.has_attachment

     

       263
       -
         let text_body t = t.text_body

     

       264
       -
         let html_body t = t.html_body

     

       265
       -
         let attachments t = t.attachments

     

       266
       -
         

     

       267
       -
         let create ?id ?blob_id ?thread_id ?mailbox_ids ?keywords ?size

     

       268
       -
             ?received_at ?subject ?preview ?from ?to_ ?cc ?message_id

     

       269
       -
             ?has_attachment ?text_body ?html_body ?attachments () =

     

       270
       -
           { id; blob_id; thread_id; mailbox_ids; keywords; size;

     

       271
       -
             received_at; subject; preview; from; to_; cc; message_id;

     

       272
       -
             has_attachment; text_body; html_body; attachments }

     

       273
       -
           

     

       274
       -
         let make_patch ?add_keywords ?remove_keywords ?add_mailboxes ?remove_mailboxes () =

     

       275
       -
           let patch = [] in

     

       276
       -
           let patch = match add_keywords with

     

       277
       -
             | Some kw -> 

     

       278
       -
                 ("keywords/", `Assoc (List.map (fun k -> 

     

       279
       -
                   (Keywords.to_string k, `Bool true)

     

       280
       -
                 ) kw)) :: patch

     

       281
       -
             | None -> patch

     

       282
       -
           in

     

       283
       -
           let patch = match remove_keywords with

     

       284
       -
             | Some kw -> 

     

       285
       -
                 List.fold_left (fun p k -> 

     

       286
       -
                   ("keywords/" ^ Keywords.to_string k, `Null) :: p

     

       287
       -
                 ) patch kw

     

       288
       -
             | None -> patch

     

       289
       -
           in

     

       290
       -
           let patch = match add_mailboxes with

     

       291
       -
             | Some mboxes -> 

     

       292
       -
                 List.fold_left (fun p mbx -> 

     

       293
       -
                   ("mailboxIds/" ^ mbx, `Bool true) :: p

     

       294
       -
                 ) patch mboxes

     

       295
       -
             | None -> patch

     

       296
       -
           in

     

       297
       -
           let patch = match remove_mailboxes with

     

       298
       -
             | Some mboxes -> 

     

       299
       -
                 List.fold_left (fun p mbx -> 

     

       300
       -
                   ("mailboxIds/" ^ mbx, `Null) :: p

     

       301
       -
                 ) patch mboxes

     

       302
       -
             | None -> patch

     

       303
       -
           in

     

       304
       -
           patch

     

       305
       -
         

     

       306
       -
         let get_id t =

     

       307
       -
           match t.id with

     

       308
       -
           | Some id -> Ok id

     

       309
       -
           | None -> Error "Email missing ID"

     

       310
       -
         

     

       311
       -
         let take_id t =

     

       312
       -
           match t.id with

     

       313
       -
           | Some id -> id

     

       314
       -
           | None -> failwith "Email missing ID"

     

       315
       -
       end

     

       316
       -
       

     

       317
       -
       (* Email import options. *)

     

       318
       -
       type email_import_options = {

     

       319
       -
         import_to_mailboxes : id list;

     

       320
       -
         import_keywords : Keywords.t option;

     

       321
       -
         import_received_at : date option;

     

       322
       -
       }

     

       323
       -
       

     

       324
       -
       (* Email copy options. *)

     

       325
       -
       type email_copy_options = {

     

       326
       -
         copy_to_account_id : id;

     

       327
       -
         copy_to_mailboxes : id list;

     

       328
       -
         copy_on_success_destroy_original : bool option;

     

       329
       -
       }

     

       330
       -
       

     

       331
       -
       (* Convert a property variant to its string representation *)

     

       332
       -
       let email_property_to_string = function

     

       333
       -
         | Id -> "id"

     

       334
       -
         | BlobId -> "blobId"

     

       335
       -
         | ThreadId -> "threadId"

     

       336
       -
         | MailboxIds -> "mailboxIds"

     

       337
       -
         | Keywords -> "keywords"

     

       338
       -
         | Size -> "size"

     

       339
       -
         | ReceivedAt -> "receivedAt"

     

       340
       -
         | MessageId -> "messageId"

     

       341
       -
         | InReplyTo -> "inReplyTo"

     

       342
       -
         | References -> "references"

     

       343
       -
         | Sender -> "sender"

     

       344
       -
         | From -> "from"

     

       345
       -
         | To -> "to"

     

       346
       -
         | Cc -> "cc"

     

       347
       -
         | Bcc -> "bcc"

     

       348
       -
         | ReplyTo -> "replyTo"

     

       349
       -
         | Subject -> "subject"

     

       350
       -
         | SentAt -> "sentAt"

     

       351
       -
         | HasAttachment -> "hasAttachment"

     

       352
       -
         | Preview -> "preview"

     

       353
       -
         | BodyStructure -> "bodyStructure"

     

       354
       -
         | BodyValues -> "bodyValues"

     

       355
       -
         | TextBody -> "textBody"

     

       356
       -
         | HtmlBody -> "htmlBody"

     

       357
       -
         | Attachments -> "attachments"

     

       358
       -
         | Header h -> "header:" ^ h

     

       359
       -
         | Other s -> s

     

       360
       -
       

     

       361
       -
       (* Parse a string into a property variant *)

     

       362
       -
       let string_to_email_property s =

     

       363
       -
         match s with

     

       364
       -
         | "id" -> Id

     

       365
       -
         | "blobId" -> BlobId

     

       366
       -
         | "threadId" -> ThreadId

     

       367
       -
         | "mailboxIds" -> MailboxIds

     

       368
       -
         | "keywords" -> Keywords

     

       369
       -
         | "size" -> Size

     

       370
       -
         | "receivedAt" -> ReceivedAt

     

       371
       -
         | "messageId" -> MessageId

     

       372
       -
         | "inReplyTo" -> InReplyTo

     

       373
       -
         | "references" -> References

     

       374
       -
         | "sender" -> Sender

     

       375
       -
         | "from" -> From

     

       376
       -
         | "to" -> To

     

       377
       -
         | "cc" -> Cc

     

       378
       -
         | "bcc" -> Bcc

     

       379
       -
         | "replyTo" -> ReplyTo

     

       380
       -
         | "subject" -> Subject

     

       381
       -
         | "sentAt" -> SentAt

     

       382
       -
         | "hasAttachment" -> HasAttachment

     

       383
       -
         | "preview" -> Preview

     

       384
       -
         | "bodyStructure" -> BodyStructure

     

       385
       -
         | "bodyValues" -> BodyValues

     

       386
       -
         | "textBody" -> TextBody

     

       387
       -
         | "htmlBody" -> HtmlBody

     

       388
       -
         | "attachments" -> Attachments

     

       389
       -
         | s when String.length s > 7 && String.sub s 0 7 = "header:" ->

     

       390
       -
             Header (String.sub s 7 (String.length s - 7))

     

       391
       -
         | s -> Other s

     

       392
       -
       

     

       393
       -
       (* Get a list of common properties useful for displaying email lists *)

     

       394
       -
       let common_email_properties = [

     

       395
       -
         Id; ThreadId; MailboxIds; Keywords; Size; ReceivedAt;

     

       396
       -
         From; Subject; Preview; HasAttachment; SentAt;

     

       397
       -
       ]

     

       398
       -
       

     

       399
       -
       (* Get a list of common properties for detailed email view *)

     

       400
       -
       let detailed_email_properties = [

     

       401
       -
         Id; ThreadId; MailboxIds; Keywords; Size; ReceivedAt;

     

       402
       -
         MessageId; InReplyTo; References; Sender; From; To; Cc;

     

       403
       -
         ReplyTo; Subject; SentAt; HasAttachment; Preview;

     

       404
       -
         TextBody; HtmlBody; Attachments;

     

       405
       -
       ]

-130

jmap-email/jmap_identity.ml

···

       1
       -
       (* JMAP Identity. *)

     

       2
       -
       

     

       3
       -
       open Jmap.Types

     

       4
       -
       open Jmap.Methods

     

       5
       -
       

     

       6
       -
       (* Identity object. *)

     

       7
       -
       type t = {

     

       8
       -
         id_value: id;

     

       9
       -
         name_value: string;

     

       10
       -
         email_value: string;

     

       11
       -
         reply_to_value: Jmap_email_types.Email_address.t list option;

     

       12
       -
         bcc_value: Jmap_email_types.Email_address.t list option;

     

       13
       -
         text_signature_value: string;

     

       14
       -
         html_signature_value: string;

     

       15
       -
         may_delete_value: bool;

     

       16
       -
       }

     

       17
       -
       

     

       18
       -
       (* Get the identity ID (immutable, server-set) *)

     

       19
       -
       let id t = t.id_value

     

       20
       -
       

     

       21
       -
       (* Get the display name (defaults to "") *)

     

       22
       -
       let name t = t.name_value

     

       23
       -
       

     

       24
       -
       (* Get the email address (immutable) *)

     

       25
       -
       let email t = t.email_value

     

       26
       -
       

     

       27
       -
       (* Get the reply-to addresses (if any) *)

     

       28
       -
       let reply_to t = t.reply_to_value

     

       29
       -
       

     

       30
       -
       (* Get the bcc addresses (if any) *)

     

       31
       -
       let bcc t = t.bcc_value

     

       32
       -
       

     

       33
       -
       (* Get the plain text signature (defaults to "") *)

     

       34
       -
       let text_signature t = t.text_signature_value

     

       35
       -
       

     

       36
       -
       (* Get the HTML signature (defaults to "") *)

     

       37
       -
       let html_signature t = t.html_signature_value

     

       38
       -
       

     

       39
       -
       (* Check if this identity may be deleted (server-set) *)

     

       40
       -
       let may_delete t = t.may_delete_value

     

       41
       -
       

     

       42
       -
       (* Create a new identity object *)

     

       43
       -
       let v ~id ?(name="") ~email ?reply_to ?bcc ?(text_signature="") ?(html_signature="") ~may_delete () = {

     

       44
       -
         id_value = id;

     

       45
       -
         name_value = name;

     

       46
       -
         email_value = email;

     

       47
       -
         reply_to_value = reply_to;

     

       48
       -
         bcc_value = bcc;

     

       49
       -
         text_signature_value = text_signature;

     

       50
       -
         html_signature_value = html_signature;

     

       51
       -
         may_delete_value = may_delete;

     

       52
       -
       }

     

       53
       -
       

     

       54
       -
       (* Types and functions for identity creation and updates *)

     

       55
       -
       module Create = struct

     

       56
       -
         type t = {

     

       57
       -
           name_value: string option;

     

       58
       -
           email_value: string;

     

       59
       -
           reply_to_value: Jmap_email_types.Email_address.t list option;

     

       60
       -
           bcc_value: Jmap_email_types.Email_address.t list option;

     

       61
       -
           text_signature_value: string option;

     

       62
       -
           html_signature_value: string option;

     

       63
       -
         }

     

       64
       -
         

     

       65
       -
         (* Get the name (if specified) *)

     

       66
       -
         let name t = t.name_value

     

       67
       -
         

     

       68
       -
         (* Get the email address *)

     

       69
       -
         let email t = t.email_value

     

       70
       -
         

     

       71
       -
         (* Get the reply-to addresses (if any) *)

     

       72
       -
         let reply_to t = t.reply_to_value

     

       73
       -
         

     

       74
       -
         (* Get the bcc addresses (if any) *)

     

       75
       -
         let bcc t = t.bcc_value

     

       76
       -
         

     

       77
       -
         (* Get the plain text signature (if specified) *)

     

       78
       -
         let text_signature t = t.text_signature_value

     

       79
       -
         

     

       80
       -
         (* Get the HTML signature (if specified) *)

     

       81
       -
         let html_signature t = t.html_signature_value

     

       82
       -
         

     

       83
       -
         (* Create a new identity creation object *)

     

       84
       -
         let v ?name ~email ?reply_to ?bcc ?text_signature ?html_signature () = {

     

       85
       -
           name_value = name;

     

       86
       -
           email_value = email;

     

       87
       -
           reply_to_value = reply_to;

     

       88
       -
           bcc_value = bcc;

     

       89
       -
           text_signature_value = text_signature;

     

       90
       -
           html_signature_value = html_signature;

     

       91
       -
         }

     

       92
       -
         

     

       93
       -
         (* Server response with info about the created identity *)

     

       94
       -
         module Response = struct

     

       95
       -
           type t = {

     

       96
       -
             id_value: id;

     

       97
       -
             may_delete_value: bool;

     

       98
       -
           }

     

       99
       -
           

     

       100
       -
           (* Get the server-assigned ID for the created identity *)

     

       101
       -
           let id t = t.id_value

     

       102
       -
           

     

       103
       -
           (* Check if this identity may be deleted *)

     

       104
       -
           let may_delete t = t.may_delete_value

     

       105
       -
           

     

       106
       -
           (* Create a new response object *)

     

       107
       -
           let v ~id ~may_delete () = {

     

       108
       -
             id_value = id;

     

       109
       -
             may_delete_value = may_delete;

     

       110
       -
           }

     

       111
       -
         end

     

       112
       -
       end

     

       113
       -
       

     

       114
       -
       (* Identity object for update.

     

       115
       -
          Patch object, specific structure not enforced here. *)

     

       116
       -
       type update = patch_object

     

       117
       -
       

     

       118
       -
       (* Server-set/computed info for updated identity.

     

       119
       -
          Contains only changed server-set props. *)

     

       120
       -
       module Update_response = struct

     

       121
       -
         (* We use the same type as main identity *)

     

       122
       -
         type identity_update = t

     

       123
       -
         type t = identity_update

     

       124
       -
         

     

       125
       -
         (* Convert to a full Identity object (contains only changed server-set props) *)

     

       126
       -
         let to_identity t = (t : t :> t)

     

       127
       -
         

     

       128
       -
         (* Create from a full Identity object *)

     

       129
       -
         let of_identity t = (t : t :> t)

     

       130
       -
       end

-282

jmap-email/jmap_mailbox.ml

···

       1
       -
       (* JMAP Mailbox. *)

     

       2
       -
       

     

       3
       -
       open Jmap.Types

     

       4
       -
       open Jmap.Methods

     

       5
       -
       

     

       6
       -
       (* Standard mailbox roles as defined in RFC 8621. *)

     

       7
       -
       type role =

     

       8
       -
         | Inbox     (* Messages in the primary inbox *)

     

       9
       -
         | Archive   (* Archived messages *)

     

       10
       -
         | Drafts    (* Draft messages being composed *)

     

       11
       -
         | Sent      (* Messages that have been sent *)

     

       12
       -
         | Trash     (* Messages that have been deleted *)

     

       13
       -
         | Junk      (* Messages determined to be spam *)

     

       14
       -
         | Important (* Messages deemed important *)

     

       15
       -
         | Other of string (* Custom or non-standard role *)

     

       16
       -
         | None      (* No specific role assigned *)

     

       17
       -
       

     

       18
       -
       (* Mailbox property identifiers. *)

     

       19
       -
       type property =

     

       20
       -
         | Id            (* The id of the mailbox *)

     

       21
       -
         | Name          (* The name of the mailbox *)

     

       22
       -
         | ParentId      (* The id of the parent mailbox *)

     

       23
       -
         | Role          (* The role of the mailbox *)

     

       24
       -
         | SortOrder     (* The sort order of the mailbox *)

     

       25
       -
         | TotalEmails   (* The total number of emails in the mailbox *)

     

       26
       -
         | UnreadEmails  (* The number of unread emails in the mailbox *)

     

       27
       -
         | TotalThreads  (* The total number of threads in the mailbox *)

     

       28
       -
         | UnreadThreads (* The number of unread threads in the mailbox *)

     

       29
       -
         | MyRights      (* The rights the user has for the mailbox *)

     

       30
       -
         | IsSubscribed  (* Whether the mailbox is subscribed to *)

     

       31
       -
         | Other of string (* Any server-specific extension properties *)

     

       32
       -
       

     

       33
       -
       (* Mailbox access rights. *)

     

       34
       -
       type mailbox_rights = {

     

       35
       -
         may_read_items : bool;

     

       36
       -
         may_add_items : bool;

     

       37
       -
         may_remove_items : bool;

     

       38
       -
         may_set_seen : bool;

     

       39
       -
         may_set_keywords : bool;

     

       40
       -
         may_create_child : bool;

     

       41
       -
         may_rename : bool;

     

       42
       -
         may_delete : bool;

     

       43
       -
         may_submit : bool;

     

       44
       -
       }

     

       45
       -
       

     

       46
       -
       (* Mailbox object. *)

     

       47
       -
       type mailbox = {

     

       48
       -
         mailbox_id : id; (* immutable, server-set *)

     

       49
       -
         name : string;

     

       50
       -
         parent_id : id option;

     

       51
       -
         role : role option;

     

       52
       -
         sort_order : uint; (* default: 0 *)

     

       53
       -
         total_emails : uint; (* server-set *)

     

       54
       -
         unread_emails : uint; (* server-set *)

     

       55
       -
         total_threads : uint; (* server-set *)

     

       56
       -
         unread_threads : uint; (* server-set *)

     

       57
       -
         my_rights : mailbox_rights; (* server-set *)

     

       58
       -
         is_subscribed : bool;

     

       59
       -
       }

     

       60
       -
       

     

       61
       -
       (* Mailbox object for creation.

     

       62
       -
          Excludes server-set fields. *)

     

       63
       -
       type mailbox_create = {

     

       64
       -
         mailbox_create_name : string;

     

       65
       -
         mailbox_create_parent_id : id option;

     

       66
       -
         mailbox_create_role : role option;

     

       67
       -
         mailbox_create_sort_order : uint option;

     

       68
       -
         mailbox_create_is_subscribed : bool option;

     

       69
       -
       }

     

       70
       -
       

     

       71
       -
       (* Mailbox object for update.

     

       72
       -
          Patch object, specific structure not enforced here. *)

     

       73
       -
       type mailbox_update = patch_object

     

       74
       -
       

     

       75
       -
       (* Server-set info for created mailbox. *)

     

       76
       -
       type mailbox_created_info = {

     

       77
       -
         mailbox_created_id : id;

     

       78
       -
         mailbox_created_role : role option; (* If default used *)

     

       79
       -
         mailbox_created_sort_order : uint; (* If default used *)

     

       80
       -
         mailbox_created_total_emails : uint;

     

       81
       -
         mailbox_created_unread_emails : uint;

     

       82
       -
         mailbox_created_total_threads : uint;

     

       83
       -
         mailbox_created_unread_threads : uint;

     

       84
       -
         mailbox_created_my_rights : mailbox_rights;

     

       85
       -
         mailbox_created_is_subscribed : bool; (* If default used *)

     

       86
       -
       }

     

       87
       -
       

     

       88
       -
       (* Server-set/computed info for updated mailbox. *)

     

       89
       -
       type mailbox_updated_info = mailbox (* Contains only changed server-set props *)

     

       90
       -
       

     

       91
       -
       (* FilterCondition for Mailbox/query. *)

     

       92
       -
       type mailbox_filter_condition = {

     

       93
       -
         filter_parent_id : id option option; (* Use option option for explicit null *)

     

       94
       -
         filter_name : string option;

     

       95
       -
         filter_role : role option option; (* Use option option for explicit null *)

     

       96
       -
         filter_has_any_role : bool option;

     

       97
       -
         filter_is_subscribed : bool option;

     

       98
       -
       }

     

       99
       -
       

     

       100
       -
       (* Role and Property Conversion Functions *)

     

       101
       -
       

     

       102
       -
       (* Role conversion utilities *)

     

       103
       -
       let role_to_string = function

     

       104
       -
         | Inbox -> "inbox"

     

       105
       -
         | Archive -> "archive" 

     

       106
       -
         | Drafts -> "drafts"

     

       107
       -
         | Sent -> "sent"

     

       108
       -
         | Trash -> "trash"

     

       109
       -
         | Junk -> "junk"

     

       110
       -
         | Important -> "important"

     

       111
       -
         | Other s -> s

     

       112
       -
         | None -> ""

     

       113
       -
       

     

       114
       -
       let string_to_role = function

     

       115
       -
         | "inbox" -> Inbox

     

       116
       -
         | "archive" -> Archive

     

       117
       -
         | "drafts" -> Drafts

     

       118
       -
         | "sent" -> Sent

     

       119
       -
         | "trash" -> Trash

     

       120
       -
         | "junk" -> Junk

     

       121
       -
         | "important" -> Important

     

       122
       -
         | "" -> None

     

       123
       -
         | s -> Other s

     

       124
       -
       

     

       125
       -
       (* Property conversion utilities *)

     

       126
       -
       let property_to_string = function

     

       127
       -
         | Id -> "id"

     

       128
       -
         | Name -> "name"

     

       129
       -
         | ParentId -> "parentId"

     

       130
       -
         | Role -> "role"

     

       131
       -
         | SortOrder -> "sortOrder"

     

       132
       -
         | TotalEmails -> "totalEmails"

     

       133
       -
         | UnreadEmails -> "unreadEmails"

     

       134
       -
         | TotalThreads -> "totalThreads"

     

       135
       -
         | UnreadThreads -> "unreadThreads"

     

       136
       -
         | MyRights -> "myRights"

     

       137
       -
         | IsSubscribed -> "isSubscribed"

     

       138
       -
         | Other s -> s

     

       139
       -
       

     

       140
       -
       let string_to_property = function

     

       141
       -
         | "id" -> Id

     

       142
       -
         | "name" -> Name

     

       143
       -
         | "parentId" -> ParentId

     

       144
       -
         | "role" -> Role

     

       145
       -
         | "sortOrder" -> SortOrder

     

       146
       -
         | "totalEmails" -> TotalEmails

     

       147
       -
         | "unreadEmails" -> UnreadEmails

     

       148
       -
         | "totalThreads" -> TotalThreads

     

       149
       -
         | "unreadThreads" -> UnreadThreads

     

       150
       -
         | "myRights" -> MyRights

     

       151
       -
         | "isSubscribed" -> IsSubscribed

     

       152
       -
         | s -> Other s

     

       153
       -
       

     

       154
       -
       (* Get a list of common properties useful for displaying mailboxes *)

     

       155
       -
       let common_properties = [

     

       156
       -
         Id; Name; ParentId; Role; 

     

       157
       -
         TotalEmails; UnreadEmails; 

     

       158
       -
         IsSubscribed

     

       159
       -
       ]

     

       160
       -
       

     

       161
       -
       (* Get a list of all standard properties *)

     

       162
       -
       let all_properties = [

     

       163
       -
         Id; Name; ParentId; Role; SortOrder;

     

       164
       -
         TotalEmails; UnreadEmails; TotalThreads; UnreadThreads;

     

       165
       -
         MyRights; IsSubscribed

     

       166
       -
       ]

     

       167
       -
       

     

       168
       -
       (* Check if a property is a count property (TotalEmails, UnreadEmails, etc.) *)

     

       169
       -
       let is_count_property = function

     

       170
       -
         | TotalEmails | UnreadEmails | TotalThreads | UnreadThreads -> true

     

       171
       -
         | _ -> false

     

       172
       -
       

     

       173
       -
       (* Mailbox Creation and Manipulation *)

     

       174
       -
       

     

       175
       -
       (* Create a set of default rights with all permissions *)

     

       176
       -
       let default_rights () = {

     

       177
       -
         may_read_items = true;

     

       178
       -
         may_add_items = true;

     

       179
       -
         may_remove_items = true;

     

       180
       -
         may_set_seen = true;

     

       181
       -
         may_set_keywords = true;

     

       182
       -
         may_create_child = true;

     

       183
       -
         may_rename = true;

     

       184
       -
         may_delete = true;

     

       185
       -
         may_submit = true;

     

       186
       -
       }

     

       187
       -
       

     

       188
       -
       (* Create a set of read-only rights *)

     

       189
       -
       let readonly_rights () = {

     

       190
       -
         may_read_items = true;

     

       191
       -
         may_add_items = false;

     

       192
       -
         may_remove_items = false;

     

       193
       -
         may_set_seen = false;

     

       194
       -
         may_set_keywords = false;

     

       195
       -
         may_create_child = false;

     

       196
       -
         may_rename = false;

     

       197
       -
         may_delete = false;

     

       198
       -
         may_submit = false;

     

       199
       -
       }

     

       200
       -
       

     

       201
       -
       (* Create a new mailbox object with minimal required fields *)

     

       202
       -
       let create ~name ?parent_id ?role ?sort_order ?is_subscribed () = {

     

       203
       -
         mailbox_create_name = name;

     

       204
       -
         mailbox_create_parent_id = parent_id;

     

       205
       -
         mailbox_create_role = role;

     

       206
       -
         mailbox_create_sort_order = sort_order;

     

       207
       -
         mailbox_create_is_subscribed = is_subscribed;

     

       208
       -
       }

     

       209
       -
       

     

       210
       -
       (* Build a patch object for updating mailbox properties *)

     

       211
       -
       let update ?name ?parent_id ?role ?sort_order ?is_subscribed () =

     

       212
       -
         let patches = [] in

     

       213
       -
         let patches = 

     

       214
       -
           match name with

     

       215
       -
           | Some new_name -> ("name", `String new_name) :: patches

     

       216
       -
           | None -> patches

     

       217
       -
         in

     

       218
       -
         let patches = 

     

       219
       -
           match parent_id with

     

       220
       -
           | Some (Some pid) -> ("parentId", `String pid) :: patches

     

       221
       -
           | Some None -> ("parentId", `Null) :: patches

     

       222
       -
           | None -> patches

     

       223
       -
         in

     

       224
       -
         let patches = 

     

       225
       -
           match role with

     

       226
       -
           | Some (Some r) -> ("role", `String (role_to_string r)) :: patches

     

       227
       -
           | Some None -> ("role", `Null) :: patches

     

       228
       -
           | None -> patches

     

       229
       -
         in

     

       230
       -
         let patches = 

     

       231
       -
           match sort_order with

     

       232
       -
           | Some order -> ("sortOrder", `Int order) :: patches

     

       233
       -
           | None -> patches

     

       234
       -
         in

     

       235
       -
         let patches = 

     

       236
       -
           match is_subscribed with

     

       237
       -
           | Some subscribed -> ("isSubscribed", `Bool subscribed) :: patches

     

       238
       -
           | None -> patches

     

       239
       -
         in

     

       240
       -
         patches

     

       241
       -
       

     

       242
       -
       (* Get the list of standard role names and their string representations *)

     

       243
       -
       let standard_role_names = [

     

       244
       -
         (Inbox, "inbox");

     

       245
       -
         (Archive, "archive");

     

       246
       -
         (Drafts, "drafts");

     

       247
       -
         (Sent, "sent");

     

       248
       -
         (Trash, "trash");

     

       249
       -
         (Junk, "junk");

     

       250
       -
         (Important, "important");

     

       251
       -
         (None, "");

     

       252
       -
       ]

     

       253
       -
       

     

       254
       -
       (* Filter Construction *)

     

       255
       -
       

     

       256
       -
       (* Create a filter to match mailboxes with a specific role *)

     

       257
       -
       let filter_has_role role =

     

       258
       -
         Filter.property_equals "role" (`String (role_to_string role))

     

       259
       -
       

     

       260
       -
       (* Create a filter to match mailboxes with no role *)

     

       261
       -
       let filter_has_no_role () =

     

       262
       -
         Filter.property_equals "role" `Null

     

       263
       -
       

     

       264
       -
       (* Create a filter to match mailboxes that are child of a given parent *)

     

       265
       -
       let filter_has_parent parent_id =

     

       266
       -
         Filter.property_equals "parentId" (`String parent_id)

     

       267
       -
       

     

       268
       -
       (* Create a filter to match mailboxes at the root level (no parent) *)

     

       269
       -
       let filter_is_root () =

     

       270
       -
         Filter.property_equals "parentId" `Null

     

       271
       -
       

     

       272
       -
       (* Create a filter to match subscribed mailboxes *)

     

       273
       -
       let filter_is_subscribed () =

     

       274
       -
         Filter.property_equals "isSubscribed" (`Bool true)

     

       275
       -
       

     

       276
       -
       (* Create a filter to match unsubscribed mailboxes *)

     

       277
       -
       let filter_is_not_subscribed () =

     

       278
       -
         Filter.property_equals "isSubscribed" (`Bool false)

     

       279
       -
       

     

       280
       -
       (* Create a filter to match mailboxes by name (using case-insensitive substring matching) *)

     

       281
       -
       let filter_name_contains name =

     

       282
       -
         Filter.text_contains "name" name

-9

jmap-email/jmap_search_snippet.ml

···

       1
       -
       (* JMAP Search Snippet. *)

     

       2
       -
       

     

       3
       -
       (* SearchSnippet object.

     

       4
       -
          Note: Does not have an 'id' property. *)

     

       5
       -
       type t = {

     

       6
       -
         email_id : Jmap.Types.id;

     

       7
       -
         subject : string option;

     

       8
       -
         preview : string option;

     

       9
       -
       }

-125

jmap-email/jmap_submission.ml

···

       1
       -
       (* JMAP Email Submission. *)

     

       2
       -
       

     

       3
       -
       open Jmap.Types

     

       4
       -
       open Jmap.Methods

     

       5
       -
       

     

       6
       -
       (* Address object for Envelope. *)

     

       7
       -
       type envelope_address = {

     

       8
       -
         env_addr_email : string;

     

       9
       -
         env_addr_parameters : Yojson.Safe.t string_map option;

     

       10
       -
       }

     

       11
       -
       

     

       12
       -
       (* Envelope object. *)

     

       13
       -
       type envelope = {

     

       14
       -
         env_mail_from : envelope_address;

     

       15
       -
         env_rcpt_to : envelope_address list;

     

       16
       -
       }

     

       17
       -
       

     

       18
       -
       (* Delivery status for a recipient. *)

     

       19
       -
       type delivery_status = {

     

       20
       -
         delivery_smtp_reply : string;

     

       21
       -
         delivery_delivered : [ `Queued | `Yes | `No | `Unknown ];

     

       22
       -
         delivery_displayed : [ `Yes | `Unknown ];

     

       23
       -
       }

     

       24
       -
       

     

       25
       -
       (* EmailSubmission object. *)

     

       26
       -
       type email_submission = {

     

       27
       -
         email_sub_id : id; (* immutable, server-set *)

     

       28
       -
         identity_id : id; (* immutable *)

     

       29
       -
         email_id : id; (* immutable *)

     

       30
       -
         thread_id : id; (* immutable, server-set *)

     

       31
       -
         envelope : envelope option; (* immutable *)

     

       32
       -
         send_at : utc_date; (* immutable, server-set *)

     

       33
       -
         undo_status : [ `Pending | `Final | `Canceled ];

     

       34
       -
         delivery_status : delivery_status string_map option; (* server-set *)

     

       35
       -
         dsn_blob_ids : id list; (* server-set *)

     

       36
       -
         mdn_blob_ids : id list; (* server-set *)

     

       37
       -
       }

     

       38
       -
       

     

       39
       -
       (* EmailSubmission object for creation.

     

       40
       -
          Excludes server-set fields. *)

     

       41
       -
       type email_submission_create = {

     

       42
       -
         email_sub_create_identity_id : id;

     

       43
       -
         email_sub_create_email_id : id;

     

       44
       -
         email_sub_create_envelope : envelope option;

     

       45
       -
       }

     

       46
       -
       

     

       47
       -
       (* EmailSubmission object for update.

     

       48
       -
          Only undoStatus can be updated (to 'canceled'). *)

     

       49
       -
       type email_submission_update = patch_object

     

       50
       -
       

     

       51
       -
       (* Server-set info for created email submission. *)

     

       52
       -
       type email_submission_created_info = {

     

       53
       -
         email_sub_created_id : id;

     

       54
       -
         email_sub_created_thread_id : id;

     

       55
       -
         email_sub_created_send_at : utc_date;

     

       56
       -
       }

     

       57
       -
       

     

       58
       -
       (* Server-set/computed info for updated email submission. *)

     

       59
       -
       type email_submission_updated_info = email_submission (* Contains only changed server-set props *)

     

       60
       -
       

     

       61
       -
       (* FilterCondition for EmailSubmission/query. *)

     

       62
       -
       type email_submission_filter_condition = {

     

       63
       -
         filter_identity_ids : id list option;

     

       64
       -
         filter_email_ids : id list option;

     

       65
       -
         filter_thread_ids : id list option;

     

       66
       -
         filter_undo_status : [ `Pending | `Final | `Canceled ] option;

     

       67
       -
         filter_before : utc_date option;

     

       68
       -
         filter_after : utc_date option;

     

       69
       -
       }

     

       70
       -
       

     

       71
       -
       (* EmailSubmission/get: Args type (specialized from ['record Get_args.t]). *)

     

       72
       -
       module Email_submission_get_args = struct

     

       73
       -
         type t = email_submission Get_args.t

     

       74
       -
       end

     

       75
       -
       

     

       76
       -
       (* EmailSubmission/get: Response type (specialized from ['record Get_response.t]). *)

     

       77
       -
       module Email_submission_get_response = struct

     

       78
       -
         type t = email_submission Get_response.t

     

       79
       -
       end

     

       80
       -
       

     

       81
       -
       (* EmailSubmission/changes: Args type (specialized from [Changes_args.t]). *)

     

       82
       -
       module Email_submission_changes_args = struct

     

       83
       -
         type t = Changes_args.t

     

       84
       -
       end

     

       85
       -
       

     

       86
       -
       (* EmailSubmission/changes: Response type (specialized from [Changes_response.t]). *)

     

       87
       -
       module Email_submission_changes_response = struct

     

       88
       -
         type t = Changes_response.t

     

       89
       -
       end

     

       90
       -
       

     

       91
       -
       (* EmailSubmission/query: Args type (specialized from [Query_args.t]). *)

     

       92
       -
       module Email_submission_query_args = struct

     

       93
       -
         type t = Query_args.t

     

       94
       -
       end

     

       95
       -
       

     

       96
       -
       (* EmailSubmission/query: Response type (specialized from [Query_response.t]). *)

     

       97
       -
       module Email_submission_query_response = struct

     

       98
       -
         type t = Query_response.t

     

       99
       -
       end

     

       100
       -
       

     

       101
       -
       (* EmailSubmission/queryChanges: Args type (specialized from [Query_changes_args.t]). *)

     

       102
       -
       module Email_submission_query_changes_args = struct

     

       103
       -
         type t = Query_changes_args.t

     

       104
       -
       end

     

       105
       -
       

     

       106
       -
       (* EmailSubmission/queryChanges: Response type (specialized from [Query_changes_response.t]). *)

     

       107
       -
       module Email_submission_query_changes_response = struct

     

       108
       -
         type t = Query_changes_response.t

     

       109
       -
       end

     

       110
       -
       

     

       111
       -
       (* EmailSubmission/set: Args type (specialized from [('c, 'u) set_args]).

     

       112
       -
          Includes onSuccess arguments. *)

     

       113
       -
       type email_submission_set_args = {

     

       114
       -
         set_account_id : id;

     

       115
       -
         set_if_in_state : string option;

     

       116
       -
         set_create : email_submission_create id_map option;

     

       117
       -
         set_update : email_submission_update id_map option;

     

       118
       -
         set_destroy : id list option;

     

       119
       -
         set_on_success_destroy_email : id list option;

     

       120
       -
       }

     

       121
       -
       

     

       122
       -
       (* EmailSubmission/set: Response type (specialized from [('c, 'u) Set_response.t]). *)

     

       123
       -
       module Email_submission_set_response = struct

     

       124
       -
         type t = (email_submission_created_info, email_submission_updated_info) Set_response.t

     

       125
       -
       end

-19

jmap-email/jmap_thread.ml

···

       1
       -
       (* JMAP Thread. *)

     

       2
       -
       

     

       3
       -
       open Jmap.Types

     

       4
       -
       

     

       5
       -
       (* Thread object. *)

     

       6
       -
       module Thread = struct

     

       7
       -
         type t = {

     

       8
       -
           id_value: id;

     

       9
       -
           email_ids_value: id list;

     

       10
       -
         }

     

       11
       -
       

     

       12
       -
         let id t = t.id_value

     

       13
       -
         let email_ids t = t.email_ids_value

     

       14
       -
         

     

       15
       -
         let v ~id ~email_ids = {

     

       16
       -
           id_value = id;

     

       17
       -
           email_ids_value = email_ids;

     

       18
       -
         }

     

       19
       -
       end

-103

jmap-email/jmap_vacation.ml

···

       1
       -
       (* JMAP Vacation Response. *)

     

       2
       -
       

     

       3
       -
       open Jmap.Types

     

       4
       -
       open Jmap.Methods

     

       5
       -
       open Jmap.Error

     

       6
       -
       

     

       7
       -
       (* VacationResponse object.

     

       8
       -
          Note: id is always "singleton". *)

     

       9
       -
       module Vacation_response = struct

     

       10
       -
         type t = {

     

       11
       -
           id_value: id;

     

       12
       -
           is_enabled_value: bool;

     

       13
       -
           from_date_value: utc_date option;

     

       14
       -
           to_date_value: utc_date option;

     

       15
       -
           subject_value: string option;

     

       16
       -
           text_body_value: string option;

     

       17
       -
           html_body_value: string option;

     

       18
       -
         }

     

       19
       -
         

     

       20
       -
         (* Id of the vacation response (immutable, server-set, MUST be "singleton") *)

     

       21
       -
         let id t = t.id_value

     

       22
       -
         let is_enabled t = t.is_enabled_value

     

       23
       -
         let from_date t = t.from_date_value

     

       24
       -
         let to_date t = t.to_date_value

     

       25
       -
         let subject t = t.subject_value

     

       26
       -
         let text_body t = t.text_body_value

     

       27
       -
         let html_body t = t.html_body_value

     

       28
       -
         

     

       29
       -
         let v ~id ~is_enabled ?from_date ?to_date ?subject ?text_body ?html_body () = {

     

       30
       -
           id_value = id;

     

       31
       -
           is_enabled_value = is_enabled;

     

       32
       -
           from_date_value = from_date;

     

       33
       -
           to_date_value = to_date;

     

       34
       -
           subject_value = subject;

     

       35
       -
           text_body_value = text_body;

     

       36
       -
           html_body_value = html_body;

     

       37
       -
         }

     

       38
       -
       end

     

       39
       -
       

     

       40
       -
       (* VacationResponse object for update.

     

       41
       -
          Patch object, specific structure not enforced here. *)

     

       42
       -
       type vacation_response_update = patch_object

     

       43
       -
       

     

       44
       -
       (* VacationResponse/get: Args type (specialized from ['record get_args]). *)

     

       45
       -
       module Vacation_response_get_args = struct

     

       46
       -
         type t = Vacation_response.t Get_args.t

     

       47
       -
         

     

       48
       -
         let v ~account_id ?ids ?properties () =

     

       49
       -
           Get_args.v ~account_id ?ids ?properties ()

     

       50
       -
       end

     

       51
       -
       

     

       52
       -
       (* VacationResponse/get: Response type (specialized from ['record get_response]). *)

     

       53
       -
       module Vacation_response_get_response = struct 

     

       54
       -
         type t = Vacation_response.t Get_response.t

     

       55
       -
         

     

       56
       -
         let v ~account_id ~state ~list ~not_found () =

     

       57
       -
           Get_response.v ~account_id ~state ~list ~not_found ()

     

       58
       -
       end

     

       59
       -
       

     

       60
       -
       (* VacationResponse/set: Args type.

     

       61
       -
          Only allows update, id must be "singleton". *)

     

       62
       -
       module Vacation_response_set_args = struct

     

       63
       -
         type t = {

     

       64
       -
           account_id_value: id;

     

       65
       -
           if_in_state_value: string option;

     

       66
       -
           update_value: vacation_response_update id_map option;

     

       67
       -
         }

     

       68
       -
         

     

       69
       -
         let account_id t = t.account_id_value

     

       70
       -
         let if_in_state t = t.if_in_state_value

     

       71
       -
         let update t = t.update_value

     

       72
       -
         

     

       73
       -
         let v ~account_id ?if_in_state ?update () = {

     

       74
       -
           account_id_value = account_id;

     

       75
       -
           if_in_state_value = if_in_state;

     

       76
       -
           update_value = update;

     

       77
       -
         }

     

       78
       -
       end

     

       79
       -
       

     

       80
       -
       (* VacationResponse/set: Response type. *)

     

       81
       -
       module Vacation_response_set_response = struct

     

       82
       -
         type t = {

     

       83
       -
           account_id_value: id;

     

       84
       -
           old_state_value: string option;

     

       85
       -
           new_state_value: string;

     

       86
       -
           updated_value: Vacation_response.t option id_map option;

     

       87
       -
           not_updated_value: Set_error.t id_map option;

     

       88
       -
         }

     

       89
       -
         

     

       90
       -
         let account_id t = t.account_id_value

     

       91
       -
         let old_state t = t.old_state_value

     

       92
       -
         let new_state t = t.new_state_value

     

       93
       -
         let updated t = t.updated_value

     

       94
       -
         let not_updated t = t.not_updated_value

     

       95
       -
         

     

       96
       -
         let v ~account_id ?old_state ~new_state ?updated ?not_updated () = {

     

       97
       -
           account_id_value = account_id;

     

       98
       -
           old_state_value = old_state;

     

       99
       -
           new_state_value = new_state;

     

       100
       -
           updated_value = updated;

     

       101
       -
           not_updated_value = not_updated;

     

       102
       -
         }

     

       103
       -
       end

-672

jmap-unix/jmap_unix.ml

···

       1
       -
       (* Unix-specific JMAP client implementation interface. *)

     

       2
       -
       

     

       3
       -
       open Jmap

     

       4
       -
       open Jmap.Types

     

       5
       -
       open Jmap.Error

     

       6
       -
       open Jmap.Session

     

       7
       -
       open Jmap.Wire

     

       8
       -
       

     

       9
       -
       (* Configuration options for a JMAP client context *)

     

       10
       -
       type client_config = {

     

       11
       -
         connect_timeout : float option;        (* Connection timeout in seconds *)

     

       12
       -
         request_timeout : float option;        (* Request timeout in seconds *)

     

       13
       -
         max_concurrent_requests : int option;  (* Maximum concurrent requests *)

     

       14
       -
         max_request_size : int option;         (* Maximum request size in bytes *)

     

       15
       -
         user_agent : string option;            (* User-Agent header value *)

     

       16
       -
         authentication_header : string option; (* Custom Authentication header name *)

     

       17
       -
       }

     

       18
       -
       

     

       19
       -
       (* Authentication method options *)

     

       20
       -
       type auth_method = 

     

       21
       -
         | Basic of string * string                  (* Basic auth with username and password *)

     

       22
       -
         | Bearer of string                          (* Bearer token auth *)

     

       23
       -
         | Custom of (string * string)               (* Custom header name and value *)

     

       24
       -
         | Session_cookie of (string * string)       (* Session cookie name and value *)

     

       25
       -
         | No_auth                                   (* No authentication *)

     

       26
       -
       

     

       27
       -
       (* The internal state of a JMAP client connection *)

     

       28
       -
       type context = {

     

       29
       -
         config: client_config;

     

       30
       -
         mutable session_url: Uri.t option;

     

       31
       -
         mutable session: Session.t option;

     

       32
       -
         mutable auth: auth_method;

     

       33
       -
       }

     

       34
       -
       

     

       35
       -
       (* Represents an active EventSource connection *)

     

       36
       -
       type event_source_connection = {

     

       37
       -
         event_url: Uri.t;

     

       38
       -
         mutable is_connected: bool;

     

       39
       -
       }

     

       40
       -
       

     

       41
       -
       (* A request builder for constructing and sending JMAP requests *)

     

       42
       -
       type request_builder = {

     

       43
       -
         ctx: context;

     

       44
       -
         mutable using: string list;

     

       45
       -
         mutable method_calls: Invocation.t list;

     

       46
       -
       }

     

       47
       -
       

     

       48
       -
       (* Create default configuration options *)

     

       49
       -
       let default_config () = {

     

       50
       -
         connect_timeout = Some 30.0;

     

       51
       -
         request_timeout = Some 300.0;

     

       52
       -
         max_concurrent_requests = Some 4;

     

       53
       -
         max_request_size = Some (1024 * 1024 * 10); (* 10 MB *)

     

       54
       -
         user_agent = Some "OCaml JMAP Unix Client/1.0";

     

       55
       -
         authentication_header = None;

     

       56
       -
       }

     

       57
       -
       

     

       58
       -
       (* Create a client context with the specified configuration *)

     

       59
       -
       let create_client ?(config = default_config ()) () = {

     

       60
       -
         config;

     

       61
       -
         session_url = None;

     

       62
       -
         session = None;

     

       63
       -
         auth = No_auth;

     

       64
       -
       }

     

       65
       -
       

     

       66
       -
       (* Mock implementation for the Unix connection *)

     

       67
       -
       let connect ctx ?session_url ?username ~host ?port ?auth_method () =

     

       68
       -
         (* In a real implementation, this would use Unix HTTP functions *)

     

       69
       -
         let auth = match auth_method with

     

       70
       -
           | Some auth -> auth

     

       71
       -
           | None -> No_auth

     

       72
       -
         in

     

       73
       -
         

     

       74
       -
         (* Store the auth method for future requests *)

     

       75
       -
         ctx.auth <- auth;

     

       76
       -
         

     

       77
       -
         (* Set session URL, either directly or after discovery *)

     

       78
       -
         let session_url = match session_url with

     

       79
       -
           | Some url -> url

     

       80
       -
           | None ->

     

       81
       -
               (* In a real implementation, this would perform RFC 8620 discovery *)

     

       82
       -
               let proto = "https" in

     

       83
       -
               let host_with_port = match port with

     

       84
       -
                 | Some p -> host ^ ":" ^ string_of_int p

     

       85
       -
                 | None -> host

     

       86
       -
               in

     

       87
       -
               Uri.of_string (proto ^ "://" ^ host_with_port ^ "/.well-known/jmap")

     

       88
       -
         in

     

       89
       -
         ctx.session_url <- Some session_url;

     

       90
       -
         

     

       91
       -
         (* Create a mock session object for this example *)

     

       92
       -
         let caps = Hashtbl.create 4 in

     

       93
       -
         Hashtbl.add caps Jmap.capability_core (`Assoc []);

     

       94
       -
         

     

       95
       -
         let accounts = Hashtbl.create 1 in

     

       96
       -
         let acct = Account.v 

     

       97
       -
           ~name:"user@example.com" 

     

       98
       -
           ~is_personal:true 

     

       99
       -
           ~is_read_only:false 

     

       100
       -
           ()

     

       101
       -
         in

     

       102
       -
         Hashtbl.add accounts "u1" acct;

     

       103
       -
         

     

       104
       -
         let primary = Hashtbl.create 1 in

     

       105
       -
         Hashtbl.add primary Jmap.capability_core "u1";

     

       106
       -
         

     

       107
       -
         let api_url = 

     

       108
       -
           Uri.of_string ("https://" ^ host ^ "/api/jmap")

     

       109
       -
         in

     

       110
       -
         

     

       111
       -
         let session = Session.v

     

       112
       -
           ~capabilities:caps

     

       113
       -
           ~accounts

     

       114
       -
           ~primary_accounts:primary

     

       115
       -
           ~username:"user@example.com"

     

       116
       -
           ~api_url

     

       117
       -
           ~download_url:(Uri.of_string ("https://" ^ host ^ "/download/{accountId}/{blobId}"))

     

       118
       -
           ~upload_url:(Uri.of_string ("https://" ^ host ^ "/upload/{accountId}"))

     

       119
       -
           ~event_source_url:(Uri.of_string ("https://" ^ host ^ "/eventsource"))

     

       120
       -
           ~state:"1"

     

       121
       -
           ()

     

       122
       -
         in

     

       123
       -
         

     

       124
       -
         ctx.session <- Some session;

     

       125
       -
         Ok (ctx, session)

     

       126
       -
       

     

       127
       -
       (* Create a request builder for constructing a JMAP request *)

     

       128
       -
       let build ctx = {

     

       129
       -
         ctx;

     

       130
       -
         using = [Jmap.capability_core]; (* Default to core capability *)

     

       131
       -
         method_calls = [];

     

       132
       -
       }

     

       133
       -
       

     

       134
       -
       (* Set the using capabilities for a request *)

     

       135
       -
       let using builder capabilities = 

     

       136
       -
         { builder with using = capabilities }

     

       137
       -
       

     

       138
       -
       (* Add a method call to a request builder *)

     

       139
       -
       let add_method_call builder name args id =

     

       140
       -
         let call = Invocation.v 

     

       141
       -
           ~method_name:name 

     

       142
       -
           ~arguments:args 

     

       143
       -
           ~method_call_id:id 

     

       144
       -
           ()

     

       145
       -
         in

     

       146
       -
         { builder with method_calls = builder.method_calls @ [call] }

     

       147
       -
       

     

       148
       -
       (* Create a reference to a previous method call result *)

     

       149
       -
       let create_reference result_of name =

     

       150
       -
         Jmap.Wire.Result_reference.v 

     

       151
       -
           ~result_of

     

       152
       -
           ~name

     

       153
       -
           ~path:"" (* In a real implementation, this would include a JSON pointer *)

     

       154
       -
           ()

     

       155
       -
       

     

       156
       -
       (* Execute a request and return the response *)

     

       157
       -
       let execute builder =

     

       158
       -
         match builder.ctx.session with

     

       159
       -
         | None -> Error (protocol_error "No active session")

     

       160
       -
         | Some session ->

     

       161
       -
             (* In a real implementation, this would create and send an HTTP request *)

     

       162
       -
             

     

       163
       -
             (* Create a mock response for this implementation *)

     

       164
       -
             let results = List.map (fun call ->

     

       165
       -
               let method_name = Invocation.method_name call in

     

       166
       -
               let call_id = Invocation.method_call_id call in

     

       167
       -
               if method_name = "Core/echo" then

     

       168
       -
                 (* Echo method implementation *)

     

       169
       -
                 Ok call

     

       170
       -
               else

     

       171
       -
                 (* For other methods, return a method error *)

     

       172
       -
                 Error (

     

       173
       -
                   Method_error.v 

     

       174
       -
                     ~description:(Method_error_description.v 

     

       175
       -
                       ~description:"Method not implemented in mock" 

     

       176
       -
                       ())

     

       177
       -
                     `ServerUnavailable,

     

       178
       -
                   "Mock implementation"

     

       179
       -
                 )

     

       180
       -
             ) builder.method_calls in

     

       181
       -
             

     

       182
       -
             let resp = Response.v

     

       183
       -
               ~method_responses:results

     

       184
       -
               ~session_state:(session |> Session.state)

     

       185
       -
               ()

     

       186
       -
             in

     

       187
       -
             Ok resp

     

       188
       -
       

     

       189
       -
       (* Perform a JMAP API request *)

     

       190
       -
       let request ctx req =

     

       191
       -
         match ctx.session_url, ctx.session with

     

       192
       -
         | None, _ -> Error (protocol_error "No session URL configured")

     

       193
       -
         | _, None -> Error (protocol_error "No active session")

     

       194
       -
         | Some url, Some session ->

     

       195
       -
             (* In a real implementation, this would serialize the request and send it *)

     

       196
       -
             

     

       197
       -
             (* Mock response implementation *)

     

       198
       -
             let method_calls = Request.method_calls req in

     

       199
       -
             let results = List.map (fun call ->

     

       200
       -
               let method_name = Invocation.method_name call in

     

       201
       -
               let call_id = Invocation.method_call_id call in

     

       202
       -
               if method_name = "Core/echo" then

     

       203
       -
                 (* Echo method implementation *)

     

       204
       -
                 Ok call

     

       205
       -
               else

     

       206
       -
                 (* For other methods, return a method error *)

     

       207
       -
                 Error (

     

       208
       -
                   Method_error.v 

     

       209
       -
                     ~description:(Method_error_description.v 

     

       210
       -
                       ~description:"Method not implemented in mock" 

     

       211
       -
                       ())

     

       212
       -
                     `ServerUnavailable,

     

       213
       -
                   "Mock implementation"

     

       214
       -
                 )

     

       215
       -
             ) method_calls in

     

       216
       -
             

     

       217
       -
             let resp = Response.v

     

       218
       -
               ~method_responses:results

     

       219
       -
               ~session_state:(session |> Session.state)

     

       220
       -
               ()

     

       221
       -
             in

     

       222
       -
             Ok resp

     

       223
       -
       

     

       224
       -
       (* Upload binary data *)

     

       225
       -
       let upload ctx ~account_id ~content_type ~data_stream =

     

       226
       -
         match ctx.session with

     

       227
       -
         | None -> Error (protocol_error "No active session")

     

       228
       -
         | Some session ->

     

       229
       -
             (* In a real implementation, would upload the data stream *)

     

       230
       -
             

     

       231
       -
             (* Mock success response *)

     

       232
       -
             let response = Jmap.Binary.Upload_response.v

     

       233
       -
               ~account_id

     

       234
       -
               ~blob_id:"b123456"

     

       235
       -
               ~type_:content_type

     

       236
       -
               ~size:1024 (* Mock size *)

     

       237
       -
               ()

     

       238
       -
             in

     

       239
       -
             Ok response

     

       240
       -
       

     

       241
       -
       (* Download binary data *)

     

       242
       -
       let download ctx ~account_id ~blob_id ?content_type ?name =

     

       243
       -
         match ctx.session with

     

       244
       -
         | None -> Error (protocol_error "No active session")

     

       245
       -
         | Some session ->

     

       246
       -
             (* In a real implementation, would download the data and return a stream *)

     

       247
       -
             

     

       248
       -
             (* Mock data stream - in real code, this would be read from the HTTP response *)

     

       249
       -
             let mock_data = "This is mock downloaded data for blob " ^ blob_id in

     

       250
       -
             let seq = Seq.cons mock_data Seq.empty in

     

       251
       -
             Ok seq

     

       252
       -
       

     

       253
       -
       (* Copy blobs between accounts *)

     

       254
       -
       let copy_blobs ctx ~from_account_id ~account_id ~blob_ids =

     

       255
       -
         match ctx.session with

     

       256
       -
         | None -> Error (protocol_error "No active session")

     

       257
       -
         | Some session ->

     

       258
       -
             (* In a real implementation, would perform server-side copy *)

     

       259
       -
             

     

       260
       -
             (* Mock success response with first blob copied and second failed *)

     

       261
       -
             let copied = Hashtbl.create 1 in

     

       262
       -
             Hashtbl.add copied (List.hd blob_ids) "b999999";

     

       263
       -
             

     

       264
       -
             let response = Jmap.Binary.Blob_copy_response.v

     

       265
       -
               ~from_account_id

     

       266
       -
               ~account_id

     

       267
       -
               ~copied

     

       268
       -
               ()

     

       269
       -
             in

     

       270
       -
             Ok response

     

       271
       -
             

     

       272
       -
       (* Connect to the EventSource for push notifications *)

     

       273
       -
       let connect_event_source ctx ?types ?close_after ?ping =

     

       274
       -
         match ctx.session with

     

       275
       -
         | None -> Error (protocol_error "No active session")

     

       276
       -
         | Some session ->

     

       277
       -
             (* In a real implementation, would connect to EventSource URL *)

     

       278
       -
             

     

       279
       -
             (* Create mock connection *)

     

       280
       -
             let event_url = Session.event_source_url session in

     

       281
       -
             let conn = { event_url; is_connected = true } in

     

       282
       -
             

     

       283
       -
             (* Create a mock event sequence *)

     

       284
       -
             let mock_state_change = 

     

       285
       -
               let changed = Hashtbl.create 1 in

     

       286
       -
               let account_id = "u1" in

     

       287
       -
               let state_map = Hashtbl.create 2 in

     

       288
       -
               Hashtbl.add state_map "Email" "s123";

     

       289
       -
               Hashtbl.add state_map "Mailbox" "s456";

     

       290
       -
               Hashtbl.add changed account_id state_map;

     

       291
       -
               

     

       292
       -
               Push.State_change.v ~changed ()

     

       293
       -
             in

     

       294
       -
             

     

       295
       -
             let ping_data = 

     

       296
       -
               Push.Event_source_ping_data.v ~interval:30 ()

     

       297
       -
             in

     

       298
       -
             

     

       299
       -
             (* Create a sequence with one state event and one ping event *)

     

       300
       -
             let events = Seq.cons (`State mock_state_change) 

     

       301
       -
                            (Seq.cons (`Ping ping_data) Seq.empty) in

     

       302
       -
             

     

       303
       -
             Ok (conn, events)

     

       304
       -
       

     

       305
       -
       (* Create a websocket connection for JMAP over WebSocket *)

     

       306
       -
       let connect_websocket ctx =

     

       307
       -
         match ctx.session with

     

       308
       -
         | None -> Error (protocol_error "No active session")

     

       309
       -
         | Some session ->

     

       310
       -
             (* In a real implementation, would connect via WebSocket *)

     

       311
       -
             

     

       312
       -
             (* Mock connection *)

     

       313
       -
             let event_url = Session.api_url session in

     

       314
       -
             let conn = { event_url; is_connected = true } in

     

       315
       -
             Ok conn

     

       316
       -
       

     

       317
       -
       (* Send a message over a websocket connection *)

     

       318
       -
       let websocket_send conn req =

     

       319
       -
         if not conn.is_connected then

     

       320
       -
           Error (protocol_error "WebSocket not connected")

     

       321
       -
         else

     

       322
       -
           (* In a real implementation, would send over WebSocket *)

     

       323
       -
           

     

       324
       -
           (* Mock response (same as request function) *)

     

       325
       -
           let method_calls = Request.method_calls req in

     

       326
       -
           let results = List.map (fun call ->

     

       327
       -
             let method_name = Invocation.method_name call in

     

       328
       -
             let call_id = Invocation.method_call_id call in

     

       329
       -
             if method_name = "Core/echo" then

     

       330
       -
               Ok call

     

       331
       -
             else

     

       332
       -
               Error (

     

       333
       -
                 Method_error.v 

     

       334
       -
                   ~description:(Method_error_description.v 

     

       335
       -
                     ~description:"Method not implemented in mock" 

     

       336
       -
                     ())

     

       337
       -
                   `ServerUnavailable,

     

       338
       -
                 "Mock implementation"

     

       339
       -
               )

     

       340
       -
           ) method_calls in

     

       341
       -
           

     

       342
       -
           let resp = Response.v

     

       343
       -
             ~method_responses:results

     

       344
       -
             ~session_state:"1"

     

       345
       -
             ()

     

       346
       -
           in

     

       347
       -
           Ok resp

     

       348
       -
       

     

       349
       -
       (* Close an EventSource or WebSocket connection *)

     

       350
       -
       let close_connection conn =

     

       351
       -
         if not conn.is_connected then

     

       352
       -
           Error (protocol_error "Connection already closed")

     

       353
       -
         else begin

     

       354
       -
           conn.is_connected <- false;

     

       355
       -
           Ok ()

     

       356
       -
         end

     

       357
       -
       

     

       358
       -
       (* Close the JMAP connection context *)

     

       359
       -
       let close ctx =

     

       360
       -
         ctx.session <- None;

     

       361
       -
         ctx.session_url <- None;

     

       362
       -
         Ok ()

     

       363
       -
       

     

       364
       -
       (* Helper functions for common tasks *)

     

       365
       -
       

     

       366
       -
       (* Helper to get a single object by ID *)

     

       367
       -
       let get_object ctx ~method_name ~account_id ~object_id ?properties =

     

       368
       -
         let properties_param = match properties with

     

       369
       -
           | Some props -> `List (List.map (fun p -> `String p) props)

     

       370
       -
           | None -> `Null

     

       371
       -
         in

     

       372
       -
         

     

       373
       -
         let args = `Assoc [

     

       374
       -
           ("accountId", `String account_id);

     

       375
       -
           ("ids", `List [`String object_id]);

     

       376
       -
           ("properties", properties_param);

     

       377
       -
         ] in

     

       378
       -
         

     

       379
       -
         let request_builder = build ctx

     

       380
       -
           |> add_method_call method_name args "r1"

     

       381
       -
         in

     

       382
       -
         

     

       383
       -
         match execute request_builder with

     

       384
       -
         | Error e -> Error e

     

       385
       -
         | Ok response ->

     

       386
       -
             (* Find the method response and extract the list with the object *)

     

       387
       -
             match response |> Response.method_responses with

     

       388
       -
             | [Ok invocation] when Invocation.method_name invocation = method_name ^ "/get" -> 

     

       389
       -
                 let args = Invocation.arguments invocation in

     

       390
       -
                 begin match Yojson.Safe.Util.member "list" args with

     

       391
       -
                 | `List [obj] -> Ok obj

     

       392
       -
                 | _ -> Error (protocol_error "Object not found or invalid response")

     

       393
       -
                 end

     

       394
       -
             | _ ->

     

       395
       -
                 Error (protocol_error "Method response not found")

     

       396
       -
       

     

       397
       -
       (* Helper to set up the connection with minimal options *)

     

       398
       -
       let quick_connect ~host ~username ~password =

     

       399
       -
         let ctx = create_client () in

     

       400
       -
         connect ctx ~host ~auth_method:(Basic(username, password)) ()

     

       401
       -
       

     

       402
       -
       (* Perform a Core/echo request to test connectivity *)

     

       403
       -
       let echo ctx ?data () =

     

       404
       -
         let data = match data with

     

       405
       -
           | Some d -> d

     

       406
       -
           | None -> `Assoc [("hello", `String "world")]

     

       407
       -
         in

     

       408
       -
         

     

       409
       -
         let request_builder = build ctx

     

       410
       -
           |> add_method_call "Core/echo" data "echo1"

     

       411
       -
         in

     

       412
       -
         

     

       413
       -
         match execute request_builder with

     

       414
       -
         | Error e -> Error e

     

       415
       -
         | Ok response ->

     

       416
       -
             (* Find the Core/echo response and extract the echoed data *)

     

       417
       -
             match response |> Response.method_responses with

     

       418
       -
             | [Ok invocation] when Invocation.method_name invocation = "Core/echo" -> 

     

       419
       -
                 Ok (Invocation.arguments invocation)

     

       420
       -
             | _ ->

     

       421
       -
                 Error (protocol_error "Echo response not found")

     

       422
       -
       

     

       423
       -
       (* High-level email operations *)

     

       424
       -
       module Email = struct

     

       425
       -
         open Jmap_email.Types

     

       426
       -
         

     

       427
       -
         (* Get an email by ID *)

     

       428
       -
         let get_email ctx ~account_id ~email_id ?properties () =

     

       429
       -
           let props = match properties with

     

       430
       -
             | Some p -> p

     

       431
       -
             | None -> List.map email_property_to_string detailed_email_properties

     

       432
       -
           in

     

       433
       -
           

     

       434
       -
           match get_object ctx ~method_name:"Email/get" ~account_id ~object_id:email_id ~properties:props with

     

       435
       -
           | Error e -> Error e

     

       436
       -
           | Ok json ->

     

       437
       -
               (* In a real implementation, would parse the JSON into an Email.t structure *)

     

       438
       -
               let mock_email = Email.create

     

       439
       -
                 ~id:email_id

     

       440
       -
                 ~thread_id:"t12345"

     

       441
       -
                 ~mailbox_ids:(let h = Hashtbl.create 1 in Hashtbl.add h "inbox" true; h)

     

       442
       -
                 ~keywords:(Keywords.of_list [Keywords.Seen])

     

       443
       -
                 ~subject:"Mock Email Subject"

     

       444
       -
                 ~preview:"This is a mock email..."

     

       445
       -
                 ~from:[Email_address.v ~name:"Sender Name" ~email:"sender@example.com" ()]

     

       446
       -
                 ~to_:[Email_address.v ~email:"recipient@example.com" ()]

     

       447
       -
                 ()

     

       448
       -
               in

     

       449
       -
               Ok mock_email

     

       450
       -
         

     

       451
       -
         (* Search for emails using a filter *)

     

       452
       -
         let search_emails ctx ~account_id ~filter ?sort ?limit ?position ?properties () =

     

       453
       -
           (* Create the query args *)

     

       454
       -
           let args = `Assoc [

     

       455
       -
             ("accountId", `String account_id);

     

       456
       -
             ("filter", Jmap.Methods.Filter.to_json filter);

     

       457
       -
             ("sort", match sort with

     

       458
       -
               | Some s -> `List [] (* Would convert sort params *)

     

       459
       -
               | None -> `List [`Assoc [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);

     

       460
       -
             ("limit", match limit with

     

       461
       -
               | Some l -> `Int l

     

       462
       -
               | None -> `Int 20);

     

       463
       -
             ("position", match position with

     

       464
       -
               | Some p -> `Int p

     

       465
       -
               | None -> `Int 0);

     

       466
       -
           ] in

     

       467
       -
           

     

       468
       -
           let request_builder = build ctx

     

       469
       -
             |> add_method_call "Email/query" args "q1"

     

       470
       -
           in

     

       471
       -
           

     

       472
       -
           (* If properties were provided, add a Email/get method call as well *)

     

       473
       -
           let request_builder = match properties with

     

       474
       -
             | Some _ -> 

     

       475
       -
                 let get_args = `Assoc [

     

       476
       -
                   ("accountId", `String account_id);

     

       477
       -
                   ("#ids", `Assoc [

     

       478
       -
                     ("resultOf", `String "q1");

     

       479
       -
                     ("name", `String "Email/query");

     

       480
       -
                     ("path", `String "/ids")

     

       481
       -
                   ]);

     

       482
       -
                   ("properties", match properties with

     

       483
       -
                     | Some p -> `List (List.map (fun prop -> `String prop) p)

     

       484
       -
                     | None -> `Null);

     

       485
       -
                 ] in

     

       486
       -
                 add_method_call request_builder "Email/get" get_args "g1"

     

       487
       -
             | None -> request_builder

     

       488
       -
           in

     

       489
       -
           

     

       490
       -
           match execute request_builder with

     

       491
       -
           | Error e -> Error e

     

       492
       -
           | Ok response ->

     

       493
       -
               (* Find the query response and extract the IDs *)

     

       494
       -
               match Response.method_responses response with

     

       495
       -
               | [Ok q_inv; Ok g_inv] 

     

       496
       -
                 when Invocation.method_name q_inv = "Email/query" 

     

       497
       -
                 && Invocation.method_name g_inv = "Email/get" ->

     

       498
       -
                   

     

       499
       -
                   (* Extract IDs from query response *)

     

       500
       -
                   let q_args = Invocation.arguments q_inv in

     

       501
       -
                   let ids = match Yojson.Safe.Util.member "ids" q_args with

     

       502
       -
                     | `List l -> List.map Yojson.Safe.Util.to_string l

     

       503
       -
                     | _ -> []

     

       504
       -
                   in

     

       505
       -
                   

     

       506
       -
                   (* Extract emails from get response *)

     

       507
       -
                   let g_args = Invocation.arguments g_inv in

     

       508
       -
                   (* In a real implementation, would parse each email in the list *)

     

       509
       -
                   let emails = List.map (fun id ->

     

       510
       -
                     Email.create

     

       511
       -
                       ~id

     

       512
       -
                       ~thread_id:("t" ^ id)

     

       513
       -
                       ~subject:(Printf.sprintf "Mock Email %s" id)

     

       514
       -
                       ()

     

       515
       -
                   ) ids in

     

       516
       -
                   

     

       517
       -
                   Ok (ids, Some emails)

     

       518
       -
                   

     

       519
       -
               | [Ok q_inv] when Invocation.method_name q_inv = "Email/query" ->

     

       520
       -
                   (* If only query was performed (no properties requested) *)

     

       521
       -
                   let q_args = Invocation.arguments q_inv in

     

       522
       -
                   let ids = match Yojson.Safe.Util.member "ids" q_args with

     

       523
       -
                     | `List l -> List.map Yojson.Safe.Util.to_string l

     

       524
       -
                     | _ -> []

     

       525
       -
                   in

     

       526
       -
                   

     

       527
       -
                   Ok (ids, None)

     

       528
       -
                   

     

       529
       -
               | _ ->

     

       530
       -
                   Error (protocol_error "Query response not found")

     

       531
       -
         

     

       532
       -
         (* Mark multiple emails with a keyword *)

     

       533
       -
         let mark_emails ctx ~account_id ~email_ids ~keyword () =

     

       534
       -
           (* Create the set args with a patch to add the keyword *)

     

       535
       -
           let keyword_patch = Jmap_email.Keyword_ops.add_keyword_patch keyword in

     

       536
       -
           

     

       537
       -
           (* Create patches map for each email *)

     

       538
       -
           let update = Hashtbl.create (List.length email_ids) in

     

       539
       -
           List.iter (fun id ->

     

       540
       -
             Hashtbl.add update id keyword_patch

     

       541
       -
           ) email_ids;

     

       542
       -
           

     

       543
       -
           let args = `Assoc [

     

       544
       -
             ("accountId", `String account_id);

     

       545
       -
             ("update", `Assoc (

     

       546
       -
               List.map (fun id ->

     

       547
       -
                 (id, `Assoc (List.map (fun (path, value) ->

     

       548
       -
                   (path, value)

     

       549
       -
                 ) keyword_patch))

     

       550
       -
               ) email_ids

     

       551
       -
             ));

     

       552
       -
           ] in

     

       553
       -
           

     

       554
       -
           let request_builder = build ctx

     

       555
       -
             |> add_method_call "Email/set" args "s1"

     

       556
       -
           in

     

       557
       -
           

     

       558
       -
           match execute request_builder with

     

       559
       -
           | Error e -> Error e

     

       560
       -
           | Ok response ->

     

       561
       -
               (* In a real implementation, would check for errors *)

     

       562
       -
               Ok ()

     

       563
       -
         

     

       564
       -
         (* Mark emails as seen/read *)

     

       565
       -
         let mark_as_seen ctx ~account_id ~email_ids () =

     

       566
       -
           mark_emails ctx ~account_id ~email_ids ~keyword:Keywords.Seen ()

     

       567
       -
         

     

       568
       -
         (* Mark emails as unseen/unread *)

     

       569
       -
         let mark_as_unseen ctx ~account_id ~email_ids () =

     

       570
       -
           let keyword_patch = Jmap_email.Keyword_ops.mark_unseen_patch () in

     

       571
       -
           

     

       572
       -
           (* Create patches map for each email *)

     

       573
       -
           let update = Hashtbl.create (List.length email_ids) in

     

       574
       -
           List.iter (fun id ->

     

       575
       -
             Hashtbl.add update id keyword_patch

     

       576
       -
           ) email_ids;

     

       577
       -
           

     

       578
       -
           let args = `Assoc [

     

       579
       -
             ("accountId", `String account_id);

     

       580
       -
             ("update", `Assoc (

     

       581
       -
               List.map (fun id ->

     

       582
       -
                 (id, `Assoc (List.map (fun (path, value) ->

     

       583
       -
                   (path, value)

     

       584
       -
                 ) keyword_patch))

     

       585
       -
               ) email_ids

     

       586
       -
             ));

     

       587
       -
           ] in

     

       588
       -
           

     

       589
       -
           let request_builder = build ctx

     

       590
       -
             |> add_method_call "Email/set" args "s1"

     

       591
       -
           in

     

       592
       -
           

     

       593
       -
           match execute request_builder with

     

       594
       -
           | Error e -> Error e

     

       595
       -
           | Ok _response -> Ok ()

     

       596
       -
         

     

       597
       -
         (* Move emails to a different mailbox *)

     

       598
       -
         let move_emails ctx ~account_id ~email_ids ~mailbox_id ?remove_from_mailboxes () =

     

       599
       -
           (* Create patch to add to destination mailbox *)

     

       600
       -
           let add_patch = [("mailboxIds/" ^ mailbox_id, `Bool true)] in

     

       601
       -
           

     

       602
       -
           (* If remove_from_mailboxes is specified, add patches to remove *)

     

       603
       -
           let remove_patch = match remove_from_mailboxes with

     

       604
       -
             | Some mailboxes -> 

     

       605
       -
                 List.map (fun mbx -> ("mailboxIds/" ^ mbx, `Null)) mailboxes

     

       606
       -
             | None -> []

     

       607
       -
           in

     

       608
       -
           

     

       609
       -
           (* Combine patches *)

     

       610
       -
           let patches = add_patch @ remove_patch in

     

       611
       -
           

     

       612
       -
           (* Create patches map for each email *)

     

       613
       -
           let update = Hashtbl.create (List.length email_ids) in

     

       614
       -
           List.iter (fun id ->

     

       615
       -
             Hashtbl.add update id patches

     

       616
       -
           ) email_ids;

     

       617
       -
           

     

       618
       -
           let args = `Assoc [

     

       619
       -
             ("accountId", `String account_id);

     

       620
       -
             ("update", `Assoc (

     

       621
       -
               List.map (fun id ->

     

       622
       -
                 (id, `Assoc (List.map (fun (path, value) ->

     

       623
       -
                   (path, value)

     

       624
       -
                 ) patches))

     

       625
       -
               ) email_ids

     

       626
       -
             ));

     

       627
       -
           ] in

     

       628
       -
           

     

       629
       -
           let request_builder = build ctx

     

       630
       -
             |> add_method_call "Email/set" args "s1"

     

       631
       -
           in

     

       632
       -
           

     

       633
       -
           match execute request_builder with

     

       634
       -
           | Error e -> Error e

     

       635
       -
           | Ok _response -> Ok ()

     

       636
       -
         

     

       637
       -
         (* Import an RFC822 message *)

     

       638
       -
         let import_email ctx ~account_id ~rfc822 ~mailbox_ids ?keywords ?received_at () =

     

       639
       -
           (* In a real implementation, would first upload the message as a blob *)

     

       640
       -
           let mock_blob_id = "b9876" in

     

       641
       -
           

     

       642
       -
           (* Create the Email/import call *)

     

       643
       -
           let args = `Assoc [

     

       644
       -
             ("accountId", `String account_id);

     

       645
       -
             ("emails", `Assoc [

     

       646
       -
               ("msg1", `Assoc [

     

       647
       -
                 ("blobId", `String mock_blob_id);

     

       648
       -
                 ("mailboxIds", `Assoc (

     

       649
       -
                   List.map (fun id -> (id, `Bool true)) mailbox_ids

     

       650
       -
                 ));

     

       651
       -
                 ("keywords", match keywords with

     

       652
       -
                   | Some kws -> 

     

       653
       -
                       `Assoc (List.map (fun k -> 

     

       654
       -
                         (Types.Keywords.to_string k, `Bool true)) kws)

     

       655
       -
                   | None -> `Null);

     

       656
       -
                 ("receivedAt", match received_at with

     

       657
       -
                   | Some d -> `String (string_of_float d) (* Would format as RFC3339 *)

     

       658
       -
                   | None -> `Null);

     

       659
       -
               ])

     

       660
       -
             ]);

     

       661
       -
           ] in

     

       662
       -
           

     

       663
       -
           let request_builder = build ctx

     

       664
       -
             |> add_method_call "Email/import" args "i1"

     

       665
       -
           in

     

       666
       -
           

     

       667
       -
           match execute request_builder with

     

       668
       -
           | Error e -> Error e

     

       669
       -
           | Ok response ->

     

       670
       -
               (* In a real implementation, would extract the created ID *)

     

       671
       -
               Ok "e12345"

     

       672
       -
       end

-45

jmap/jmap.ml

···

       1
       -
       (* JMAP Core Protocol Library Interface (RFC 8620) *)

     

       2
       -
       

     

       3
       -
       module Types = Jmap_types

     

       4
       -
       module Error = Jmap_error

     

       5
       -
       module Wire = Jmap_wire

     

       6
       -
       module Session = Jmap_session

     

       7
       -
       module Methods = Jmap_methods

     

       8
       -
       module Binary = Jmap_binary

     

       9
       -
       module Push = Jmap_push

     

       10
       -
       

     

       11
       -
       (* Capability URI for JMAP Core. *)

     

       12
       -
       let capability_core = "urn:ietf:params:jmap:core"

     

       13
       -
       

     

       14
       -
       (* Check if a session supports a given capability. *)

     

       15
       -
       let supports_capability session capability =

     

       16
       -
         let caps = Session.Session.capabilities session in

     

       17
       -
         Hashtbl.mem caps capability

     

       18
       -
       

     

       19
       -
       (* Get the primary account ID for a given capability. *)

     

       20
       -
       let get_primary_account session capability =

     

       21
       -
         let primary_accounts = Session.Session.primary_accounts session in

     

       22
       -
         match Hashtbl.find_opt primary_accounts capability with

     

       23
       -
         | Some account_id -> Ok account_id

     

       24
       -
         | None -> Error (Error.protocol_error ("No primary account for capability: " ^ capability))

     

       25
       -
       

     

       26
       -
       (* Get the download URL for a blob. *)

     

       27
       -
       let get_download_url session ~account_id ~blob_id ?name ?content_type () =

     

       28
       -
         let base_url = Session.Session.download_url session in

     

       29
       -
         let url_str = Uri.to_string base_url in

     

       30
       -
         let url_str = url_str ^ "/accounts/" ^ account_id ^ "/blobs/" ^ blob_id in

     

       31
       -
         let url = Uri.of_string url_str in

     

       32
       -
         let url = match name with

     

       33
       -
           | Some name -> Uri.add_query_param url ("name", [name])

     

       34
       -
           | None -> url

     

       35
       -
         in

     

       36
       -
         match content_type with

     

       37
       -
         | Some ct -> Uri.add_query_param url ("type", [ct])

     

       38
       -
         | None -> url

     

       39
       -
       

     

       40
       -
       (* Get the upload URL for a blob. *)

     

       41
       -
       let get_upload_url session ~account_id =

     

       42
       -
         let base_url = Session.Session.upload_url session in

     

       43
       -
         let url_str = Uri.to_string base_url in

     

       44
       -
         let url_str = url_str ^ "/accounts/" ^ account_id in

     

       45
       -
         Uri.of_string url_str

-56

jmap/jmap_binary.ml

···

       1
       -
       (* JMAP Binary Data Handling. *)

     

       2
       -
       

     

       3
       -
       open Jmap_types

     

       4
       -
       open Jmap_error

     

       5
       -
       

     

       6
       -
       (* Response from uploading binary data. *)

     

       7
       -
       module Upload_response = struct

     

       8
       -
         type t = {

     

       9
       -
           account_id: id;

     

       10
       -
           blob_id: id;

     

       11
       -
           type_: string;

     

       12
       -
           size: uint;

     

       13
       -
         }

     

       14
       -
         

     

       15
       -
         let account_id t = t.account_id

     

       16
       -
         let blob_id t = t.blob_id

     

       17
       -
         let type_ t = t.type_

     

       18
       -
         let size t = t.size

     

       19
       -
         

     

       20
       -
         let v ~account_id ~blob_id ~type_ ~size () =

     

       21
       -
           { account_id; blob_id; type_; size }

     

       22
       -
       end

     

       23
       -
       

     

       24
       -
       (* Arguments for Blob/copy. *)

     

       25
       -
       module Blob_copy_args = struct

     

       26
       -
         type t = {

     

       27
       -
           from_account_id: id;

     

       28
       -
           account_id: id;

     

       29
       -
           blob_ids: id list;

     

       30
       -
         }

     

       31
       -
         

     

       32
       -
         let from_account_id t = t.from_account_id

     

       33
       -
         let account_id t = t.account_id

     

       34
       -
         let blob_ids t = t.blob_ids

     

       35
       -
         

     

       36
       -
         let v ~from_account_id ~account_id ~blob_ids () =

     

       37
       -
           { from_account_id; account_id; blob_ids }

     

       38
       -
       end

     

       39
       -
       

     

       40
       -
       (* Response for Blob/copy. *)

     

       41
       -
       module Blob_copy_response = struct

     

       42
       -
         type t = {

     

       43
       -
           from_account_id: id;

     

       44
       -
           account_id: id;

     

       45
       -
           copied: id id_map option;

     

       46
       -
           not_copied: Set_error.t id_map option;

     

       47
       -
         }

     

       48
       -
         

     

       49
       -
         let from_account_id t = t.from_account_id

     

       50
       -
         let account_id t = t.account_id

     

       51
       -
         let copied t = t.copied

     

       52
       -
         let not_copied t = t.not_copied

     

       53
       -
         

     

       54
       -
         let v ~from_account_id ~account_id ?copied ?not_copied () =

     

       55
       -
           { from_account_id; account_id; copied; not_copied }

     

       56
       -
       end

-266

jmap/jmap_error.ml

···

       1
       -
       (* JMAP Error Types. *)

     

       2
       -
       

     

       3
       -
       open Jmap_types

     

       4
       -
       

     

       5
       -
       (* Standard Method-level error types. *)

     

       6
       -
       type method_error_type = [

     

       7
       -
         | `ServerUnavailable

     

       8
       -
         | `ServerFail

     

       9
       -
         | `ServerPartialFail

     

       10
       -
         | `UnknownMethod

     

       11
       -
         | `InvalidArguments

     

       12
       -
         | `InvalidResultReference

     

       13
       -
         | `Forbidden

     

       14
       -
         | `AccountNotFound

     

       15
       -
         | `AccountNotSupportedByMethod

     

       16
       -
         | `AccountReadOnly

     

       17
       -
         | `RequestTooLarge

     

       18
       -
         | `CannotCalculateChanges

     

       19
       -
         | `StateMismatch

     

       20
       -
         | `AnchorNotFound

     

       21
       -
         | `UnsupportedSort

     

       22
       -
         | `UnsupportedFilter

     

       23
       -
         | `TooManyChanges

     

       24
       -
         | `FromAccountNotFound

     

       25
       -
         | `FromAccountNotSupportedByMethod

     

       26
       -
         | `Other_method_error of string

     

       27
       -
       ]

     

       28
       -
       

     

       29
       -
       (* Standard SetError types. *)

     

       30
       -
       type set_error_type = [

     

       31
       -
         | `Forbidden

     

       32
       -
         | `OverQuota

     

       33
       -
         | `TooLarge

     

       34
       -
         | `RateLimit

     

       35
       -
         | `NotFound

     

       36
       -
         | `InvalidPatch

     

       37
       -
         | `WillDestroy

     

       38
       -
         | `InvalidProperties

     

       39
       -
         | `Singleton

     

       40
       -
         | `AlreadyExists (* From /copy *)

     

       41
       -
         | `MailboxHasChild (* RFC 8621 *)

     

       42
       -
         | `MailboxHasEmail (* RFC 8621 *)

     

       43
       -
         | `BlobNotFound (* RFC 8621 *)

     

       44
       -
         | `TooManyKeywords (* RFC 8621 *)

     

       45
       -
         | `TooManyMailboxes (* RFC 8621 *)

     

       46
       -
         | `InvalidEmail (* RFC 8621 *)

     

       47
       -
         | `TooManyRecipients (* RFC 8621 *)

     

       48
       -
         | `NoRecipients (* RFC 8621 *)

     

       49
       -
         | `InvalidRecipients (* RFC 8621 *)

     

       50
       -
         | `ForbiddenMailFrom (* RFC 8621 *)

     

       51
       -
         | `ForbiddenFrom (* RFC 8621 *)

     

       52
       -
         | `ForbiddenToSend (* RFC 8621 *)

     

       53
       -
         | `CannotUnsend (* RFC 8621 *)

     

       54
       -
         | `Other_set_error of string (* For future or custom errors *)

     

       55
       -
       ]

     

       56
       -
       

     

       57
       -
       (* Primary error type that can represent all JMAP errors *)

     

       58
       -
       type error =

     

       59
       -
         | Transport of string     (* Network/HTTP-level error *)

     

       60
       -
         | Parse of string         (* JSON parsing error *)

     

       61
       -
         | Protocol of string      (* JMAP protocol error *)

     

       62
       -
         | Problem of string       (* Problem Details object error *)

     

       63
       -
         | Method of method_error_type * string option (* Method error with optional description *)

     

       64
       -
         | SetItem of id * set_error_type * string option (* Error for a specific item in a /set operation *)

     

       65
       -
         | Auth of string          (* Authentication error *)

     

       66
       -
         | ServerError of string   (* Server reported an error *)

     

       67
       -
       

     

       68
       -
       (* Standard Result type for JMAP operations *)

     

       69
       -
       type 'a result = ('a, error) Result.t

     

       70
       -
       

     

       71
       -
       (* Problem details object for HTTP-level errors. *)

     

       72
       -
       module Problem_details = struct

     

       73
       -
         type t = {

     

       74
       -
           problem_type: string;

     

       75
       -
           status: int option;

     

       76
       -
           detail: string option;

     

       77
       -
           limit: string option;

     

       78
       -
           other_fields: Yojson.Safe.t string_map;

     

       79
       -
         }

     

       80
       -
       

     

       81
       -
         let problem_type t = t.problem_type

     

       82
       -
         let status t = t.status

     

       83
       -
         let detail t = t.detail

     

       84
       -
         let limit t = t.limit

     

       85
       -
         let other_fields t = t.other_fields

     

       86
       -
         

     

       87
       -
         let v ?status ?detail ?limit ?(other_fields=Hashtbl.create 0) problem_type =

     

       88
       -
           { problem_type; status; detail; limit; other_fields }

     

       89
       -
       end

     

       90
       -
       

     

       91
       -
       (* Description for method errors. May contain additional details. *)

     

       92
       -
       module Method_error_description = struct

     

       93
       -
         type t = {

     

       94
       -
           description: string option;

     

       95
       -
         }

     

       96
       -
         

     

       97
       -
         let description t = t.description

     

       98
       -
         

     

       99
       -
         let v ?description () = { description }

     

       100
       -
       end

     

       101
       -
       

     

       102
       -
       (* Represents a method-level error response invocation part. *)

     

       103
       -
       module Method_error = struct

     

       104
       -
         type t = {

     

       105
       -
           type_: method_error_type;

     

       106
       -
           description: Method_error_description.t option;

     

       107
       -
         }

     

       108
       -
         

     

       109
       -
         let type_ t = t.type_

     

       110
       -
         let description t = t.description

     

       111
       -
         

     

       112
       -
         let v ?description type_ = { type_; description }

     

       113
       -
       end

     

       114
       -
       

     

       115
       -
       (* SetError object. *)

     

       116
       -
       module Set_error = struct

     

       117
       -
         type t = {

     

       118
       -
           type_: set_error_type;

     

       119
       -
           description: string option;

     

       120
       -
           properties: string list option;

     

       121
       -
           existing_id: id option;

     

       122
       -
           max_recipients: uint option;

     

       123
       -
           invalid_recipients: string list option;

     

       124
       -
           max_size: uint option;

     

       125
       -
           not_found_blob_ids: id list option;

     

       126
       -
         }

     

       127
       -
         

     

       128
       -
         let type_ t = t.type_

     

       129
       -
         let description t = t.description

     

       130
       -
         let properties t = t.properties

     

       131
       -
         let existing_id t = t.existing_id

     

       132
       -
         let max_recipients t = t.max_recipients

     

       133
       -
         let invalid_recipients t = t.invalid_recipients

     

       134
       -
         let max_size t = t.max_size

     

       135
       -
         let not_found_blob_ids t = t.not_found_blob_ids

     

       136
       -
         

     

       137
       -
         let v ?description ?properties ?existing_id ?max_recipients

     

       138
       -
             ?invalid_recipients ?max_size ?not_found_blob_ids type_ =

     

       139
       -
           { type_; description; properties; existing_id; max_recipients;

     

       140
       -
             invalid_recipients; max_size; not_found_blob_ids }

     

       141
       -
       end

     

       142
       -
       

     

       143
       -
       (* Error Handling Functions *)

     

       144
       -
       

     

       145
       -
       let transport_error msg = Transport msg

     

       146
       -
       

     

       147
       -
       let parse_error msg = Parse msg

     

       148
       -
       

     

       149
       -
       let protocol_error msg = Protocol msg

     

       150
       -
       

     

       151
       -
       let problem_error problem = 

     

       152
       -
         Problem (Problem_details.problem_type problem)

     

       153
       -
       

     

       154
       -
       let method_error ?description type_ = 

     

       155
       -
         Method (type_, description)

     

       156
       -
       

     

       157
       -
       let set_item_error id ?description type_ = 

     

       158
       -
         SetItem (id, type_, description)

     

       159
       -
       

     

       160
       -
       let auth_error msg = Auth msg

     

       161
       -
       

     

       162
       -
       let server_error msg = ServerError msg

     

       163
       -
       

     

       164
       -
       let of_method_error method_error =

     

       165
       -
         let description = match Method_error.description method_error with

     

       166
       -
           | Some desc -> Method_error_description.description desc

     

       167
       -
           | None -> None

     

       168
       -
         in

     

       169
       -
         Method (Method_error.type_ method_error, description)

     

       170
       -
       

     

       171
       -
       let of_set_error id set_error =

     

       172
       -
         SetItem (id, Set_error.type_ set_error, Set_error.description set_error)

     

       173
       -
       

     

       174
       -
       let error_to_string = function

     

       175
       -
         | Transport msg -> "Transport error: " ^ msg

     

       176
       -
         | Parse msg -> "Parse error: " ^ msg

     

       177
       -
         | Protocol msg -> "Protocol error: " ^ msg

     

       178
       -
         | Problem problem -> "Problem: " ^ problem

     

       179
       -
         | Method (type_, desc) -> 

     

       180
       -
             let type_str = match type_ with

     

       181
       -
               | `ServerUnavailable -> "serverUnavailable"

     

       182
       -
               | `ServerFail -> "serverFail"

     

       183
       -
               | `ServerPartialFail -> "serverPartialFail"

     

       184
       -
               | `UnknownMethod -> "unknownMethod"

     

       185
       -
               | `InvalidArguments -> "invalidArguments"

     

       186
       -
               | `InvalidResultReference -> "invalidResultReference"

     

       187
       -
               | `Forbidden -> "forbidden"

     

       188
       -
               | `AccountNotFound -> "accountNotFound"

     

       189
       -
               | `AccountNotSupportedByMethod -> "accountNotSupportedByMethod"

     

       190
       -
               | `AccountReadOnly -> "accountReadOnly"

     

       191
       -
               | `RequestTooLarge -> "requestTooLarge"

     

       192
       -
               | `CannotCalculateChanges -> "cannotCalculateChanges"

     

       193
       -
               | `StateMismatch -> "stateMismatch"

     

       194
       -
               | `AnchorNotFound -> "anchorNotFound"

     

       195
       -
               | `UnsupportedSort -> "unsupportedSort"

     

       196
       -
               | `UnsupportedFilter -> "unsupportedFilter"

     

       197
       -
               | `TooManyChanges -> "tooManyChanges"

     

       198
       -
               | `FromAccountNotFound -> "fromAccountNotFound"

     

       199
       -
               | `FromAccountNotSupportedByMethod -> "fromAccountNotSupportedByMethod"

     

       200
       -
               | `Other_method_error s -> s

     

       201
       -
             in

     

       202
       -
             let desc_str = match desc with

     

       203
       -
               | Some d -> ": " ^ d

     

       204
       -
               | None -> ""

     

       205
       -
             in

     

       206
       -
             "Method error: " ^ type_str ^ desc_str

     

       207
       -
         | SetItem (id, type_, desc) ->

     

       208
       -
             let type_str = match type_ with

     

       209
       -
               | `Forbidden -> "forbidden"

     

       210
       -
               | `OverQuota -> "overQuota"

     

       211
       -
               | `TooLarge -> "tooLarge"

     

       212
       -
               | `RateLimit -> "rateLimit"

     

       213
       -
               | `NotFound -> "notFound"

     

       214
       -
               | `InvalidPatch -> "invalidPatch"

     

       215
       -
               | `WillDestroy -> "willDestroy"

     

       216
       -
               | `InvalidProperties -> "invalidProperties"

     

       217
       -
               | `Singleton -> "singleton"

     

       218
       -
               | `AlreadyExists -> "alreadyExists"

     

       219
       -
               | `MailboxHasChild -> "mailboxHasChild"

     

       220
       -
               | `MailboxHasEmail -> "mailboxHasEmail"

     

       221
       -
               | `BlobNotFound -> "blobNotFound"

     

       222
       -
               | `TooManyKeywords -> "tooManyKeywords"

     

       223
       -
               | `TooManyMailboxes -> "tooManyMailboxes"

     

       224
       -
               | `InvalidEmail -> "invalidEmail"

     

       225
       -
               | `TooManyRecipients -> "tooManyRecipients"

     

       226
       -
               | `NoRecipients -> "noRecipients"

     

       227
       -
               | `InvalidRecipients -> "invalidRecipients"

     

       228
       -
               | `ForbiddenMailFrom -> "forbiddenMailFrom"

     

       229
       -
               | `ForbiddenFrom -> "forbiddenFrom"

     

       230
       -
               | `ForbiddenToSend -> "forbiddenToSend"

     

       231
       -
               | `CannotUnsend -> "cannotUnsend"

     

       232
       -
               | `Other_set_error s -> s

     

       233
       -
             in

     

       234
       -
             let desc_str = match desc with

     

       235
       -
               | Some d -> ": " ^ d

     

       236
       -
               | None -> ""

     

       237
       -
             in

     

       238
       -
             "SetItem error for " ^ id ^ ": " ^ type_str ^ desc_str

     

       239
       -
         | Auth msg -> "Authentication error: " ^ msg

     

       240
       -
         | ServerError msg -> "Server error: " ^ msg

     

       241
       -
       

     

       242
       -
       (* Result Handling *)

     

       243
       -
       

     

       244
       -
       let map_error result f =

     

       245
       -
         match result with

     

       246
       -
         | Ok v -> Ok v

     

       247
       -
         | Error e -> Error (f e)

     

       248
       -
       

     

       249
       -
       let with_context result context =

     

       250
       -
         map_error result (function

     

       251
       -
           | Transport msg -> Transport (context ^ ": " ^ msg)

     

       252
       -
           | Parse msg -> Parse (context ^ ": " ^ msg)

     

       253
       -
           | Protocol msg -> Protocol (context ^ ": " ^ msg)

     

       254
       -
           | Problem p -> Problem (context ^ ": " ^ p)

     

       255
       -
           | Method (t, Some d) -> Method (t, Some (context ^ ": " ^ d))

     

       256
       -
           | Method (t, None) -> Method (t, Some context)

     

       257
       -
           | SetItem (id, t, Some d) -> SetItem (id, t, Some (context ^ ": " ^ d))

     

       258
       -
           | SetItem (id, t, None) -> SetItem (id, t, Some context)

     

       259
       -
           | Auth msg -> Auth (context ^ ": " ^ msg)

     

       260
       -
           | ServerError msg -> ServerError (context ^ ": " ^ msg)

     

       261
       -
         )

     

       262
       -
       

     

       263
       -
       let of_option opt error =

     

       264
       -
         match opt with

     

       265
       -
         | Some v -> Ok v

     

       266
       -
         | None -> Error error

-436

jmap/jmap_methods.ml

···

       1
       -
       (* Standard JMAP Methods and Core/echo. *)

     

       2
       -
       

     

       3
       -
       open Jmap_types

     

       4
       -
       open Jmap_error

     

       5
       -
       

     

       6
       -
       (* Generic representation of a record type. Actual types defined elsewhere. *)

     

       7
       -
       type generic_record = Yojson.Safe.t

     

       8
       -
       

     

       9
       -
       (* Arguments for /get methods. *)

     

       10
       -
       module Get_args = struct

     

       11
       -
         type 'record t = {

     

       12
       -
           account_id: id;

     

       13
       -
           ids: id list option;

     

       14
       -
           properties: string list option;

     

       15
       -
         }

     

       16
       -
         

     

       17
       -
         let account_id t = t.account_id

     

       18
       -
         let ids t = t.ids

     

       19
       -
         let properties t = t.properties

     

       20
       -
         

     

       21
       -
         let v ~account_id ?ids ?properties () =

     

       22
       -
           { account_id; ids; properties }

     

       23
       -
       end

     

       24
       -
       

     

       25
       -
       (* Response for /get methods. *)

     

       26
       -
       module Get_response = struct

     

       27
       -
         type 'record t = {

     

       28
       -
           account_id: id;

     

       29
       -
           state: string;

     

       30
       -
           list: 'record list;

     

       31
       -
           not_found: id list;

     

       32
       -
         }

     

       33
       -
         

     

       34
       -
         let account_id t = t.account_id

     

       35
       -
         let state t = t.state

     

       36
       -
         let list t = t.list

     

       37
       -
         let not_found t = t.not_found

     

       38
       -
         

     

       39
       -
         let v ~account_id ~state ~list ~not_found () =

     

       40
       -
           { account_id; state; list; not_found }

     

       41
       -
       end

     

       42
       -
       

     

       43
       -
       (* Arguments for /changes methods. *)

     

       44
       -
       module Changes_args = struct

     

       45
       -
         type t = {

     

       46
       -
           account_id: id;

     

       47
       -
           since_state: string;

     

       48
       -
           max_changes: uint option;

     

       49
       -
         }

     

       50
       -
         

     

       51
       -
         let account_id t = t.account_id

     

       52
       -
         let since_state t = t.since_state

     

       53
       -
         let max_changes t = t.max_changes

     

       54
       -
         

     

       55
       -
         let v ~account_id ~since_state ?max_changes () =

     

       56
       -
           { account_id; since_state; max_changes }

     

       57
       -
       end

     

       58
       -
       

     

       59
       -
       (* Response for /changes methods. *)

     

       60
       -
       module Changes_response = struct

     

       61
       -
         type t = {

     

       62
       -
           account_id: id;

     

       63
       -
           old_state: string;

     

       64
       -
           new_state: string;

     

       65
       -
           has_more_changes: bool;

     

       66
       -
           created: id list;

     

       67
       -
           updated: id list;

     

       68
       -
           destroyed: id list;

     

       69
       -
           updated_properties: string list option;

     

       70
       -
         }

     

       71
       -
         

     

       72
       -
         let account_id t = t.account_id

     

       73
       -
         let old_state t = t.old_state

     

       74
       -
         let new_state t = t.new_state

     

       75
       -
         let has_more_changes t = t.has_more_changes

     

       76
       -
         let created t = t.created

     

       77
       -
         let updated t = t.updated

     

       78
       -
         let destroyed t = t.destroyed

     

       79
       -
         let updated_properties t = t.updated_properties

     

       80
       -
         

     

       81
       -
         let v ~account_id ~old_state ~new_state ~has_more_changes

     

       82
       -
             ~created ~updated ~destroyed ?updated_properties () =

     

       83
       -
           { account_id; old_state; new_state; has_more_changes;

     

       84
       -
             created; updated; destroyed; updated_properties }

     

       85
       -
       end

     

       86
       -
       

     

       87
       -
       (* Patch object for /set update.

     

       88
       -
          A list of (JSON Pointer path, value) pairs. *)

     

       89
       -
       type patch_object = (json_pointer * Yojson.Safe.t) list

     

       90
       -
       

     

       91
       -
       (* Arguments for /set methods. *)

     

       92
       -
       module Set_args = struct

     

       93
       -
         type ('create_record, 'update_record) t = {

     

       94
       -
           account_id: id;

     

       95
       -
           if_in_state: string option;

     

       96
       -
           create: 'create_record id_map option;

     

       97
       -
           update: 'update_record id_map option;

     

       98
       -
           destroy: id list option;

     

       99
       -
           on_success_destroy_original: bool option;

     

       100
       -
           destroy_from_if_in_state: string option;

     

       101
       -
           on_destroy_remove_emails: bool option;

     

       102
       -
         }

     

       103
       -
         

     

       104
       -
         let account_id t = t.account_id

     

       105
       -
         let if_in_state t = t.if_in_state

     

       106
       -
         let create t = t.create

     

       107
       -
         let update t = t.update

     

       108
       -
         let destroy t = t.destroy

     

       109
       -
         let on_success_destroy_original t = t.on_success_destroy_original

     

       110
       -
         let destroy_from_if_in_state t = t.destroy_from_if_in_state

     

       111
       -
         let on_destroy_remove_emails t = t.on_destroy_remove_emails

     

       112
       -
         

     

       113
       -
         let v ~account_id ?if_in_state ?create ?update ?destroy

     

       114
       -
             ?on_success_destroy_original ?destroy_from_if_in_state

     

       115
       -
             ?on_destroy_remove_emails () =

     

       116
       -
           { account_id; if_in_state; create; update; destroy;

     

       117
       -
             on_success_destroy_original; destroy_from_if_in_state;

     

       118
       -
             on_destroy_remove_emails }

     

       119
       -
       end

     

       120
       -
       

     

       121
       -
       (* Response for /set methods. *)

     

       122
       -
       module Set_response = struct

     

       123
       -
         type ('created_record_info, 'updated_record_info) t = {

     

       124
       -
           account_id: id;

     

       125
       -
           old_state: string option;

     

       126
       -
           new_state: string;

     

       127
       -
           created: 'created_record_info id_map option;

     

       128
       -
           updated: 'updated_record_info option id_map option;

     

       129
       -
           destroyed: id list option;

     

       130
       -
           not_created: Set_error.t id_map option;

     

       131
       -
           not_updated: Set_error.t id_map option;

     

       132
       -
           not_destroyed: Set_error.t id_map option;

     

       133
       -
         }

     

       134
       -
         

     

       135
       -
         let account_id t = t.account_id

     

       136
       -
         let old_state t = t.old_state

     

       137
       -
         let new_state t = t.new_state

     

       138
       -
         let created t = t.created

     

       139
       -
         let updated t = t.updated

     

       140
       -
         let destroyed t = t.destroyed

     

       141
       -
         let not_created t = t.not_created

     

       142
       -
         let not_updated t = t.not_updated

     

       143
       -
         let not_destroyed t = t.not_destroyed

     

       144
       -
         

     

       145
       -
         let v ~account_id ?old_state ~new_state ?created ?updated ?destroyed

     

       146
       -
             ?not_created ?not_updated ?not_destroyed () =

     

       147
       -
           { account_id; old_state; new_state; created; updated; destroyed;

     

       148
       -
             not_created; not_updated; not_destroyed }

     

       149
       -
       end

     

       150
       -
       

     

       151
       -
       (* Arguments for /copy methods. *)

     

       152
       -
       module Copy_args = struct

     

       153
       -
         type 'copy_record_override t = {

     

       154
       -
           from_account_id: id;

     

       155
       -
           if_from_in_state: string option;

     

       156
       -
           account_id: id;

     

       157
       -
           if_in_state: string option;

     

       158
       -
           create: 'copy_record_override id_map;

     

       159
       -
           on_success_destroy_original: bool;

     

       160
       -
           destroy_from_if_in_state: string option;

     

       161
       -
         }

     

       162
       -
         

     

       163
       -
         let from_account_id t = t.from_account_id

     

       164
       -
         let if_from_in_state t = t.if_from_in_state

     

       165
       -
         let account_id t = t.account_id

     

       166
       -
         let if_in_state t = t.if_in_state

     

       167
       -
         let create t = t.create

     

       168
       -
         let on_success_destroy_original t = t.on_success_destroy_original

     

       169
       -
         let destroy_from_if_in_state t = t.destroy_from_if_in_state

     

       170
       -
         

     

       171
       -
         let v ~from_account_id ?if_from_in_state ~account_id ?if_in_state

     

       172
       -
             ~create ?(on_success_destroy_original=false) ?destroy_from_if_in_state () =

     

       173
       -
           { from_account_id; if_from_in_state; account_id; if_in_state;

     

       174
       -
             create; on_success_destroy_original; destroy_from_if_in_state }

     

       175
       -
       end

     

       176
       -
       

     

       177
       -
       (* Response for /copy methods. *)

     

       178
       -
       module Copy_response = struct

     

       179
       -
         type 'created_record_info t = {

     

       180
       -
           from_account_id: id;

     

       181
       -
           account_id: id;

     

       182
       -
           old_state: string option;

     

       183
       -
           new_state: string;

     

       184
       -
           created: 'created_record_info id_map option;

     

       185
       -
           not_created: Set_error.t id_map option;

     

       186
       -
         }

     

       187
       -
         

     

       188
       -
         let from_account_id t = t.from_account_id

     

       189
       -
         let account_id t = t.account_id

     

       190
       -
         let old_state t = t.old_state

     

       191
       -
         let new_state t = t.new_state

     

       192
       -
         let created t = t.created

     

       193
       -
         let not_created t = t.not_created

     

       194
       -
         

     

       195
       -
         let v ~from_account_id ~account_id ?old_state ~new_state

     

       196
       -
             ?created ?not_created () =

     

       197
       -
           { from_account_id; account_id; old_state; new_state;

     

       198
       -
             created; not_created }

     

       199
       -
       end

     

       200
       -
       

     

       201
       -
       (* Module for generic filter representation. *)

     

       202
       -
       module Filter = struct

     

       203
       -
         type t =

     

       204
       -
           | Condition of Yojson.Safe.t

     

       205
       -
           | Operator of [ `AND | `OR | `NOT ] * t list

     

       206
       -
         

     

       207
       -
         let condition json = Condition json

     

       208
       -
         

     

       209
       -
         let operator op filters = Operator (op, filters)

     

       210
       -
         

     

       211
       -
         let and_ filters = operator `AND filters

     

       212
       -
         

     

       213
       -
         let or_ filters = operator `OR filters

     

       214
       -
         

     

       215
       -
         let not_ filter = operator `NOT [filter]

     

       216
       -
         

     

       217
       -
         let rec to_json = function

     

       218
       -
           | Condition json -> json

     

       219
       -
           | Operator (op, filters) ->

     

       220
       -
               let key = match op with

     

       221
       -
                 | `AND -> "AND"

     

       222
       -
                 | `OR -> "OR"

     

       223
       -
                 | `NOT -> "NOT"

     

       224
       -
               in

     

       225
       -
               `Assoc [(key, `List (List.map to_json filters))]

     

       226
       -
         

     

       227
       -
         (* Helper functions for common filter conditions *)

     

       228
       -
         

     

       229
       -
         let text_contains property value =

     

       230
       -
           condition (`Assoc [

     

       231
       -
             (property, `Assoc [("contains", `String value)])

     

       232
       -
           ])

     

       233
       -
         

     

       234
       -
         let property_equals property value =

     

       235
       -
           condition (`Assoc [(property, value)])

     

       236
       -
         

     

       237
       -
         let property_not_equals property value =

     

       238
       -
           condition (`Assoc [

     

       239
       -
             (property, `Assoc [("!",value)])

     

       240
       -
           ])

     

       241
       -
         

     

       242
       -
         let property_gt property value =

     

       243
       -
           condition (`Assoc [

     

       244
       -
             (property, `Assoc [("gt", value)])

     

       245
       -
           ])

     

       246
       -
         

     

       247
       -
         let property_ge property value =

     

       248
       -
           condition (`Assoc [

     

       249
       -
             (property, `Assoc [("ge", value)])

     

       250
       -
           ])

     

       251
       -
         

     

       252
       -
         let property_lt property value =

     

       253
       -
           condition (`Assoc [

     

       254
       -
             (property, `Assoc [("lt", value)])

     

       255
       -
           ])

     

       256
       -
         

     

       257
       -
         let property_le property value =

     

       258
       -
           condition (`Assoc [

     

       259
       -
             (property, `Assoc [("le", value)])

     

       260
       -
           ])

     

       261
       -
         

     

       262
       -
         let property_in property values =

     

       263
       -
           condition (`Assoc [

     

       264
       -
             (property, `Assoc [("in", `List values)])

     

       265
       -
           ])

     

       266
       -
         

     

       267
       -
         let property_not_in property values =

     

       268
       -
           condition (`Assoc [

     

       269
       -
             (property, `Assoc [("!in", `List values)])

     

       270
       -
           ])

     

       271
       -
         

     

       272
       -
         let property_exists property =

     

       273
       -
           condition (`Assoc [

     

       274
       -
             (property, `Null) (* Using just the property name means "property exists" *)

     

       275
       -
           ])

     

       276
       -
         

     

       277
       -
         let string_starts_with property prefix =

     

       278
       -
           condition (`Assoc [

     

       279
       -
             (property, `Assoc [("startsWith", `String prefix)])

     

       280
       -
           ])

     

       281
       -
         

     

       282
       -
         let string_ends_with property suffix =

     

       283
       -
           condition (`Assoc [

     

       284
       -
             (property, `Assoc [("endsWith", `String suffix)])

     

       285
       -
           ])

     

       286
       -
       end

     

       287
       -
       

     

       288
       -
       (* Comparator for sorting. *)

     

       289
       -
       module Comparator = struct

     

       290
       -
         type t = {

     

       291
       -
           property: string;

     

       292
       -
           is_ascending: bool option;

     

       293
       -
           collation: string option;

     

       294
       -
           keyword: string option;

     

       295
       -
           other_fields: Yojson.Safe.t string_map;

     

       296
       -
         }

     

       297
       -
         

     

       298
       -
         let property t = t.property

     

       299
       -
         let is_ascending t = t.is_ascending

     

       300
       -
         let collation t = t.collation

     

       301
       -
         let keyword t = t.keyword

     

       302
       -
         let other_fields t = t.other_fields

     

       303
       -
         

     

       304
       -
         let v ~property ?is_ascending ?collation ?keyword

     

       305
       -
             ?(other_fields=Hashtbl.create 0) () =

     

       306
       -
           { property; is_ascending; collation; keyword; other_fields }

     

       307
       -
       end

     

       308
       -
       

     

       309
       -
       (* Arguments for /query methods. *)

     

       310
       -
       module Query_args = struct

     

       311
       -
         type t = {

     

       312
       -
           account_id: id;

     

       313
       -
           filter: Filter.t option;

     

       314
       -
           sort: Comparator.t list option;

     

       315
       -
           position: jint option;

     

       316
       -
           anchor: id option;

     

       317
       -
           anchor_offset: jint option;

     

       318
       -
           limit: uint option;

     

       319
       -
           calculate_total: bool option;

     

       320
       -
           collapse_threads: bool option;

     

       321
       -
           sort_as_tree: bool option;

     

       322
       -
           filter_as_tree: bool option;

     

       323
       -
         }

     

       324
       -
         

     

       325
       -
         let account_id t = t.account_id

     

       326
       -
         let filter t = t.filter

     

       327
       -
         let sort t = t.sort

     

       328
       -
         let position t = t.position

     

       329
       -
         let anchor t = t.anchor

     

       330
       -
         let anchor_offset t = t.anchor_offset

     

       331
       -
         let limit t = t.limit

     

       332
       -
         let calculate_total t = t.calculate_total

     

       333
       -
         let collapse_threads t = t.collapse_threads

     

       334
       -
         let sort_as_tree t = t.sort_as_tree

     

       335
       -
         let filter_as_tree t = t.filter_as_tree

     

       336
       -
         

     

       337
       -
         let v ~account_id ?filter ?sort ?position ?anchor ?anchor_offset

     

       338
       -
             ?limit ?calculate_total ?collapse_threads ?sort_as_tree ?filter_as_tree () =

     

       339
       -
           { account_id; filter; sort; position; anchor; anchor_offset;

     

       340
       -
             limit; calculate_total; collapse_threads; sort_as_tree; filter_as_tree }

     

       341
       -
       end

     

       342
       -
       

     

       343
       -
       (* Response for /query methods. *)

     

       344
       -
       module Query_response = struct

     

       345
       -
         type t = {

     

       346
       -
           account_id: id;

     

       347
       -
           query_state: string;

     

       348
       -
           can_calculate_changes: bool;

     

       349
       -
           position: uint;

     

       350
       -
           ids: id list;

     

       351
       -
           total: uint option;

     

       352
       -
           limit: uint option;

     

       353
       -
         }

     

       354
       -
         

     

       355
       -
         let account_id t = t.account_id

     

       356
       -
         let query_state t = t.query_state

     

       357
       -
         let can_calculate_changes t = t.can_calculate_changes

     

       358
       -
         let position t = t.position

     

       359
       -
         let ids t = t.ids

     

       360
       -
         let total t = t.total

     

       361
       -
         let limit t = t.limit

     

       362
       -
         

     

       363
       -
         let v ~account_id ~query_state ~can_calculate_changes ~position ~ids

     

       364
       -
             ?total ?limit () =

     

       365
       -
           { account_id; query_state; can_calculate_changes; position; ids;

     

       366
       -
             total; limit }

     

       367
       -
       end

     

       368
       -
       

     

       369
       -
       (* Item indicating an added record in /queryChanges. *)

     

       370
       -
       module Added_item = struct

     

       371
       -
         type t = {

     

       372
       -
           id: id;

     

       373
       -
           index: uint;

     

       374
       -
         }

     

       375
       -
         

     

       376
       -
         let id t = t.id

     

       377
       -
         let index t = t.index

     

       378
       -
         

     

       379
       -
         let v ~id ~index () = { id; index }

     

       380
       -
       end

     

       381
       -
       

     

       382
       -
       (* Arguments for /queryChanges methods. *)

     

       383
       -
       module Query_changes_args = struct

     

       384
       -
         type t = {

     

       385
       -
           account_id: id;

     

       386
       -
           filter: Filter.t option;

     

       387
       -
           sort: Comparator.t list option;

     

       388
       -
           since_query_state: string;

     

       389
       -
           max_changes: uint option;

     

       390
       -
           up_to_id: id option;

     

       391
       -
           calculate_total: bool option;

     

       392
       -
           collapse_threads: bool option;

     

       393
       -
         }

     

       394
       -
         

     

       395
       -
         let account_id t = t.account_id

     

       396
       -
         let filter t = t.filter

     

       397
       -
         let sort t = t.sort

     

       398
       -
         let since_query_state t = t.since_query_state

     

       399
       -
         let max_changes t = t.max_changes

     

       400
       -
         let up_to_id t = t.up_to_id

     

       401
       -
         let calculate_total t = t.calculate_total

     

       402
       -
         let collapse_threads t = t.collapse_threads

     

       403
       -
         

     

       404
       -
         let v ~account_id ?filter ?sort ~since_query_state ?max_changes

     

       405
       -
             ?up_to_id ?calculate_total ?collapse_threads () =

     

       406
       -
           { account_id; filter; sort; since_query_state; max_changes;

     

       407
       -
             up_to_id; calculate_total; collapse_threads }

     

       408
       -
       end

     

       409
       -
       

     

       410
       -
       (* Response for /queryChanges methods. *)

     

       411
       -
       module Query_changes_response = struct

     

       412
       -
         type t = {

     

       413
       -
           account_id: id;

     

       414
       -
           old_query_state: string;

     

       415
       -
           new_query_state: string;

     

       416
       -
           total: uint option;

     

       417
       -
           removed: id list;

     

       418
       -
           added: Added_item.t list;

     

       419
       -
         }

     

       420
       -
         

     

       421
       -
         let account_id t = t.account_id

     

       422
       -
         let old_query_state t = t.old_query_state

     

       423
       -
         let new_query_state t = t.new_query_state

     

       424
       -
         let total t = t.total

     

       425
       -
         let removed t = t.removed

     

       426
       -
         let added t = t.added

     

       427
       -
         

     

       428
       -
         let v ~account_id ~old_query_state ~new_query_state ?total

     

       429
       -
             ~removed ~added () =

     

       430
       -
           { account_id; old_query_state; new_query_state; total;

     

       431
       -
             removed; added }

     

       432
       -
       end

     

       433
       -
       

     

       434
       -
       (* Core/echo method: Arguments are mirrored in the response. *)

     

       435
       -
       type core_echo_args = Yojson.Safe.t

     

       436
       -
       type core_echo_response = Yojson.Safe.t

-192

jmap/jmap_push.ml

···

       1
       -
       (* JMAP Push Notifications. *)

     

       2
       -
       

     

       3
       -
       open Jmap_types

     

       4
       -
       open Jmap_methods

     

       5
       -
       open Jmap_error

     

       6
       -
       

     

       7
       -
       (* TypeState object map (TypeName -> StateString). *)

     

       8
       -
       type type_state = string string_map

     

       9
       -
       

     

       10
       -
       (* StateChange object. *)

     

       11
       -
       module State_change = struct

     

       12
       -
         type t = {

     

       13
       -
           changed: type_state id_map;

     

       14
       -
         }

     

       15
       -
         

     

       16
       -
         let changed t = t.changed

     

       17
       -
         

     

       18
       -
         let v ~changed () = { changed }

     

       19
       -
       end

     

       20
       -
       

     

       21
       -
       (* PushSubscription encryption keys. *)

     

       22
       -
       module Push_encryption_keys = struct

     

       23
       -
         type t = {

     

       24
       -
           p256dh: string;

     

       25
       -
           auth: string;

     

       26
       -
         }

     

       27
       -
         

     

       28
       -
         let p256dh t = t.p256dh

     

       29
       -
         let auth t = t.auth

     

       30
       -
         

     

       31
       -
         let v ~p256dh ~auth () = { p256dh; auth }

     

       32
       -
       end

     

       33
       -
       

     

       34
       -
       (* PushSubscription object. *)

     

       35
       -
       module Push_subscription = struct

     

       36
       -
         type t = {

     

       37
       -
           id: id;

     

       38
       -
           device_client_id: string;

     

       39
       -
           url: Uri.t;

     

       40
       -
           keys: Push_encryption_keys.t option;

     

       41
       -
           verification_code: string option;

     

       42
       -
           expires: utc_date option;

     

       43
       -
           types: string list option;

     

       44
       -
         }

     

       45
       -
         

     

       46
       -
         let id t = t.id

     

       47
       -
         let device_client_id t = t.device_client_id

     

       48
       -
         let url t = t.url

     

       49
       -
         let keys t = t.keys

     

       50
       -
         let verification_code t = t.verification_code

     

       51
       -
         let expires t = t.expires

     

       52
       -
         let types t = t.types

     

       53
       -
         

     

       54
       -
         let v ~id ~device_client_id ~url ?keys ?verification_code ?expires ?types () =

     

       55
       -
           { id; device_client_id; url; keys; verification_code; expires; types }

     

       56
       -
       end

     

       57
       -
       

     

       58
       -
       (* PushSubscription object for creation (omits server-set fields). *)

     

       59
       -
       module Push_subscription_create = struct

     

       60
       -
         type t = {

     

       61
       -
           device_client_id: string;

     

       62
       -
           url: Uri.t;

     

       63
       -
           keys: Push_encryption_keys.t option;

     

       64
       -
           expires: utc_date option;

     

       65
       -
           types: string list option;

     

       66
       -
         }

     

       67
       -
         

     

       68
       -
         let device_client_id t = t.device_client_id

     

       69
       -
         let url t = t.url

     

       70
       -
         let keys t = t.keys

     

       71
       -
         let expires t = t.expires

     

       72
       -
         let types t = t.types

     

       73
       -
         

     

       74
       -
         let v ~device_client_id ~url ?keys ?expires ?types () =

     

       75
       -
           { device_client_id; url; keys; expires; types }

     

       76
       -
       end

     

       77
       -
       

     

       78
       -
       (* PushSubscription object for update patch.

     

       79
       -
          Only verification_code and expires can be updated. *)

     

       80
       -
       type push_subscription_update = patch_object

     

       81
       -
       

     

       82
       -
       (* Arguments for PushSubscription/get. *)

     

       83
       -
       module Push_subscription_get_args = struct

     

       84
       -
         type t = {

     

       85
       -
           ids: id list option;

     

       86
       -
           properties: string list option;

     

       87
       -
         }

     

       88
       -
         

     

       89
       -
         let ids t = t.ids

     

       90
       -
         let properties t = t.properties

     

       91
       -
         

     

       92
       -
         let v ?ids ?properties () = { ids; properties }

     

       93
       -
       end

     

       94
       -
       

     

       95
       -
       (* Response for PushSubscription/get. *)

     

       96
       -
       module Push_subscription_get_response = struct

     

       97
       -
         type t = {

     

       98
       -
           list: Push_subscription.t list;

     

       99
       -
           not_found: id list;

     

       100
       -
         }

     

       101
       -
         

     

       102
       -
         let list t = t.list

     

       103
       -
         let not_found t = t.not_found

     

       104
       -
         

     

       105
       -
         let v ~list ~not_found () = { list; not_found }

     

       106
       -
       end

     

       107
       -
       

     

       108
       -
       (* Arguments for PushSubscription/set. *)

     

       109
       -
       module Push_subscription_set_args = struct

     

       110
       -
         type t = {

     

       111
       -
           create: Push_subscription_create.t id_map option;

     

       112
       -
           update: push_subscription_update id_map option;

     

       113
       -
           destroy: id list option;

     

       114
       -
         }

     

       115
       -
         

     

       116
       -
         let create t = t.create

     

       117
       -
         let update t = t.update

     

       118
       -
         let destroy t = t.destroy

     

       119
       -
         

     

       120
       -
         let v ?create ?update ?destroy () = { create; update; destroy }

     

       121
       -
       end

     

       122
       -
       

     

       123
       -
       (* Server-set information for created PushSubscription. *)

     

       124
       -
       module Push_subscription_created_info = struct

     

       125
       -
         type t = {

     

       126
       -
           id: id;

     

       127
       -
           expires: utc_date option;

     

       128
       -
         }

     

       129
       -
         

     

       130
       -
         let id t = t.id

     

       131
       -
         let expires t = t.expires

     

       132
       -
         

     

       133
       -
         let v ~id ?expires () = { id; expires }

     

       134
       -
       end

     

       135
       -
       

     

       136
       -
       (* Server-set information for updated PushSubscription. *)

     

       137
       -
       module Push_subscription_updated_info = struct

     

       138
       -
         type t = {

     

       139
       -
           expires: utc_date option;

     

       140
       -
         }

     

       141
       -
         

     

       142
       -
         let expires t = t.expires

     

       143
       -
         

     

       144
       -
         let v ?expires () = { expires }

     

       145
       -
       end

     

       146
       -
       

     

       147
       -
       (* Response for PushSubscription/set. *)

     

       148
       -
       module Push_subscription_set_response = struct

     

       149
       -
         type t = {

     

       150
       -
           created: Push_subscription_created_info.t id_map option;

     

       151
       -
           updated: Push_subscription_updated_info.t option id_map option;

     

       152
       -
           destroyed: id list option;

     

       153
       -
           not_created: Set_error.t id_map option;

     

       154
       -
           not_updated: Set_error.t id_map option;

     

       155
       -
           not_destroyed: Set_error.t id_map option;

     

       156
       -
         }

     

       157
       -
         

     

       158
       -
         let created t = t.created

     

       159
       -
         let updated t = t.updated

     

       160
       -
         let destroyed t = t.destroyed

     

       161
       -
         let not_created t = t.not_created

     

       162
       -
         let not_updated t = t.not_updated

     

       163
       -
         let not_destroyed t = t.not_destroyed

     

       164
       -
         

     

       165
       -
         let v ?created ?updated ?destroyed ?not_created ?not_updated ?not_destroyed () =

     

       166
       -
           { created; updated; destroyed; not_created; not_updated; not_destroyed }

     

       167
       -
       end

     

       168
       -
       

     

       169
       -
       (* PushVerification object. *)

     

       170
       -
       module Push_verification = struct

     

       171
       -
         type t = {

     

       172
       -
           push_subscription_id: id;

     

       173
       -
           verification_code: string;

     

       174
       -
         }

     

       175
       -
         

     

       176
       -
         let push_subscription_id t = t.push_subscription_id

     

       177
       -
         let verification_code t = t.verification_code

     

       178
       -
         

     

       179
       -
         let v ~push_subscription_id ~verification_code () =

     

       180
       -
           { push_subscription_id; verification_code }

     

       181
       -
       end

     

       182
       -
       

     

       183
       -
       (* Data for EventSource ping event. *)

     

       184
       -
       module Event_source_ping_data = struct

     

       185
       -
         type t = {

     

       186
       -
           interval: uint;

     

       187
       -
         }

     

       188
       -
         

     

       189
       -
         let interval t = t.interval

     

       190
       -
         

     

       191
       -
         let v ~interval () = { interval }

     

       192
       -
       end

-114

jmap/jmap_session.ml

···

       1
       -
       (* JMAP Session Resource. *)

     

       2
       -
       

     

       3
       -
       open Jmap_types

     

       4
       -
       

     

       5
       -
       (* Account capability information.

     

       6
       -
          The value is capability-specific. *)

     

       7
       -
       type account_capability_value = Yojson.Safe.t

     

       8
       -
       

     

       9
       -
       (* Server capability information.

     

       10
       -
          The value is capability-specific. *)

     

       11
       -
       type server_capability_value = Yojson.Safe.t

     

       12
       -
       

     

       13
       -
       (* Core capability information. *)

     

       14
       -
       module Core_capability = struct

     

       15
       -
         type t = {

     

       16
       -
           max_size_upload: uint;

     

       17
       -
           max_concurrent_upload: uint;

     

       18
       -
           max_size_request: uint;

     

       19
       -
           max_concurrent_requests: uint;

     

       20
       -
           max_calls_in_request: uint;

     

       21
       -
           max_objects_in_get: uint;

     

       22
       -
           max_objects_in_set: uint;

     

       23
       -
           collation_algorithms: string list;

     

       24
       -
         }

     

       25
       -
         

     

       26
       -
         let max_size_upload t = t.max_size_upload

     

       27
       -
         let max_concurrent_upload t = t.max_concurrent_upload

     

       28
       -
         let max_size_request t = t.max_size_request

     

       29
       -
         let max_concurrent_requests t = t.max_concurrent_requests

     

       30
       -
         let max_calls_in_request t = t.max_calls_in_request

     

       31
       -
         let max_objects_in_get t = t.max_objects_in_get

     

       32
       -
         let max_objects_in_set t = t.max_objects_in_set

     

       33
       -
         let collation_algorithms t = t.collation_algorithms

     

       34
       -
         

     

       35
       -
         let v ~max_size_upload ~max_concurrent_upload ~max_size_request

     

       36
       -
             ~max_concurrent_requests ~max_calls_in_request ~max_objects_in_get

     

       37
       -
             ~max_objects_in_set ~collation_algorithms () =

     

       38
       -
           { max_size_upload; max_concurrent_upload; max_size_request;

     

       39
       -
             max_concurrent_requests; max_calls_in_request; max_objects_in_get;

     

       40
       -
             max_objects_in_set; collation_algorithms }

     

       41
       -
       end

     

       42
       -
       

     

       43
       -
       (* An Account object. *)

     

       44
       -
       module Account = struct

     

       45
       -
         type t = {

     

       46
       -
           name: string;

     

       47
       -
           is_personal: bool;

     

       48
       -
           is_read_only: bool;

     

       49
       -
           account_capabilities: account_capability_value string_map;

     

       50
       -
         }

     

       51
       -
         

     

       52
       -
         let name t = t.name

     

       53
       -
         let is_personal t = t.is_personal

     

       54
       -
         let is_read_only t = t.is_read_only

     

       55
       -
         let account_capabilities t = t.account_capabilities

     

       56
       -
         

     

       57
       -
         let v ~name ?(is_personal=true) ?(is_read_only=false)

     

       58
       -
             ?(account_capabilities=Hashtbl.create 0) () =

     

       59
       -
           { name; is_personal; is_read_only; account_capabilities }

     

       60
       -
       end

     

       61
       -
       

     

       62
       -
       (* The Session object. *)

     

       63
       -
       module Session = struct

     

       64
       -
         type t = {

     

       65
       -
           capabilities: server_capability_value string_map;

     

       66
       -
           accounts: Account.t id_map;

     

       67
       -
           primary_accounts: id string_map;

     

       68
       -
           username: string;

     

       69
       -
           api_url: Uri.t;

     

       70
       -
           download_url: Uri.t;

     

       71
       -
           upload_url: Uri.t;

     

       72
       -
           event_source_url: Uri.t;

     

       73
       -
           state: string;

     

       74
       -
         }

     

       75
       -
         

     

       76
       -
         let capabilities t = t.capabilities

     

       77
       -
         let accounts t = t.accounts

     

       78
       -
         let primary_accounts t = t.primary_accounts

     

       79
       -
         let username t = t.username

     

       80
       -
         let api_url t = t.api_url

     

       81
       -
         let download_url t = t.download_url

     

       82
       -
         let upload_url t = t.upload_url

     

       83
       -
         let event_source_url t = t.event_source_url

     

       84
       -
         let state t = t.state

     

       85
       -
         

     

       86
       -
         let v ~capabilities ~accounts ~primary_accounts ~username

     

       87
       -
             ~api_url ~download_url ~upload_url ~event_source_url ~state () =

     

       88
       -
           { capabilities; accounts; primary_accounts; username;

     

       89
       -
             api_url; download_url; upload_url; event_source_url; state }

     

       90
       -
       end

     

       91
       -
       

     

       92
       -
       (* Function to perform service autodiscovery.

     

       93
       -
          Returns the session URL if found. *)

     

       94
       -
       let discover ~domain =

     

       95
       -
         (* This is a placeholder implementation - would need to be completed in Unix implementation *)

     

       96
       -
         let well_known_url = Uri.of_string ("https://" ^ domain ^ "/.well-known/jmap") in

     

       97
       -
         Some well_known_url

     

       98
       -
       

     

       99
       -
       (* Function to fetch the session object from a given URL.

     

       100
       -
          Requires authentication handling (details TBD/outside this signature). *)

     

       101
       -
       let get_session ~url =

     

       102
       -
         (* This is a placeholder implementation - would need to be completed in Unix implementation *)

     

       103
       -
         let empty_map () = Hashtbl.create 0 in

     

       104
       -
         Session.v

     

       105
       -
           ~capabilities:(empty_map ())

     

       106
       -
           ~accounts:(empty_map ())

     

       107
       -
           ~primary_accounts:(empty_map ())

     

       108
       -
           ~username:"placeholder"

     

       109
       -
           ~api_url:url

     

       110
       -
           ~download_url:url

     

       111
       -
           ~upload_url:url

     

       112
       -
           ~event_source_url:url

     

       113
       -
           ~state:"placeholder"

     

       114
       -
           ()

-32

jmap/jmap_types.ml

···

       1
       -
       (* Basic JMAP types as defined in RFC 8620. *)

     

       2
       -
       

     

       3
       -
       (* The Id data type.

     

       4
       -
          A string of 1 to 255 octets, using URL-safe base64 characters. *)

     

       5
       -
       type id = string

     

       6
       -
       

     

       7
       -
       (* The Int data type.

     

       8
       -
          An integer in the range [-2^53+1, 2^53-1]. Represented as OCaml's standard [int]. *)

     

       9
       -
       type jint = int

     

       10
       -
       

     

       11
       -
       (* The UnsignedInt data type.

     

       12
       -
          An integer in the range [0, 2^53-1]. Represented as OCaml's standard [int]. *)

     

       13
       -
       type uint = int

     

       14
       -
       

     

       15
       -
       (* The Date data type.

     

       16
       -
          A string in RFC 3339 "date-time" format.

     

       17
       -
          Represented as a float using Unix time. *)

     

       18
       -
       type date = float

     

       19
       -
       

     

       20
       -
       (* The UTCDate data type.

     

       21
       -
          A string in RFC 3339 "date-time" format, restricted to UTC (Z timezone).

     

       22
       -
          Represented as a float using Unix time. *)

     

       23
       -
       type utc_date = float

     

       24
       -
       

     

       25
       -
       (* Represents a JSON object used as a map String -> V. *)

     

       26
       -
       type 'v string_map = (string, 'v) Hashtbl.t

     

       27
       -
       

     

       28
       -
       (* Represents a JSON object used as a map Id -> V. *)

     

       29
       -
       type 'v id_map = (id, 'v) Hashtbl.t

     

       30
       -
       

     

       31
       -
       (* Represents a JSON Pointer path with JMAP extensions. *)

     

       32
       -
       type json_pointer = string

-73

jmap/jmap_wire.ml

···

       1
       -
       (* JMAP Wire Protocol Structures (Request/Response). *)

     

       2
       -
       

     

       3
       -
       open Jmap_types

     

       4
       -
       

     

       5
       -
       (* An invocation tuple within a request or response. *)

     

       6
       -
       module Invocation = struct

     

       7
       -
         type t = {

     

       8
       -
           method_name: string;

     

       9
       -
           arguments: Yojson.Safe.t;

     

       10
       -
           method_call_id: string;

     

       11
       -
         }

     

       12
       -
         

     

       13
       -
         let method_name t = t.method_name

     

       14
       -
         let arguments t = t.arguments

     

       15
       -
         let method_call_id t = t.method_call_id

     

       16
       -
         

     

       17
       -
         let v ?(arguments=`Assoc []) ~method_name ~method_call_id () =

     

       18
       -
           { method_name; arguments; method_call_id }

     

       19
       -
       end

     

       20
       -
       

     

       21
       -
       (* Method error type with context. *)

     

       22
       -
       type method_error = Jmap_error.Method_error.t * string

     

       23
       -
       

     

       24
       -
       (* A response invocation part, which can be a standard response or an error. *)

     

       25
       -
       type response_invocation = (Invocation.t, method_error) result

     

       26
       -
       

     

       27
       -
       (* A reference to a previous method call's result. *)

     

       28
       -
       module Result_reference = struct

     

       29
       -
         type t = {

     

       30
       -
           result_of: string;

     

       31
       -
           name: string;

     

       32
       -
           path: json_pointer;

     

       33
       -
         }

     

       34
       -
         

     

       35
       -
         let result_of t = t.result_of

     

       36
       -
         let name t = t.name

     

       37
       -
         let path t = t.path

     

       38
       -
         

     

       39
       -
         let v ~result_of ~name ~path () =

     

       40
       -
           { result_of; name; path }

     

       41
       -
       end

     

       42
       -
       

     

       43
       -
       (* The Request object. *)

     

       44
       -
       module Request = struct

     

       45
       -
         type t = {

     

       46
       -
           using: string list;

     

       47
       -
           method_calls: Invocation.t list;

     

       48
       -
           created_ids: id id_map option;

     

       49
       -
         }

     

       50
       -
         

     

       51
       -
         let using t = t.using

     

       52
       -
         let method_calls t = t.method_calls

     

       53
       -
         let created_ids t = t.created_ids

     

       54
       -
         

     

       55
       -
         let v ~using ~method_calls ?created_ids () =

     

       56
       -
           { using; method_calls; created_ids }

     

       57
       -
       end

     

       58
       -
       

     

       59
       -
       (* The Response object. *)

     

       60
       -
       module Response = struct

     

       61
       -
         type t = {

     

       62
       -
           method_responses: response_invocation list;

     

       63
       -
           created_ids: id id_map option;

     

       64
       -
           session_state: string;

     

       65
       -
         }

     

       66
       -
         

     

       67
       -
         let method_responses t = t.method_responses

     

       68
       -
         let created_ids t = t.created_ids

     

       69
       -
         let session_state t = t.session_state

     

       70
       -
         

     

       71
       -
         let v ~method_responses ?created_ids ~session_state () =

     

       72
       -
           { method_responses; created_ids; session_state }

     

       73
       -
       end