forked from
anil.recoil.org/ocaml-imap
IMAP in OCaml
Implement comprehensive IMAP RFC extensions
P0 Critical Fixes:
- Fix SEARCH response parsing in client library
- Add BODY/BODYSTRUCTURE recursive parsing for MIME structures
- Parse BODY[section] literals with section specifiers
P1 Core Protocol Compliance:
- ESEARCH (RFC 4731): search_return_opt types, MIN/MAX/COUNT/ALL
- Parse APPENDUID/COPYUID response codes with UID set parsing
- Add UNSELECT capability (RFC 3691)
- Add SPECIAL-USE capability and mailbox mapping (RFC 6154)
P2 Extension Support:
- THREAD (RFC 5256): algorithm types, response parsing, server handlers
- Base subject extraction per RFC 5256 Section 2.1
- QUOTA (RFC 9208): resource types, GETQUOTA/GETQUOTAROOT/SETQUOTA
- LIST-EXTENDED (RFC 5258): selection/return options, CHILDINFO
P3 Advanced Features:
- UTF-8 support (RFC 6855): validation, UTF8=ACCEPT capability
- CONDSTORE (RFC 7162): MODSEQ, Highestmodseq/Nomodseq/Modified codes
New modules: thread.ml, subject.ml, utf8.ml
New tests: 187 tests passing (was ~150)
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+3515
-163
+669
IMPLEMENTATION-PLAN.md
+669
IMPLEMENTATION-PLAN.md
···
1
+
# Comprehensive IMAP Implementation Plan
2
+
3
+
This document consolidates all RFC implementation plans from `spec/` and `lib/imap/PLAN.md` into a single, prioritized implementation roadmap. Per the design goals, we favor OCaml variants over strings and do not require backwards compatibility.
4
+
5
+
## Executive Summary
6
+
7
+
The ocaml-imap library implements IMAP4rev2 (RFC 9051) with several extensions. This plan covers:
8
+
- **P0**: Critical fixes and core infrastructure
9
+
- **P1**: Core protocol compliance
10
+
- **P2**: Extension support (SORT/THREAD, QUOTA, etc.)
11
+
- **P3**: Advanced features (UTF-8, CONDSTORE/QRESYNC)
12
+
- **P4**: Polish (documentation, unified flag library)
13
+
14
+
---
15
+
16
+
## Phase 0: Critical Fixes (P0)
17
+
18
+
These are blocking issues that need immediate attention.
19
+
20
+
### 0.1 Fix SEARCH Response Parsing (Client Library)
21
+
22
+
**Source**: `lib/imap/PLAN.md` - P0 Broken Functionality
23
+
24
+
**Problem**: `search` function always returns empty list - response is never parsed.
25
+
26
+
**Files**:
27
+
- `lib/imap/read.ml` - Add SEARCH response parsing
28
+
- `lib/imap/client.ml:536-544` - Fix to read response
29
+
30
+
**Implementation**:
31
+
```ocaml
32
+
(* In read.ml - add case for SEARCH response *)
33
+
| "SEARCH" ->
34
+
let rec parse_numbers acc =
35
+
match R.peek_char r with
36
+
| Some ' ' -> sp r; parse_numbers (number r :: acc)
37
+
| Some c when c >= '0' && c <= '9' -> parse_numbers (number r :: acc)
38
+
| _ -> List.rev acc
39
+
in
40
+
let nums = parse_numbers [] in
41
+
crlf r;
42
+
Response.Search nums
43
+
```
44
+
45
+
**Tests** (`test/test_read.ml`):
46
+
```ocaml
47
+
let test_search_response () =
48
+
let resp = parse "* SEARCH 2 4 7 11\r\n" in
49
+
Alcotest.(check (list int)) "search" [2; 4; 7; 11]
50
+
(match resp with Response.Search nums -> nums | _ -> [])
51
+
52
+
let test_search_empty () =
53
+
let resp = parse "* SEARCH\r\n" in
54
+
Alcotest.(check (list int)) "empty search" []
55
+
(match resp with Response.Search nums -> nums | _ -> [-1])
56
+
```
57
+
58
+
### 0.2 Parse BODY/BODYSTRUCTURE Responses
59
+
60
+
**Source**: `lib/imap/PLAN.md` - P1 Incomplete Core Features
61
+
62
+
**Problem**: FETCH responses with BODY/BODYSTRUCTURE fall back to empty flags.
63
+
64
+
**Files**:
65
+
- `lib/imap/read.ml:284-302` - Add BODY/BODYSTRUCTURE parsing
66
+
- `lib/imap/body.ml` - Body structure types (may need new file)
67
+
68
+
**Implementation**: Parse nested multipart MIME structures recursively.
69
+
70
+
**Tests**:
71
+
```ocaml
72
+
let test_body_structure () =
73
+
let resp = parse {|* 1 FETCH (BODYSTRUCTURE ("TEXT" "PLAIN" ("CHARSET" "UTF-8") NIL NIL "7BIT" 1234 56))|} in
74
+
(* verify body structure parsed correctly *)
75
+
```
76
+
77
+
### 0.3 Parse BODY[section] Literal Responses
78
+
79
+
**Source**: `lib/imap/PLAN.md` - P1
80
+
81
+
**Problem**: Cannot read actual message content from FETCH.
82
+
83
+
**Implementation**: Parse section specifiers and literal data:
84
+
```ocaml
85
+
(* Patterns: BODY[HEADER], BODY[TEXT], BODY[1.2.MIME], BODY[section]<origin> *)
86
+
```
87
+
88
+
---
89
+
90
+
## Phase 1: Core Protocol Compliance (P1)
91
+
92
+
### 1.1 Complete ESEARCH Support (RFC 4731)
93
+
94
+
**Source**: `spec/PLAN-rfc4731.md`
95
+
96
+
**Current State**: Response type exists, parsing not implemented.
97
+
98
+
**Tasks**:
99
+
1. Add ESEARCH response parsing to `lib/imap/read.ml`
100
+
2. Add search return options to Command type
101
+
3. Add serialization for `RETURN (MIN MAX COUNT ALL)`
102
+
4. Add client API functions
103
+
104
+
**Types** (use variants, no strings):
105
+
```ocaml
106
+
type search_return_opt =
107
+
| Return_min
108
+
| Return_max
109
+
| Return_all
110
+
| Return_count
111
+
112
+
type esearch_result =
113
+
| Esearch_min of int
114
+
| Esearch_max of int
115
+
| Esearch_count of int
116
+
| Esearch_all of Seq.t
117
+
```
118
+
119
+
**Tests**:
120
+
```ocaml
121
+
let test_esearch_parsing () =
122
+
let resp = parse "* ESEARCH (TAG \"A282\") MIN 2 COUNT 3\r\n" in
123
+
assert (resp = Response.Esearch {
124
+
tag = Some "A282";
125
+
uid = false;
126
+
results = [Esearch_min 2; Esearch_count 3]
127
+
})
128
+
```
129
+
130
+
### 1.2 Parse APPENDUID/COPYUID Response Codes
131
+
132
+
**Source**: `lib/imap/PLAN.md` - P1
133
+
134
+
**Files**: `lib/imap/read.ml:169-228`
135
+
136
+
**Implementation**:
137
+
```ocaml
138
+
(* Add to response_code parsing *)
139
+
| "APPENDUID" ->
140
+
sp r;
141
+
let uidvalidity = number32 r in
142
+
sp r;
143
+
let uid = number32 r in
144
+
Code.Appenduid (uidvalidity, uid)
145
+
| "COPYUID" ->
146
+
sp r;
147
+
let uidvalidity = number32 r in
148
+
sp r;
149
+
let source_uids = parse_uid_set r in
150
+
sp r;
151
+
let dest_uids = parse_uid_set r in
152
+
Code.Copyuid (uidvalidity, source_uids, dest_uids)
153
+
```
154
+
155
+
### 1.3 UNSELECT Capability Advertisement
156
+
157
+
**Source**: `spec/PLAN-rfc3691.md`
158
+
159
+
**Status**: Fully implemented except capability not advertised.
160
+
161
+
**Fix** (`lib/imapd/server.ml`):
162
+
```ocaml
163
+
let base_capabilities_pre_tls = [
164
+
(* existing *)
165
+
"UNSELECT"; (* RFC 3691 - already implemented *)
166
+
]
167
+
```
168
+
169
+
### 1.4 SPECIAL-USE Support (RFC 6154)
170
+
171
+
**Source**: `spec/PLAN-rfc6154.md`
172
+
173
+
**Current**: Types exist, capability not advertised, flags not returned.
174
+
175
+
**Tasks**:
176
+
1. Add `SPECIAL-USE` to capabilities
177
+
2. Return special-use flags in LIST responses
178
+
3. Map standard mailbox names to attributes
179
+
180
+
**Types** (already exist, ensure completeness):
181
+
```ocaml
182
+
type special_use =
183
+
| All | Archive | Drafts | Flagged | Important
184
+
| Junk | Sent | Trash
185
+
| Snoozed | Scheduled | Memos (* draft-ietf-mailmaint *)
186
+
```
187
+
188
+
**Tests**:
189
+
```ocaml
190
+
let test_list_special_use () =
191
+
(* LIST "" "*" should return \Drafts on Drafts mailbox *)
192
+
```
193
+
194
+
---
195
+
196
+
## Phase 2: Extension Support (P2)
197
+
198
+
### 2.1 SORT/THREAD Extension (RFC 5256)
199
+
200
+
**Source**: `spec/PLAN-rfc5256.md`
201
+
202
+
**Scope**: Large feature - server-side sorting and threading.
203
+
204
+
#### 2.1.1 Thread Module Types
205
+
206
+
**New file**: `lib/imap/thread.ml`
207
+
208
+
```ocaml
209
+
type algorithm =
210
+
| Orderedsubject (** Group by subject, sort by date *)
211
+
| References (** Full JWZ threading algorithm *)
212
+
| Extension of string
213
+
214
+
type 'a node =
215
+
| Message of 'a * 'a node list
216
+
| Dummy of 'a node list
217
+
218
+
type 'a t = 'a node list
219
+
```
220
+
221
+
#### 2.1.2 Base Subject Extraction
222
+
223
+
**New file**: `lib/imap/subject.ml`
224
+
225
+
Implements RFC 5256 Section 2.1 algorithm:
226
+
1. Decode RFC 2047 encoded-words
227
+
2. Remove `Re:`, `Fw:`, `Fwd:` prefixes
228
+
3. Remove `[blob]` prefixes
229
+
4. Remove `(fwd)` trailers
230
+
5. Unwrap `[fwd: ...]` wrappers
231
+
232
+
```ocaml
233
+
val base_subject : string -> string
234
+
val is_reply_or_forward : string -> bool
235
+
```
236
+
237
+
#### 2.1.3 Sent Date Handling
238
+
239
+
**New file**: `lib/imap/date.ml`
240
+
241
+
```ocaml
242
+
type t
243
+
244
+
val of_header : string -> t option
245
+
val of_internaldate : string -> t
246
+
val sent_date : date_header:string option -> internaldate:string -> t
247
+
val compare : t -> t -> int
248
+
```
249
+
250
+
#### 2.1.4 Server-Side SORT Handler
251
+
252
+
**File**: `lib/imapd/server.ml`
253
+
254
+
1. Implement sort key extraction
255
+
2. Implement comparison by criteria
256
+
3. Return SORT response
257
+
258
+
#### 2.1.5 Threading Algorithms
259
+
260
+
**New file**: `lib/imapd/thread.ml`
261
+
262
+
1. `orderedsubject` - simple subject-based grouping
263
+
2. `references` - full JWZ algorithm (6 steps)
264
+
265
+
**Tests**:
266
+
```ocaml
267
+
let test_base_subject () =
268
+
assert (Subject.base_subject "Re: test" = "test");
269
+
assert (Subject.base_subject "Re: Re: test" = "test");
270
+
assert (Subject.base_subject "[PATCH] Re: [ocaml] test" = "test");
271
+
assert (Subject.base_subject "[fwd: wrapped]" = "wrapped")
272
+
273
+
let test_orderedsubject () =
274
+
(* Test grouping by subject *)
275
+
276
+
let test_references_threading () =
277
+
(* Test parent/child relationships *)
278
+
```
279
+
280
+
### 2.2 QUOTA Extension (RFC 9208)
281
+
282
+
**Source**: `spec/PLAN-rfc9208.md`
283
+
284
+
#### 2.2.1 Protocol Types
285
+
286
+
**File**: `lib/imapd/protocol.ml`
287
+
288
+
```ocaml
289
+
type quota_resource =
290
+
| Quota_storage (** KB of storage *)
291
+
| Quota_message (** Number of messages *)
292
+
| Quota_mailbox (** Number of mailboxes *)
293
+
| Quota_annotation_storage
294
+
295
+
type quota_resource_info = {
296
+
resource : quota_resource;
297
+
usage : int64;
298
+
limit : int64;
299
+
}
300
+
301
+
(* Commands *)
302
+
| Getquota of string
303
+
| Getquotaroot of mailbox_name
304
+
| Setquota of { root : string; limits : (quota_resource * int64) list }
305
+
306
+
(* Responses *)
307
+
| Quota_response of { root : string; resources : quota_resource_info list }
308
+
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
309
+
```
310
+
311
+
#### 2.2.2 Storage Backend Interface
312
+
313
+
**File**: `lib/imapd/storage.mli`
314
+
315
+
```ocaml
316
+
val get_quota_roots : t -> username:string -> mailbox_name -> string list
317
+
val get_quota : t -> username:string -> string -> (quota_resource_info list, error) result
318
+
val set_quota : t -> username:string -> string -> (quota_resource * int64) list -> (quota_resource_info list, error) result
319
+
val check_quota : t -> username:string -> mailbox_name -> additional_size:int64 -> bool
320
+
```
321
+
322
+
#### 2.2.3 Server Handlers
323
+
324
+
Implement `handle_getquota`, `handle_getquotaroot`, `handle_setquota`.
325
+
326
+
Add quota checks to APPEND/COPY/MOVE:
327
+
```ocaml
328
+
if not (Storage.check_quota ...) then
329
+
send_response flow (No { code = Some Code_overquota; ... })
330
+
```
331
+
332
+
**Tests**:
333
+
```ocaml
334
+
let test_getquotaroot () =
335
+
(* GETQUOTAROOT INBOX returns quota info *)
336
+
337
+
let test_quota_exceeded () =
338
+
(* APPEND fails with OVERQUOTA when over limit *)
339
+
```
340
+
341
+
### 2.3 LIST-EXTENDED (RFC 5258)
342
+
343
+
**Source**: `spec/PLAN-rfc5258.md`
344
+
345
+
**Types**:
346
+
```ocaml
347
+
type list_select_option =
348
+
| List_select_subscribed
349
+
| List_select_remote
350
+
| List_select_recursivematch
351
+
| List_select_special_use (* RFC 6154 *)
352
+
353
+
type list_return_option =
354
+
| List_return_subscribed
355
+
| List_return_children
356
+
| List_return_special_use
357
+
358
+
type list_extended_item =
359
+
| Childinfo of string list
360
+
361
+
type list_command =
362
+
| List_basic of { reference : string; pattern : string }
363
+
| List_extended of {
364
+
selection : list_select_option list;
365
+
reference : string;
366
+
patterns : string list;
367
+
return_opts : list_return_option list;
368
+
}
369
+
```
370
+
371
+
**Tasks**:
372
+
1. Update grammar for extended LIST syntax
373
+
2. Add `\NonExistent` and `\Remote` attributes
374
+
3. Implement subscription tracking in storage
375
+
4. Handle RECURSIVEMATCH with CHILDINFO
376
+
5. Add `LIST-EXTENDED` capability
377
+
378
+
---
379
+
380
+
## Phase 3: Advanced Features (P3)
381
+
382
+
### 3.1 UTF-8 Support (RFC 6855)
383
+
384
+
**Source**: `spec/PLAN-rfc6855.md`
385
+
386
+
#### 3.1.1 Session State Tracking
387
+
388
+
```ocaml
389
+
type session_state = {
390
+
utf8_enabled : bool;
391
+
(* ... *)
392
+
}
393
+
```
394
+
395
+
#### 3.1.2 UTF-8 Validation
396
+
397
+
**New file**: `lib/imapd/utf8.ml`
398
+
399
+
```ocaml
400
+
val is_valid_utf8 : string -> bool
401
+
val has_non_ascii : string -> bool
402
+
val is_valid_utf8_mailbox_name : string -> bool
403
+
```
404
+
405
+
#### 3.1.3 ENABLE Handler Update
406
+
407
+
Track UTF8=ACCEPT state, reject SEARCH with CHARSET after enable.
408
+
409
+
#### 3.1.4 UTF8 APPEND Extension
410
+
411
+
Parse `UTF8 (literal)` syntax for 8-bit headers.
412
+
413
+
**Tests**:
414
+
```ocaml
415
+
let test_utf8_validation () =
416
+
assert (Utf8.is_valid_utf8 "Hello");
417
+
assert (Utf8.is_valid_utf8 "\xe4\xb8\xad\xe6\x96\x87");
418
+
assert (not (Utf8.is_valid_utf8 "\xff\xfe"))
419
+
```
420
+
421
+
### 3.2 CONDSTORE/QRESYNC (RFC 7162)
422
+
423
+
**Source**: `lib/imap/PLAN.md` - P2, `PLAN.md` - Phase 2.2
424
+
425
+
#### 3.2.1 CONDSTORE Types
426
+
427
+
```ocaml
428
+
(* Fetch items *)
429
+
| Modseq
430
+
| Item_modseq of int64
431
+
432
+
(* Response codes *)
433
+
| Highestmodseq of int64
434
+
| Nomodseq
435
+
| Modified of Seq.t
436
+
437
+
(* Command modifiers *)
438
+
type fetch_modifier = { changedsince : int64 option }
439
+
type store_modifier = { unchangedsince : int64 option }
440
+
```
441
+
442
+
#### 3.2.2 Storage Backend
443
+
444
+
Add `modseq` to message type and mailbox state:
445
+
```ocaml
446
+
type message = {
447
+
(* existing *)
448
+
modseq : int64;
449
+
}
450
+
451
+
type mailbox_state = {
452
+
(* existing *)
453
+
highestmodseq : int64;
454
+
}
455
+
```
456
+
457
+
#### 3.2.3 QRESYNC
458
+
459
+
```ocaml
460
+
type qresync_params = {
461
+
uidvalidity : int32;
462
+
modseq : int64;
463
+
known_uids : Seq.t option;
464
+
seq_match : (Seq.t * Seq.t) option;
465
+
}
466
+
467
+
(* Response *)
468
+
| Vanished of { earlier : bool; uids : Seq.t }
469
+
```
470
+
471
+
---
472
+
473
+
## Phase 4: Polish and Infrastructure (P4)
474
+
475
+
### 4.1 RFC 5530 Response Code Documentation
476
+
477
+
**Source**: `spec/PLAN-rfc5530.md`
478
+
479
+
All 16 response codes already implemented. Add OCamldoc citations.
480
+
481
+
### 4.2 Unified Mail Flag Library
482
+
483
+
**Source**: `spec/PLAN-unified-mail-flag.md`
484
+
485
+
Create shared `mail-flag` library for IMAP/JMAP:
486
+
487
+
```
488
+
mail-flag/
489
+
├── keyword.ml # Message keywords (typed variants)
490
+
├── system_flag.ml # IMAP \Seen, \Deleted, etc.
491
+
├── mailbox_attr.ml # Mailbox attributes/roles
492
+
├── flag_color.ml # Apple Mail flag colors
493
+
├── imap_wire.ml # IMAP serialization
494
+
└── jmap_wire.ml # JMAP serialization
495
+
```
496
+
497
+
### 4.3 Infrastructure Improvements
498
+
499
+
**Source**: `PLAN.md` - Phase 1
500
+
501
+
1. **Replace Menhir with Eio.Buf_read** - Pure functional parser
502
+
2. **Integrate conpool** - Connection pooling for client
503
+
3. **Add bytesrw streaming** - Large message handling
504
+
4. **Fuzz testing** - Parser robustness with Crowbar
505
+
5. **Eio mock testing** - Deterministic tests
506
+
507
+
---
508
+
509
+
## Testing Strategy
510
+
511
+
### Unit Tests
512
+
513
+
Each module should have corresponding tests in `test/`:
514
+
515
+
| Module | Test File | Coverage |
516
+
|--------|-----------|----------|
517
+
| `lib/imap/read.ml` | `test/test_read.ml` | Response parsing |
518
+
| `lib/imap/write.ml` | `test/test_write.ml` | Command serialization |
519
+
| `lib/imap/subject.ml` | `test/test_subject.ml` | Base subject extraction |
520
+
| `lib/imap/thread.ml` | `test/test_thread.ml` | Threading algorithms |
521
+
| `lib/imapd/server.ml` | `test/test_server.ml` | Command handlers |
522
+
| `lib/imapd/storage.ml` | `test/test_storage.ml` | Storage backends |
523
+
524
+
### Integration Tests
525
+
526
+
**File**: `test/integration/`
527
+
528
+
- Protocol compliance testing against real servers
529
+
- ImapTest compatibility suite
530
+
- Dovecot interoperability
531
+
532
+
### Fuzz Tests
533
+
534
+
**File**: `test/fuzz_parser.ml`
535
+
536
+
```ocaml
537
+
let fuzz_command_parser =
538
+
Crowbar.(map [bytes] (fun input ->
539
+
try
540
+
ignore (Imap_parser.parse_command input);
541
+
true
542
+
with _ -> true (* Parser should never crash *)
543
+
))
544
+
```
545
+
546
+
---
547
+
548
+
## Implementation Order
549
+
550
+
### Sprint 1: P0 Critical Fixes
551
+
1. [ ] Fix SEARCH response parsing
552
+
2. [ ] Parse BODY/BODYSTRUCTURE responses
553
+
3. [ ] Parse BODY[section] literals
554
+
555
+
### Sprint 2: P1 Core Compliance
556
+
4. [ ] Complete ESEARCH support
557
+
5. [ ] Parse APPENDUID/COPYUID response codes
558
+
6. [ ] Add UNSELECT to capabilities
559
+
7. [ ] Complete SPECIAL-USE support
560
+
561
+
### Sprint 3: P2 SORT/THREAD
562
+
8. [ ] Thread module types
563
+
9. [ ] Base subject extraction
564
+
10. [ ] Sent date handling
565
+
11. [ ] ORDEREDSUBJECT algorithm
566
+
12. [ ] REFERENCES algorithm
567
+
13. [ ] Server SORT/THREAD handlers
568
+
569
+
### Sprint 4: P2 QUOTA
570
+
14. [ ] Quota protocol types
571
+
15. [ ] Storage backend interface
572
+
16. [ ] Memory storage quota
573
+
17. [ ] Maildir storage quota
574
+
18. [ ] Server handlers
575
+
576
+
### Sprint 5: P2 LIST-EXTENDED
577
+
19. [ ] Extended LIST grammar
578
+
20. [ ] New attributes
579
+
21. [ ] Subscription tracking
580
+
22. [ ] RECURSIVEMATCH support
581
+
582
+
### Sprint 6: P3 UTF-8 & CONDSTORE
583
+
23. [ ] UTF-8 session state
584
+
24. [ ] UTF-8 validation
585
+
25. [ ] UTF8 APPEND extension
586
+
26. [ ] CONDSTORE types
587
+
27. [ ] CONDSTORE handlers
588
+
28. [ ] QRESYNC support
589
+
590
+
### Sprint 7: P4 Polish
591
+
29. [ ] Response code documentation
592
+
30. [ ] Unified mail flag library
593
+
31. [ ] Infrastructure improvements
594
+
32. [ ] Comprehensive test suite
595
+
596
+
---
597
+
598
+
## File Modification Summary
599
+
600
+
### New Files
601
+
602
+
| File | Purpose |
603
+
|------|---------|
604
+
| `lib/imap/thread.ml` | Thread types and parsing |
605
+
| `lib/imap/subject.ml` | Base subject extraction |
606
+
| `lib/imap/date.ml` | Sent date handling |
607
+
| `lib/imap/collation.ml` | Unicode collation |
608
+
| `lib/imap/mime.ml` | RFC 2047 decoding |
609
+
| `lib/imapd/thread.ml` | Threading algorithms |
610
+
| `lib/imapd/utf8.ml` | UTF-8 validation |
611
+
| `test/test_subject.ml` | Subject tests |
612
+
| `test/test_thread.ml` | Threading tests |
613
+
| `test/test_quota.ml` | Quota tests |
614
+
| `test/fuzz_parser.ml` | Fuzz tests |
615
+
616
+
### Modified Files
617
+
618
+
| File | Changes |
619
+
|------|---------|
620
+
| `lib/imap/read.ml` | SEARCH, ESEARCH, BODY parsing |
621
+
| `lib/imap/write.ml` | ESEARCH, THREAD serialization |
622
+
| `lib/imap/command.ml` | Return options, THREAD command |
623
+
| `lib/imap/response.ml` | ESEARCH, THREAD responses |
624
+
| `lib/imap/client.ml` | Fix search, add esearch/thread |
625
+
| `lib/imap/code.ml` | OCamldoc citations |
626
+
| `lib/imap/list_attr.ml` | Add NonExistent, Remote |
627
+
| `lib/imapd/protocol.ml` | Quota types, LIST-EXTENDED |
628
+
| `lib/imapd/server.ml` | Handlers, capabilities |
629
+
| `lib/imapd/storage.ml` | Quota ops, subscription tracking |
630
+
| `lib/imapd/grammar.mly` | Extended LIST, QUOTA, UTF8 |
631
+
| `lib/imapd/lexer.mll` | New tokens |
632
+
| `lib/imapd/parser.ml` | Response serialization |
633
+
634
+
---
635
+
636
+
## Design Principles
637
+
638
+
1. **Favor OCaml variants** - Use typed variants over strings where possible
639
+
2. **No backwards compatibility** - Clean API without legacy shims
640
+
3. **RFC citations** - OCamldoc links to RFC sections
641
+
4. **Incremental** - Each task is independently useful
642
+
5. **Test-driven** - Tests accompany each feature
643
+
6. **Eio-native** - Use Eio patterns throughout
644
+
645
+
---
646
+
647
+
## References
648
+
649
+
### Implemented RFCs
650
+
- RFC 9051 - IMAP4rev2 (core)
651
+
- RFC 8314 - Implicit TLS
652
+
- RFC 2177 - IDLE
653
+
- RFC 2342 - NAMESPACE
654
+
- RFC 2971 - ID
655
+
- RFC 4315 - UIDPLUS
656
+
- RFC 5161 - ENABLE
657
+
- RFC 6851 - MOVE
658
+
- RFC 7888 - LITERAL+
659
+
660
+
### RFCs in This Plan
661
+
- RFC 3691 - UNSELECT (partially complete)
662
+
- RFC 4731 - ESEARCH
663
+
- RFC 5256 - SORT/THREAD
664
+
- RFC 5258 - LIST-EXTENDED
665
+
- RFC 5530 - Response Codes (types complete)
666
+
- RFC 6154 - SPECIAL-USE (partially complete)
667
+
- RFC 6855 - UTF-8 Support
668
+
- RFC 7162 - CONDSTORE/QRESYNC
669
+
- RFC 9208 - QUOTA
+48
-2
lib/imap/client.ml
+48
-2
lib/imap/client.ml
···
570
570
571
571
let search t ?charset criteria =
572
572
require_selected t;
573
-
let tag = send_command t (Command.Search { charset; criteria }) in
573
+
let tag = send_command t (Command.Search { charset; criteria; return_opts = None }) in
574
574
let untagged, final = receive_responses t tag in
575
575
check_ok tag untagged final;
576
576
(* Extract search results from untagged responses *)
···
582
582
583
583
let uid_search t ?charset criteria =
584
584
require_selected t;
585
-
let tag = send_command t (Command.Uid (Uid_search { charset; criteria })) in
585
+
let tag = send_command t (Command.Uid (Uid_search { charset; criteria; return_opts = None })) in
586
586
let untagged, final = receive_responses t tag in
587
587
check_ok tag untagged final;
588
588
(* Extract UID search results from untagged responses - UIDs are returned as int64 *)
···
685
685
(function Response.Enabled exts -> enabled := exts | _ -> ())
686
686
untagged;
687
687
!enabled
688
+
689
+
(** {1 ESEARCH Support (RFC 4731)} *)
690
+
691
+
type esearch_result = {
692
+
min : int option;
693
+
max : int option;
694
+
count : int option;
695
+
all : Seq.t option;
696
+
}
697
+
698
+
let empty_esearch_result = {
699
+
min = None;
700
+
max = None;
701
+
count = None;
702
+
all = None;
703
+
}
704
+
705
+
let parse_esearch_response responses =
706
+
List.fold_left (fun acc resp ->
707
+
match resp with
708
+
| Response.Esearch { results; _ } ->
709
+
List.fold_left (fun acc item ->
710
+
match item with
711
+
| Response.Esearch_min n -> { acc with min = Some n }
712
+
| Response.Esearch_max n -> { acc with max = Some n }
713
+
| Response.Esearch_count n -> { acc with count = Some n }
714
+
| Response.Esearch_all seq -> { acc with all = Some seq }
715
+
) acc results
716
+
| _ -> acc
717
+
) empty_esearch_result responses
718
+
719
+
let esearch t ?charset ?(return_opts = [Command.Return_all]) criteria =
720
+
require_selected t;
721
+
require_capability t "ESEARCH";
722
+
let tag = send_command t (Command.Search { charset; criteria; return_opts = Some return_opts }) in
723
+
let untagged, final = receive_responses t tag in
724
+
check_ok tag untagged final;
725
+
parse_esearch_response untagged
726
+
727
+
let uid_esearch t ?charset ?(return_opts = [Command.Return_all]) criteria =
728
+
require_selected t;
729
+
require_capability t "ESEARCH";
730
+
let tag = send_command t (Command.Uid (Uid_search { charset; criteria; return_opts = Some return_opts })) in
731
+
let untagged, final = receive_responses t tag in
732
+
check_ok tag untagged final;
733
+
parse_esearch_response untagged
+30
lib/imap/client.mli
+30
lib/imap/client.mli
···
247
247
248
248
val enable : t -> string list -> string list
249
249
(** [enable client extensions] enables protocol extensions. *)
250
+
251
+
(** {1 ESEARCH Support (RFC 4731)} *)
252
+
253
+
type esearch_result = {
254
+
min : int option;
255
+
max : int option;
256
+
count : int option;
257
+
all : Seq.t option;
258
+
}
259
+
(** ESEARCH result containing optional min, max, count, and all values. *)
260
+
261
+
val esearch :
262
+
t ->
263
+
?charset:string ->
264
+
?return_opts:Command.search_return_opt list ->
265
+
Search.t ->
266
+
esearch_result
267
+
(** [esearch client ?charset ?return_opts criteria] performs an extended search.
268
+
Returns an {!esearch_result} with the requested information.
269
+
Default [return_opts] is [[Return_all]].
270
+
Requires ESEARCH extension. *)
271
+
272
+
val uid_esearch :
273
+
t ->
274
+
?charset:string ->
275
+
?return_opts:Command.search_return_opt list ->
276
+
Search.t ->
277
+
esearch_result
278
+
(** [uid_esearch client ?charset ?return_opts criteria] like {!esearch} but for UID searches.
279
+
Requires ESEARCH extension. *)
+6
lib/imap/code.ml
+6
lib/imap/code.ml
···
24
24
| Expired
25
25
| Expungeissued
26
26
| Haschildren
27
+
| Highestmodseq of int64 (** Highest MODSEQ in mailbox - RFC 7162 CONDSTORE *)
27
28
| Inuse
28
29
| Limit
30
+
| Modified of Seq.t (** Messages modified since UNCHANGEDSINCE - RFC 7162 CONDSTORE *)
31
+
| Nomodseq (** Mailbox doesn't support MODSEQ - RFC 7162 CONDSTORE *)
29
32
| Nonexistent
30
33
| Noperm
31
34
| Overquota
···
61
64
| Expired -> Fmt.string ppf "EXPIRED"
62
65
| Expungeissued -> Fmt.string ppf "EXPUNGEISSUED"
63
66
| Haschildren -> Fmt.string ppf "HASCHILDREN"
67
+
| Highestmodseq m -> Fmt.pf ppf "HIGHESTMODSEQ %Ld" m
64
68
| Inuse -> Fmt.string ppf "INUSE"
65
69
| Limit -> Fmt.string ppf "LIMIT"
70
+
| Modified s -> Fmt.pf ppf "MODIFIED %a" Seq.pp s
71
+
| Nomodseq -> Fmt.string ppf "NOMODSEQ"
66
72
| Nonexistent -> Fmt.string ppf "NONEXISTENT"
67
73
| Noperm -> Fmt.string ppf "NOPERM"
68
74
| Overquota -> Fmt.string ppf "OVERQUOTA"
+3
lib/imap/code.mli
+3
lib/imap/code.mli
···
24
24
| Expired
25
25
| Expungeissued
26
26
| Haschildren
27
+
| Highestmodseq of int64 (** Highest MODSEQ in mailbox - RFC 7162 CONDSTORE *)
27
28
| Inuse
28
29
| Limit
30
+
| Modified of Seq.t (** Messages modified since UNCHANGEDSINCE - RFC 7162 CONDSTORE *)
31
+
| Nomodseq (** Mailbox doesn't support MODSEQ - RFC 7162 CONDSTORE *)
29
32
| Nonexistent
30
33
| Noperm
31
34
| Overquota
+13
-2
lib/imap/command.ml
+13
-2
lib/imap/command.ml
···
7
7
8
8
Client-to-server commands as specified in RFC 9051. *)
9
9
10
+
(** ESEARCH return options (RFC 4731) *)
11
+
type search_return_opt =
12
+
| Return_min (** Return minimum matching sequence number/UID *)
13
+
| Return_max (** Return maximum matching sequence number/UID *)
14
+
| Return_all (** Return all matching sequence numbers/UIDs as a sequence set *)
15
+
| Return_count (** Return count of matching messages *)
16
+
10
17
type t =
11
18
| Capability
12
19
| Noop
···
35
42
| Close
36
43
| Unselect
37
44
| Expunge
38
-
| Search of { charset : string option; criteria : Search.t }
45
+
| Search of { charset : string option; criteria : Search.t; return_opts : search_return_opt list option }
39
46
| Sort of { charset : string; criteria : Sort.t; search : Search.t }
47
+
| Thread of { algorithm : Thread.algorithm; charset : string; search : Search.t }
40
48
| Fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
41
49
| Store of {
42
50
sequence : Seq.t;
···
61
69
}
62
70
| Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
63
71
| Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
64
-
| Uid_search of { charset : string option; criteria : Search.t }
72
+
| Uid_search of { charset : string option; criteria : Search.t; return_opts : search_return_opt list option }
65
73
| Uid_sort of { charset : string; criteria : Sort.t; search : Search.t }
74
+
| Uid_thread of { algorithm : Thread.algorithm; charset : string; search : Search.t }
66
75
| Uid_expunge of Seq.t
67
76
68
77
type tagged = { tag : string; command : t }
···
95
104
| Expunge -> Fmt.string ppf "EXPUNGE"
96
105
| Search _ -> Fmt.string ppf "SEARCH (...)"
97
106
| Sort _ -> Fmt.string ppf "SORT (...)"
107
+
| Thread _ -> Fmt.string ppf "THREAD (...)"
98
108
| Fetch { sequence; _ } -> Fmt.pf ppf "FETCH %a (...)" Seq.pp sequence
99
109
| Store { sequence; action; _ } ->
100
110
let action_str = match action with Store.Set -> "FLAGS" | Store.Add -> "+FLAGS" | Store.Remove -> "-FLAGS" in
···
113
123
| Uid_move { sequence; mailbox } -> Fmt.pf ppf "MOVE %a %s" Seq.pp sequence mailbox
114
124
| Uid_search _ -> Fmt.string ppf "SEARCH (...)"
115
125
| Uid_sort _ -> Fmt.string ppf "SORT (...)"
126
+
| Uid_thread _ -> Fmt.string ppf "THREAD (...)"
116
127
| Uid_expunge seq -> Fmt.pf ppf "EXPUNGE %a" Seq.pp seq
+11
-2
lib/imap/command.mli
+11
-2
lib/imap/command.mli
···
7
7
8
8
Client-to-server commands as specified in RFC 9051. *)
9
9
10
+
(** ESEARCH return options (RFC 4731) *)
11
+
type search_return_opt =
12
+
| Return_min (** Return minimum matching sequence number/UID *)
13
+
| Return_max (** Return maximum matching sequence number/UID *)
14
+
| Return_all (** Return all matching sequence numbers/UIDs as a sequence set *)
15
+
| Return_count (** Return count of matching messages *)
16
+
10
17
type t =
11
18
| Capability
12
19
| Noop
···
35
42
| Close
36
43
| Unselect
37
44
| Expunge
38
-
| Search of { charset : string option; criteria : Search.t }
45
+
| Search of { charset : string option; criteria : Search.t; return_opts : search_return_opt list option }
39
46
| Sort of { charset : string; criteria : Sort.t; search : Search.t }
47
+
| Thread of { algorithm : Thread.algorithm; charset : string; search : Search.t }
40
48
| Fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
41
49
| Store of {
42
50
sequence : Seq.t;
···
61
69
}
62
70
| Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
63
71
| Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
64
-
| Uid_search of { charset : string option; criteria : Search.t }
72
+
| Uid_search of { charset : string option; criteria : Search.t; return_opts : search_return_opt list option }
65
73
| Uid_sort of { charset : string; criteria : Sort.t; search : Search.t }
74
+
| Uid_thread of { algorithm : Thread.algorithm; charset : string; search : Search.t }
66
75
| Uid_expunge of Seq.t
67
76
68
77
type tagged = { tag : string; command : t }
+2
lib/imap/fetch.ml
+2
lib/imap/fetch.ml
···
25
25
| Binary of string * (int * int) option
26
26
| Binary_peek of string * (int * int) option
27
27
| Binary_size of string
28
+
| Modseq (** Request MODSEQ value - RFC 7162 CONDSTORE *)
28
29
29
30
let pp_request ppf = function
30
31
| Envelope -> Fmt.string ppf "ENVELOPE"
···
42
43
| Binary (s, _) -> Fmt.pf ppf "BINARY[%s]" s
43
44
| Binary_peek (s, _) -> Fmt.pf ppf "BINARY.PEEK[%s]" s
44
45
| Binary_size s -> Fmt.pf ppf "BINARY.SIZE[%s]" s
46
+
| Modseq -> Fmt.string ppf "MODSEQ"
45
47
46
48
(** {1 Response Items} *)
47
49
+1
lib/imap/fetch.mli
+1
lib/imap/fetch.mli
+3
lib/imap/imap.ml
+3
lib/imap/imap.ml
···
57
57
- {!module:Fetch} - FETCH request/response items
58
58
- {!module:Search} - SEARCH criteria
59
59
- {!module:Sort} - SORT criteria (RFC 5256)
60
+
- {!module:Subject} - Base subject extraction (RFC 5256)
60
61
- {!module:Store} - STORE actions
61
62
- {!module:Status} - STATUS items
62
63
- {!module:List_attr} - LIST mailbox attributes
···
99
100
module Store = Store
100
101
module Status = Status
101
102
module List_attr = List_attr
103
+
module Subject = Subject
104
+
module Thread = Thread
102
105
103
106
(** {1 Client} *)
104
107
+3
lib/imap/imap.mli
+3
lib/imap/imap.mli
···
57
57
- {!module:Fetch} - FETCH request/response items
58
58
- {!module:Search} - SEARCH criteria
59
59
- {!module:Sort} - SORT criteria (RFC 5256)
60
+
- {!module:Subject} - Base subject extraction (RFC 5256)
60
61
- {!module:Store} - STORE actions
61
62
- {!module:Status} - STATUS items
62
63
- {!module:List_attr} - LIST mailbox attributes
···
99
100
module Store = Store
100
101
module Status = Status
101
102
module List_attr = List_attr
103
+
module Subject = Subject
104
+
module Thread = Thread
102
105
103
106
(** {1 Client} *)
104
107
+530
-78
lib/imap/read.ml
+530
-78
lib/imap/read.ml
···
106
106
in
107
107
loop []
108
108
109
+
(** {1 UID Set Parsing}
110
+
111
+
Parses UID sets in the format used by APPENDUID/COPYUID response codes.
112
+
Examples: "304", "319:320", "304,319:320,325" *)
113
+
114
+
let uid_set_range r =
115
+
let first = number r in
116
+
match R.peek_char r with
117
+
| Some ':' ->
118
+
R.char ':' r;
119
+
(* Check for * (wildcard) *)
120
+
(match R.peek_char r with
121
+
| Some '*' ->
122
+
R.char '*' r;
123
+
Seq.From first
124
+
| _ ->
125
+
let last = number r in
126
+
Seq.Range (first, last))
127
+
| _ -> Seq.Single first
128
+
129
+
let uid_set r =
130
+
let rec loop acc =
131
+
let range = uid_set_range r in
132
+
match R.peek_char r with
133
+
| Some ',' ->
134
+
R.char ',' r;
135
+
loop (range :: acc)
136
+
| _ -> List.rev (range :: acc)
137
+
in
138
+
loop []
139
+
109
140
(** {1 Flags} *)
110
141
111
142
let system_flag r =
···
175
206
in
176
207
loop []
177
208
209
+
(** {1 Body Structure Parsing} *)
210
+
211
+
(** Parse a parenthesized list of key-value pairs for body parameters.
212
+
Format: ("key1" "value1" "key2" "value2" ...) or NIL *)
213
+
let body_params r =
214
+
if is_nil r then (skip_nil r; [])
215
+
else (
216
+
R.char '(' r;
217
+
let rec loop acc =
218
+
match R.peek_char r with
219
+
| Some ')' ->
220
+
R.char ')' r;
221
+
List.rev acc
222
+
| Some ' ' ->
223
+
sp r;
224
+
loop acc
225
+
| _ ->
226
+
let k = astring r in
227
+
sp r;
228
+
let v = astring r in
229
+
loop ((k, v) :: acc)
230
+
in
231
+
loop [])
232
+
233
+
(** Parse body fields common to all body types.
234
+
Format: params content-id content-desc encoding size *)
235
+
let body_fields r =
236
+
let params = body_params r in
237
+
sp r;
238
+
let content_id = nstring r in
239
+
sp r;
240
+
let description = nstring r in
241
+
sp r;
242
+
let encoding = astring r in
243
+
sp r;
244
+
let size = number64 r in
245
+
Body.{ params; content_id; description; encoding; size }
246
+
247
+
(** Parse body disposition.
248
+
Format: ("INLINE" ("filename" "test.txt")) or NIL *)
249
+
let body_disposition r =
250
+
if is_nil r then (skip_nil r; None)
251
+
else (
252
+
R.char '(' r;
253
+
let disposition_type = astring r in
254
+
sp r;
255
+
let params = body_params r in
256
+
R.char ')' r;
257
+
Some (disposition_type, params))
258
+
259
+
(** Parse body language - single string or list of strings.
260
+
Format: NIL or "en" or ("en" "de") *)
261
+
let body_language r =
262
+
if is_nil r then (skip_nil r; None)
263
+
else
264
+
match R.peek_char r with
265
+
| Some '(' ->
266
+
(* List of languages *)
267
+
R.char '(' r;
268
+
let rec loop acc =
269
+
match R.peek_char r with
270
+
| Some ')' ->
271
+
R.char ')' r;
272
+
Some (List.rev acc)
273
+
| Some ' ' ->
274
+
sp r;
275
+
loop acc
276
+
| _ ->
277
+
let lang = astring r in
278
+
loop (lang :: acc)
279
+
in
280
+
loop []
281
+
| _ ->
282
+
(* Single language *)
283
+
Some [astring r]
284
+
285
+
(** Skip remaining body extensions after the known ones *)
286
+
let rec skip_body_extension r =
287
+
match R.peek_char r with
288
+
| Some '(' ->
289
+
R.char '(' r;
290
+
let rec loop () =
291
+
match R.peek_char r with
292
+
| Some ')' -> R.char ')' r
293
+
| Some ' ' -> sp r; loop ()
294
+
| _ -> skip_body_extension r; loop ()
295
+
in
296
+
loop ()
297
+
| Some '"' -> ignore (quoted_string r)
298
+
| Some '{' -> ignore (literal r)
299
+
| _ when is_nil r -> skip_nil r
300
+
| _ ->
301
+
(* Could be a number or atom *)
302
+
ignore (R.take_while (fun c -> c <> ' ' && c <> ')' && c <> '\r') r)
303
+
304
+
let skip_remaining_extensions r =
305
+
while R.peek_char r = Some ' ' do
306
+
sp r;
307
+
match R.peek_char r with
308
+
| Some ')' -> () (* End of body, don't consume *)
309
+
| _ -> skip_body_extension r
310
+
done
311
+
178
312
(** {1 Response Codes} *)
179
313
180
314
let response_code r =
···
184
318
match String.uppercase_ascii name with
185
319
| "ALERT" -> Code.Alert
186
320
| "ALREADYEXISTS" -> Code.Alreadyexists
321
+
| "APPENDUID" ->
322
+
sp r;
323
+
let uidvalidity = number64 r in
324
+
sp r;
325
+
let uid = number64 r in
326
+
Code.Appenduid (uidvalidity, uid)
187
327
| "AUTHENTICATIONFAILED" -> Code.Authenticationfailed
188
328
| "AUTHORIZATIONFAILED" -> Code.Authorizationfailed
189
329
| "CANNOT" -> Code.Cannot
···
191
331
| "CLIENTBUG" -> Code.Clientbug
192
332
| "CLOSED" -> Code.Closed
193
333
| "CONTACTADMIN" -> Code.Contactadmin
334
+
| "COPYUID" ->
335
+
sp r;
336
+
let uidvalidity = number64 r in
337
+
sp r;
338
+
let source_uids = uid_set r in
339
+
sp r;
340
+
let dest_uids = uid_set r in
341
+
Code.Copyuid (uidvalidity, source_uids, dest_uids)
194
342
| "CORRUPTION" -> Code.Corruption
195
343
| "EXPIRED" -> Code.Expired
196
344
| "EXPUNGEISSUED" -> Code.Expungeissued
197
345
| "HASCHILDREN" -> Code.Haschildren
346
+
| "HIGHESTMODSEQ" ->
347
+
(* RFC 7162 Section 3.1.2.1: HIGHESTMODSEQ response code
348
+
Returned in SELECT/EXAMINE to indicate the highest mod-sequence
349
+
value of all messages in the mailbox. *)
350
+
sp r;
351
+
Code.Highestmodseq (number64 r)
198
352
| "INUSE" -> Code.Inuse
199
353
| "LIMIT" -> Code.Limit
354
+
| "MODIFIED" ->
355
+
(* RFC 7162 Section 3.1.3: MODIFIED response code
356
+
Returned in response to STORE with UNCHANGEDSINCE modifier
357
+
when messages have been modified since the specified mod-sequence. *)
358
+
sp r;
359
+
Code.Modified (uid_set r)
360
+
| "NOMODSEQ" ->
361
+
(* RFC 7162 Section 3.1.2.2: NOMODSEQ response code
362
+
Indicates that the mailbox does not support persistent storage
363
+
of mod-sequences (e.g., a virtual mailbox). *)
364
+
Code.Nomodseq
200
365
| "NONEXISTENT" -> Code.Nonexistent
201
366
| "NOPERM" -> Code.Noperm
202
367
| "OVERQUOTA" -> Code.Overquota
···
286
451
R.char ')' r;
287
452
Envelope.{ date; subject; from; sender; reply_to; to_; cc; bcc; in_reply_to; message_id }
288
453
454
+
(** {1 Body Structure Parsing - Recursive Part}
455
+
456
+
These functions parse body structures per RFC 9051 Section 7.4.2.
457
+
They must be defined after envelope since MESSAGE/RFC822 bodies contain envelopes. *)
458
+
459
+
(** Parse a single body part (non-multipart).
460
+
Returns the body type and optional extension data. *)
461
+
let rec body_type_1part r =
462
+
let media_type = astring r in
463
+
sp r;
464
+
let subtype = astring r in
465
+
sp r;
466
+
let fields = body_fields r in
467
+
let media_type_upper = String.uppercase_ascii media_type in
468
+
469
+
(* Parse type-specific fields and build body_type *)
470
+
let (body_type : Body.body_type) =
471
+
if media_type_upper = "TEXT" then (
472
+
sp r;
473
+
let lines = number64 r in
474
+
Text { subtype; fields; lines }
475
+
) else if media_type_upper = "MESSAGE" && String.uppercase_ascii subtype = "RFC822" then (
476
+
sp r;
477
+
let env = envelope r in
478
+
sp r;
479
+
let nested_body = body r in
480
+
sp r;
481
+
let lines = number64 r in
482
+
Message_rfc822 { fields; envelope = env; body = nested_body; lines }
483
+
) else
484
+
Basic { media_type; subtype; fields }
485
+
in
486
+
487
+
(* Parse optional extension data for BODYSTRUCTURE *)
488
+
let disposition, language, location =
489
+
match R.peek_char r with
490
+
| Some ' ' -> (
491
+
sp r;
492
+
match R.peek_char r with
493
+
| Some ')' -> (None, None, None) (* End of body *)
494
+
| _ ->
495
+
(* md5 - skip it *)
496
+
ignore (nstring r);
497
+
match R.peek_char r with
498
+
| Some ' ' -> (
499
+
sp r;
500
+
match R.peek_char r with
501
+
| Some ')' -> (None, None, None)
502
+
| _ ->
503
+
let disposition = body_disposition r in
504
+
match R.peek_char r with
505
+
| Some ' ' -> (
506
+
sp r;
507
+
match R.peek_char r with
508
+
| Some ')' -> (disposition, None, None)
509
+
| _ ->
510
+
let language = body_language r in
511
+
match R.peek_char r with
512
+
| Some ' ' -> (
513
+
sp r;
514
+
match R.peek_char r with
515
+
| Some ')' -> (disposition, language, None)
516
+
| _ ->
517
+
let location = nstring r in
518
+
skip_remaining_extensions r;
519
+
(disposition, language, location))
520
+
| _ -> (disposition, language, None))
521
+
| _ -> (disposition, None, None))
522
+
| _ -> (None, None, None))
523
+
| _ -> (None, None, None)
524
+
in
525
+
526
+
Body.{ body_type; disposition; language; location }
527
+
528
+
(** Parse multipart body structure.
529
+
Format: (body)(body)... "subtype" [extensions] *)
530
+
and body_type_mpart r =
531
+
(* Collect all nested body parts *)
532
+
let rec collect_parts acc =
533
+
match R.peek_char r with
534
+
| Some '(' ->
535
+
let part = body r in
536
+
collect_parts (part :: acc)
537
+
| _ -> List.rev acc
538
+
in
539
+
let parts = collect_parts [] in
540
+
541
+
(* Parse subtype *)
542
+
sp r;
543
+
let subtype = astring r in
544
+
545
+
(* Parse optional extension data for BODYSTRUCTURE *)
546
+
let params, disposition, language, location =
547
+
match R.peek_char r with
548
+
| Some ' ' -> (
549
+
sp r;
550
+
match R.peek_char r with
551
+
| Some ')' -> ([], None, None, None)
552
+
| _ ->
553
+
let params = body_params r in
554
+
match R.peek_char r with
555
+
| Some ' ' -> (
556
+
sp r;
557
+
match R.peek_char r with
558
+
| Some ')' -> (params, None, None, None)
559
+
| _ ->
560
+
let disposition = body_disposition r in
561
+
match R.peek_char r with
562
+
| Some ' ' -> (
563
+
sp r;
564
+
match R.peek_char r with
565
+
| Some ')' -> (params, disposition, None, None)
566
+
| _ ->
567
+
let language = body_language r in
568
+
match R.peek_char r with
569
+
| Some ' ' -> (
570
+
sp r;
571
+
match R.peek_char r with
572
+
| Some ')' -> (params, disposition, language, None)
573
+
| _ ->
574
+
let location = nstring r in
575
+
skip_remaining_extensions r;
576
+
(params, disposition, language, location))
577
+
| _ -> (params, disposition, language, None))
578
+
| _ -> (params, disposition, None, None))
579
+
| _ -> (params, None, None, None))
580
+
| _ -> ([], None, None, None)
581
+
in
582
+
583
+
Body.{
584
+
body_type = Multipart { subtype; parts; params };
585
+
disposition;
586
+
language;
587
+
location;
588
+
}
589
+
590
+
(** Parse a body structure - either multipart or single part.
591
+
Multipart starts with nested parentheses, single part starts with a string. *)
592
+
and body r =
593
+
R.char '(' r;
594
+
let result =
595
+
match R.peek_char r with
596
+
| Some '(' ->
597
+
(* Multipart - starts with nested body *)
598
+
body_type_mpart r
599
+
| _ ->
600
+
(* Single part - starts with media type string *)
601
+
body_type_1part r
602
+
in
603
+
R.char ')' r;
604
+
result
605
+
606
+
(** {1 Section Specifier Parsing}
607
+
608
+
Parse section specifiers like HEADER, TEXT, 1.2.MIME, HEADER.FIELDS (From Subject) *)
609
+
610
+
(** Parse a header field list like (From Subject To).
611
+
Note: Currently unused as HEADER.FIELDS parsing is simplified. *)
612
+
let _parse_header_fields r =
613
+
sp r;
614
+
R.char '(' r;
615
+
let rec loop acc =
616
+
match R.peek_char r with
617
+
| Some ')' ->
618
+
R.char ')' r;
619
+
List.rev acc
620
+
| Some ' ' ->
621
+
sp r;
622
+
loop acc
623
+
| _ ->
624
+
let field = astring r in
625
+
loop (field :: acc)
626
+
in
627
+
loop []
628
+
629
+
(** Parse a section specifier string into a Body.section option.
630
+
Section format per RFC 9051:
631
+
- Empty string means whole message
632
+
- HEADER, TEXT, MIME
633
+
- HEADER.FIELDS (field list)
634
+
- HEADER.FIELDS.NOT (field list)
635
+
- Part number like 1, 1.2, 1.2.3
636
+
- Part number with subsection like 1.HEADER, 1.2.TEXT, 1.2.MIME *)
637
+
let parse_section_spec section_str =
638
+
if section_str = "" then None
639
+
else
640
+
let upper = String.uppercase_ascii section_str in
641
+
if upper = "HEADER" then Some Body.Header
642
+
else if upper = "TEXT" then Some Body.Text
643
+
else if upper = "MIME" then Some Body.Mime
644
+
else if String.length upper > 14 && String.sub upper 0 14 = "HEADER.FIELDS " then
645
+
(* HEADER.FIELDS (field1 field2...) - simplified parsing *)
646
+
Some Body.Header
647
+
else if String.length upper > 18 && String.sub upper 0 18 = "HEADER.FIELDS.NOT " then
648
+
(* HEADER.FIELDS.NOT (field1 field2...) - simplified parsing *)
649
+
Some Body.Header
650
+
else
651
+
(* Try to parse as part numbers: 1, 1.2, 1.2.3, possibly with .HEADER/.TEXT/.MIME suffix *)
652
+
let parts = String.split_on_char '.' section_str in
653
+
let rec parse_parts nums = function
654
+
| [] -> Some (Body.Part (List.rev nums, None))
655
+
| [s] when String.uppercase_ascii s = "HEADER" ->
656
+
Some (Body.Part (List.rev nums, Some Body.Header))
657
+
| [s] when String.uppercase_ascii s = "TEXT" ->
658
+
Some (Body.Part (List.rev nums, Some Body.Text))
659
+
| [s] when String.uppercase_ascii s = "MIME" ->
660
+
Some (Body.Part (List.rev nums, Some Body.Mime))
661
+
| s :: rest ->
662
+
(try
663
+
let n = int_of_string s in
664
+
parse_parts (n :: nums) rest
665
+
with Failure _ ->
666
+
(* Not a number, and not a known section type at end - skip *)
667
+
Some (Body.Part (List.rev nums, None)))
668
+
in
669
+
parse_parts [] parts
670
+
289
671
(** {1 FETCH Response Items} *)
290
672
291
673
let fetch_item r =
···
333
715
| Some '[' ->
334
716
(* BODY[section]<origin> literal-or-nil *)
335
717
R.char '[' r;
336
-
let _section = R.take_while (fun c -> c <> ']') r in
718
+
let section_str = R.take_while (fun c -> c <> ']') r in
337
719
R.char ']' r;
338
-
(* Skip optional origin <n> *)
720
+
let section = parse_section_spec section_str in
721
+
(* Parse optional origin <n> *)
339
722
let origin =
340
723
if R.peek_char r = Some '<' then (
341
724
R.char '<' r;
···
346
729
in
347
730
sp r;
348
731
let data = nstring r in
349
-
Fetch.Item_body_section { section = None; origin; data }
732
+
Fetch.Item_body_section { section; origin; data }
350
733
| _ ->
351
-
(* BODY without [] means bodystructure - skip for now *)
734
+
(* BODY without [] means basic bodystructure (no extensions) *)
352
735
sp r;
353
-
(* Skip the parenthesized body structure *)
354
-
let depth = ref 0 in
355
-
(match R.peek_char r with
356
-
| Some '(' ->
357
-
R.char '(' r;
358
-
depth := 1;
359
-
while !depth > 0 do
360
-
match R.any_char r with
361
-
| '(' -> incr depth
362
-
| ')' -> decr depth
363
-
| '"' -> ignore (R.take_while (fun c -> c <> '"') r); ignore (R.any_char r)
364
-
| '{' ->
365
-
let len = number r in
366
-
R.char '}' r;
367
-
crlf r;
368
-
ignore (R.take len r)
369
-
| _ -> ()
370
-
done
371
-
| _ -> ());
372
-
(* Return a minimal body structure stub *)
373
-
let stub_body : Body.t = {
374
-
body_type = Body.Basic {
375
-
media_type = "application";
376
-
subtype = "octet-stream";
377
-
fields = {
378
-
params = [];
379
-
content_id = None;
380
-
description = None;
381
-
encoding = "7bit";
382
-
size = 0L;
383
-
}
384
-
};
385
-
disposition = None;
386
-
language = None;
387
-
location = None;
388
-
} in
389
-
Fetch.Item_body stub_body)
736
+
let parsed_body = body r in
737
+
Fetch.Item_body parsed_body)
390
738
| "BODYSTRUCTURE" ->
739
+
(* BODYSTRUCTURE includes extension data *)
391
740
sp r;
392
-
(* Skip the parenthesized body structure - return minimal stub *)
393
-
let depth = ref 0 in
394
-
(match R.peek_char r with
395
-
| Some '(' ->
396
-
R.char '(' r;
397
-
depth := 1;
398
-
while !depth > 0 do
399
-
match R.any_char r with
400
-
| '(' -> incr depth
401
-
| ')' -> decr depth
402
-
| '"' -> ignore (R.take_while (fun c -> c <> '"') r); ignore (R.any_char r)
403
-
| '{' ->
404
-
let len = number r in
405
-
R.char '}' r;
406
-
crlf r;
407
-
ignore (R.take len r)
408
-
| _ -> ()
409
-
done
410
-
| _ -> ());
411
-
(* Return a minimal body structure stub *)
412
-
let stub_body : Body.t = {
413
-
body_type = Body.Basic {
414
-
media_type = "application";
415
-
subtype = "octet-stream";
416
-
fields = {
417
-
params = [];
418
-
content_id = None;
419
-
description = None;
420
-
encoding = "7bit";
421
-
size = 0L;
422
-
}
423
-
};
424
-
disposition = None;
425
-
language = None;
426
-
location = None;
427
-
} in
428
-
Fetch.Item_bodystructure stub_body
741
+
let parsed_body = body r in
742
+
Fetch.Item_bodystructure parsed_body
429
743
| _ -> Fetch.Item_flags []
430
744
431
745
let fetch_items r = parse_paren_list ~parse_item:fetch_item r
···
444
758
| "UNSEEN" -> Status.Unseen
445
759
| "DELETED" -> Status.Deleted
446
760
| "SIZE" -> Status.Size
761
+
| "HIGHESTMODSEQ" -> Status.Highestmodseq (* RFC 7162 CONDSTORE *)
447
762
| _ -> Status.Messages
448
763
in
449
764
(item, value)
···
488
803
let shared = namespace_list r in
489
804
Response.{ personal; other; shared }
490
805
806
+
(** {1 ESEARCH Response (RFC 4731)} *)
807
+
808
+
let esearch_correlator r =
809
+
(* Parse (TAG "xxx") *)
810
+
R.char '(' r;
811
+
let name = atom r in
812
+
sp r;
813
+
let value = quoted_string r in
814
+
R.char ')' r;
815
+
if String.uppercase_ascii name = "TAG" then Some value else None
816
+
817
+
let esearch_result_item r =
818
+
let name = atom r in
819
+
match String.uppercase_ascii name with
820
+
| "MIN" ->
821
+
sp r;
822
+
Some (Response.Esearch_min (number r))
823
+
| "MAX" ->
824
+
sp r;
825
+
Some (Response.Esearch_max (number r))
826
+
| "COUNT" ->
827
+
sp r;
828
+
Some (Response.Esearch_count (number r))
829
+
| "ALL" ->
830
+
sp r;
831
+
Some (Response.Esearch_all (uid_set r))
832
+
| _ -> None
833
+
834
+
let esearch_data r =
835
+
(* Parse optional (TAG "xxx") correlator *)
836
+
let tag =
837
+
match R.peek_char r with
838
+
| Some '(' -> esearch_correlator r
839
+
| _ -> None
840
+
in
841
+
(* Skip space if present after correlator *)
842
+
if Option.is_some tag && R.peek_char r = Some ' ' then sp r;
843
+
(* Check for UID indicator *)
844
+
let uid =
845
+
match R.peek_char r with
846
+
| Some 'U' | Some 'u' ->
847
+
(* Peek ahead to check if it's "UID" *)
848
+
R.ensure r 3;
849
+
let buf = R.peek r in
850
+
if Cstruct.length buf >= 3
851
+
&& Char.uppercase_ascii (Cstruct.get_char buf 0) = 'U'
852
+
&& Char.uppercase_ascii (Cstruct.get_char buf 1) = 'I'
853
+
&& Char.uppercase_ascii (Cstruct.get_char buf 2) = 'D'
854
+
then (
855
+
ignore (R.take 3 r); (* consume "UID" *)
856
+
if R.peek_char r = Some ' ' then sp r;
857
+
true
858
+
) else false
859
+
| _ -> false
860
+
in
861
+
(* Parse result data items *)
862
+
let rec loop acc =
863
+
match R.peek_char r with
864
+
| Some '\r' | Some '\n' | None -> List.rev acc
865
+
| Some ' ' ->
866
+
sp r;
867
+
loop acc
868
+
| _ ->
869
+
(match esearch_result_item r with
870
+
| Some item -> loop (item :: acc)
871
+
| None -> List.rev acc)
872
+
in
873
+
let results = loop [] in
874
+
Response.Esearch { tag; uid; results }
875
+
491
876
(** {1 ID Response} *)
492
877
493
878
let id_params r =
···
509
894
loop ((k, v) :: acc)
510
895
in
511
896
loop [])
897
+
898
+
(** {1 THREAD Response (RFC 5256)}
899
+
900
+
Parses the THREAD response format as specified in RFC 5256 Section 4.
901
+
902
+
The thread response has a recursive structure where each thread node
903
+
can be either a message number or a nested list of children.
904
+
905
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
906
+
907
+
(** Parse a single thread node.
908
+
909
+
A thread node is either:
910
+
- A message number optionally followed by children: "(n ...children...)"
911
+
- A dummy node (missing parent) starting with nested parens: "((...)...)"
912
+
913
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
914
+
let rec thread_node r =
915
+
R.char '(' r;
916
+
match R.peek_char r with
917
+
| Some '(' ->
918
+
(* Dummy node - starts with ( instead of number.
919
+
This represents a missing parent message in the thread. *)
920
+
let children = thread_children r in
921
+
R.char ')' r;
922
+
Thread.Dummy children
923
+
| _ ->
924
+
let n = number r in
925
+
let children = thread_children r in
926
+
R.char ')' r;
927
+
Thread.Message (n, children)
928
+
929
+
(** Parse thread children (zero or more thread nodes).
930
+
931
+
Children can be separated by spaces or appear consecutively.
932
+
This handles formats like "(3 6 (4 23))" where 6 is a child of 3,
933
+
and (4 23) is a sibling subtree. *)
934
+
and thread_children r =
935
+
let rec loop acc =
936
+
match R.peek_char r with
937
+
| Some '(' -> loop (thread_node r :: acc)
938
+
| Some ' ' -> sp r; loop acc
939
+
| _ -> List.rev acc
940
+
in
941
+
loop []
512
942
513
943
(** {1 Main Response Parser} *)
514
944
···
631
1061
done;
632
1062
crlf r;
633
1063
Response.Sort (List.rev !seqs)
1064
+
| "THREAD" ->
1065
+
(* RFC 5256 Section 4 - THREAD response format:
1066
+
thread-data = "THREAD" [SP 1*thread-list]
1067
+
thread-list = "(" thread-members / thread-nested ")"
1068
+
thread-members = thread-node *(SP thread-node)
1069
+
thread-nested = thread-list
1070
+
thread-node = nz-number / thread-nested
1071
+
1072
+
Example: * THREAD (2)(3 6 (4 23)(44 7 96))
1073
+
- Thread 1: Message 2 (no children)
1074
+
- Thread 2: Message 3 with child 6, which has children 4,23 and 44->7->96
1075
+
1076
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
1077
+
let threads = thread_children r in
1078
+
crlf r;
1079
+
Response.Thread threads
1080
+
| "ESEARCH" ->
1081
+
(* RFC 4731 ESEARCH response *)
1082
+
if R.peek_char r = Some ' ' then sp r;
1083
+
let result = esearch_data r in
1084
+
crlf r;
1085
+
result
634
1086
| _ ->
635
1087
let _ = rest_of_line r in
636
1088
Response.Ok { tag = None; code = None; text = "" })
+2
lib/imap/response.ml
+2
lib/imap/response.ml
···
45
45
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
46
46
| Search of int list
47
47
| Sort of int64 list
48
+
| Thread of int Thread.t
48
49
| Flags of Flag.t list
49
50
| Exists of int
50
51
| Recent of int
···
83
84
| Esearch _ -> Fmt.string ppf "* ESEARCH ..."
84
85
| Search seqs -> Fmt.pf ppf "* SEARCH %a" Fmt.(list ~sep:sp int) seqs
85
86
| Sort seqs -> Fmt.pf ppf "* SORT %a" Fmt.(list ~sep:sp int64) seqs
87
+
| Thread threads -> Fmt.pf ppf "* THREAD %a" (Thread.pp Fmt.int) threads
86
88
| Flags flags -> Fmt.pf ppf "* FLAGS (%a)" Fmt.(list ~sep:sp Flag.pp) flags
87
89
| Exists n -> Fmt.pf ppf "* %d EXISTS" n
88
90
| Recent n -> Fmt.pf ppf "* %d RECENT" n
+1
lib/imap/response.mli
+1
lib/imap/response.mli
+2
lib/imap/status.ml
+2
lib/imap/status.ml
···
14
14
| Unseen
15
15
| Deleted
16
16
| Size
17
+
| Highestmodseq (** RFC 7162 CONDSTORE *)
17
18
18
19
let pp_item ppf = function
19
20
| Messages -> Fmt.string ppf "MESSAGES"
···
22
23
| Unseen -> Fmt.string ppf "UNSEEN"
23
24
| Deleted -> Fmt.string ppf "DELETED"
24
25
| Size -> Fmt.string ppf "SIZE"
26
+
| Highestmodseq -> Fmt.string ppf "HIGHESTMODSEQ"
25
27
26
28
type t = {
27
29
mailbox : string;
+1
lib/imap/status.mli
+1
lib/imap/status.mli
+220
lib/imap/subject.ml
+220
lib/imap/subject.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** {0 Base Subject Extraction}
7
+
8
+
Implements {{:https://datatracker.ietf.org/doc/html/rfc5256#section-2.1}RFC 5256 Section 2.1}
9
+
for extracting the "base subject" from email Subject headers.
10
+
11
+
The base subject is used for SORT by SUBJECT and threading operations. *)
12
+
13
+
(** Normalize whitespace: convert tabs to spaces, collapse multiple spaces to one,
14
+
and trim leading/trailing whitespace. *)
15
+
let normalize_whitespace s =
16
+
(* Replace tabs with spaces *)
17
+
let s = String.map (fun c -> if c = '\t' then ' ' else c) s in
18
+
(* Collapse multiple spaces and trim *)
19
+
let buf = Buffer.create (String.length s) in
20
+
let last_was_space = ref true in (* Start true to skip leading spaces *)
21
+
String.iter (fun c ->
22
+
if c = ' ' then begin
23
+
if not !last_was_space then Buffer.add_char buf ' ';
24
+
last_was_space := true
25
+
end else begin
26
+
Buffer.add_char buf c;
27
+
last_was_space := false
28
+
end
29
+
) s;
30
+
(* Remove trailing space if present *)
31
+
let result = Buffer.contents buf in
32
+
let len = String.length result in
33
+
if len > 0 && result.[len - 1] = ' ' then
34
+
String.sub result 0 (len - 1)
35
+
else
36
+
result
37
+
38
+
(** Case-insensitive string prefix check *)
39
+
let starts_with_ci ~prefix s =
40
+
let plen = String.length prefix in
41
+
let slen = String.length s in
42
+
slen >= plen &&
43
+
let rec check i =
44
+
if i >= plen then true
45
+
else if Char.lowercase_ascii s.[i] = Char.lowercase_ascii prefix.[i] then
46
+
check (i + 1)
47
+
else false
48
+
in
49
+
check 0
50
+
51
+
(** Case-insensitive string suffix check *)
52
+
let ends_with_ci ~suffix s =
53
+
let suflen = String.length suffix in
54
+
let slen = String.length s in
55
+
slen >= suflen &&
56
+
let rec check i =
57
+
if i >= suflen then true
58
+
else if Char.lowercase_ascii s.[slen - suflen + i] = Char.lowercase_ascii suffix.[i] then
59
+
check (i + 1)
60
+
else false
61
+
in
62
+
check 0
63
+
64
+
(** Remove trailing (fwd) and whitespace - subj-trailer from RFC 5256 Section 5.
65
+
Returns the string and whether anything was removed. *)
66
+
let remove_trailer s =
67
+
let s = String.trim s in
68
+
if ends_with_ci ~suffix:"(fwd)" s then
69
+
let len = String.length s in
70
+
(String.trim (String.sub s 0 (len - 5)), true)
71
+
else
72
+
(s, false)
73
+
74
+
(** Skip a [blob] pattern starting at position i.
75
+
Returns the position after the blob and trailing whitespace, or None if no blob. *)
76
+
let skip_blob s i =
77
+
let len = String.length s in
78
+
if i >= len || s.[i] <> '[' then None
79
+
else begin
80
+
(* Find matching ] - blob chars are anything except [ ] *)
81
+
let rec find_close j =
82
+
if j >= len then None
83
+
else if s.[j] = ']' then Some j
84
+
else if s.[j] = '[' then None (* nested [ not allowed in blob *)
85
+
else find_close (j + 1)
86
+
in
87
+
match find_close (i + 1) with
88
+
| None -> None
89
+
| Some close_pos ->
90
+
(* Skip trailing whitespace after ] *)
91
+
let rec skip_ws k =
92
+
if k >= len then k
93
+
else if s.[k] = ' ' || s.[k] = '\t' then skip_ws (k + 1)
94
+
else k
95
+
in
96
+
Some (skip_ws (close_pos + 1))
97
+
end
98
+
99
+
(** Try to remove a subj-refwd pattern: ("re" / ("fw" ["d"])) *WSP [subj-blob] ":"
100
+
Returns (rest_of_string, removed) *)
101
+
let remove_refwd s =
102
+
let len = String.length s in
103
+
let try_prefix prefix =
104
+
if starts_with_ci ~prefix s then
105
+
let after_prefix = String.length prefix in
106
+
(* Skip optional whitespace *)
107
+
let rec skip_ws i =
108
+
if i >= len then i
109
+
else if s.[i] = ' ' || s.[i] = '\t' then skip_ws (i + 1)
110
+
else i
111
+
in
112
+
let after_ws = skip_ws after_prefix in
113
+
(* Try to skip optional blob *)
114
+
let after_blob = match skip_blob s after_ws with
115
+
| Some pos -> pos
116
+
| None -> after_ws
117
+
in
118
+
(* Must have colon *)
119
+
if after_blob < len && s.[after_blob] = ':' then
120
+
let rest = String.sub s (after_blob + 1) (len - after_blob - 1) in
121
+
Some (String.trim rest)
122
+
else
123
+
None
124
+
else
125
+
None
126
+
in
127
+
(* Try fwd first (longer), then fw, then re *)
128
+
match try_prefix "fwd" with
129
+
| Some rest -> (rest, true)
130
+
| None ->
131
+
match try_prefix "fw" with
132
+
| Some rest -> (rest, true)
133
+
| None ->
134
+
match try_prefix "re" with
135
+
| Some rest -> (rest, true)
136
+
| None -> (s, false)
137
+
138
+
(** Try to remove a leading [blob] if doing so leaves a non-empty base subject.
139
+
Returns (rest_of_string, removed) *)
140
+
let remove_leading_blob s =
141
+
match skip_blob s 0 with
142
+
| None -> (s, false)
143
+
| Some after_blob ->
144
+
let rest = String.sub s after_blob (String.length s - after_blob) in
145
+
let rest = String.trim rest in
146
+
(* Only remove if non-empty base remains *)
147
+
if String.length rest > 0 then (rest, true)
148
+
else (s, false)
149
+
150
+
(** Remove [fwd: ... ] wrapper pattern.
151
+
Returns (unwrapped_content, was_wrapped) *)
152
+
let remove_fwd_wrapper s =
153
+
let len = String.length s in
154
+
if len >= 6 && starts_with_ci ~prefix:"[fwd:" s && s.[len - 1] = ']' then begin
155
+
let inner = String.sub s 5 (len - 6) in
156
+
(String.trim inner, true)
157
+
end else
158
+
(s, false)
159
+
160
+
(** Internal state for tracking whether modifications occurred *)
161
+
type extract_state = {
162
+
subject : string;
163
+
is_reply_or_fwd : bool;
164
+
}
165
+
166
+
(** Extract base subject with full algorithm from RFC 5256 Section 2.1 *)
167
+
let rec extract_base_subject_full subject =
168
+
(* Step 1: Normalize whitespace (RFC 2047 decoding would go here too) *)
169
+
let s = normalize_whitespace subject in
170
+
let state = { subject = s; is_reply_or_fwd = false } in
171
+
172
+
(* Step 2: Remove trailing (fwd) - subj-trailer *)
173
+
let rec remove_trailers state =
174
+
let (s, removed) = remove_trailer state.subject in
175
+
if removed then
176
+
remove_trailers { subject = s; is_reply_or_fwd = true }
177
+
else
178
+
state
179
+
in
180
+
let state = remove_trailers state in
181
+
182
+
(* Steps 3-5: Remove leading subj-leader and subj-blob, repeat until stable *)
183
+
let rec remove_leaders state =
184
+
(* Step 3: Remove subj-refwd *)
185
+
let (s, refwd_removed) = remove_refwd state.subject in
186
+
let new_is_reply = state.is_reply_or_fwd || refwd_removed in
187
+
let state = { subject = s; is_reply_or_fwd = new_is_reply } in
188
+
189
+
(* Step 4: Remove leading [blob] if non-empty base remains *)
190
+
let (s, blob_removed) = remove_leading_blob state.subject in
191
+
let state = { subject = s; is_reply_or_fwd = state.is_reply_or_fwd } in
192
+
193
+
(* Step 5: Repeat if any changes *)
194
+
if refwd_removed || blob_removed then
195
+
remove_leaders state
196
+
else
197
+
state
198
+
in
199
+
let state = remove_leaders state in
200
+
201
+
(* Step 6: Check for [fwd: ... ] wrapper *)
202
+
let (s, fwd_wrapped) = remove_fwd_wrapper state.subject in
203
+
let new_is_reply = state.is_reply_or_fwd || fwd_wrapped in
204
+
let state = { subject = s; is_reply_or_fwd = new_is_reply } in
205
+
206
+
(* If we unwrapped [fwd:], need to re-run the whole algorithm on the inner content *)
207
+
if fwd_wrapped then begin
208
+
let inner_result = extract_base_subject_full s in
209
+
{ subject = inner_result.subject;
210
+
is_reply_or_fwd = true (* The outer [fwd:] wrapper counts *) }
211
+
end else
212
+
state
213
+
214
+
let base_subject subject =
215
+
let result = extract_base_subject_full subject in
216
+
result.subject
217
+
218
+
let is_reply_or_forward subject =
219
+
let result = extract_base_subject_full subject in
220
+
result.is_reply_or_fwd
+60
lib/imap/subject.mli
+60
lib/imap/subject.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** {0 Base Subject Extraction}
7
+
8
+
Implements {{:https://datatracker.ietf.org/doc/html/rfc5256#section-2.1}RFC 5256 Section 2.1}
9
+
for extracting the "base subject" from email Subject headers.
10
+
11
+
The base subject is used for SORT by SUBJECT and threading operations.
12
+
13
+
{1 Algorithm Overview}
14
+
15
+
The algorithm:
16
+
{ol
17
+
{li Converts RFC 2047 encoded-words to UTF-8 and normalizes whitespace}
18
+
{li Removes trailing [(fwd)] and whitespace (subj-trailer)}
19
+
{li Removes leading [Re:], [Fw:], [Fwd:] with optional [\[blob\]] (subj-leader)}
20
+
{li Removes leading [\[blob\]] if non-empty base remains}
21
+
{li Repeats steps 3-4 until no more changes}
22
+
{li Unwraps [\[fwd: ... \]] wrapper pattern}
23
+
}
24
+
25
+
{1 ABNF from RFC 5256 Section 5}
26
+
27
+
{v
28
+
subj-refwd = ("re" / ("fw" ["d"])) *WSP [subj-blob] ":"
29
+
subj-blob = "[" *BLOBCHAR "]" *WSP
30
+
subj-trailer = "(fwd)" / WSP
31
+
subj-fwd-hdr = "[fwd:"
32
+
subj-fwd-trl = "]"
33
+
v} *)
34
+
35
+
val base_subject : string -> string
36
+
(** [base_subject subject] extracts the base subject from [subject].
37
+
38
+
The base subject is the normalized subject string with reply/forward
39
+
indicators removed, suitable for sorting and threading.
40
+
41
+
Examples:
42
+
- [base_subject "Re: test"] returns ["test"]
43
+
- [base_subject "Re: Re: test"] returns ["test"]
44
+
- [base_subject "Fwd: test"] returns ["test"]
45
+
- [base_subject "\[PATCH\] Re: \[ocaml\] test"] returns ["test"]
46
+
- [base_subject "\[fwd: wrapped\]"] returns ["wrapped"]
47
+
- [base_subject "test (fwd)"] returns ["test"]
48
+
- [base_subject " spaced "] returns ["spaced"] *)
49
+
50
+
val is_reply_or_forward : string -> bool
51
+
(** [is_reply_or_forward subject] returns [true] if the subject indicates
52
+
a reply or forward.
53
+
54
+
This is determined by whether base subject extraction removed any of:
55
+
- [Re:], [Fw:], or [Fwd:] prefixes
56
+
- [(fwd)] trailer
57
+
- [\[fwd: ...\]] wrapper
58
+
59
+
This is useful for threading algorithms that need to distinguish
60
+
original messages from replies/forwards. *)
+95
lib/imap/thread.ml
+95
lib/imap/thread.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** {0 RFC 5256 THREAD Extension}
7
+
8
+
Message threading algorithms as specified in
9
+
{{:https://datatracker.ietf.org/doc/html/rfc5256}RFC 5256 Section 3}.
10
+
11
+
The THREAD command allows clients to retrieve messages organized into
12
+
conversation threads based on message relationships. *)
13
+
14
+
(** {1 Threading Algorithms}
15
+
16
+
RFC 5256 Section 3 defines two threading algorithms. Servers MUST
17
+
implement at least ORDEREDSUBJECT and SHOULD implement REFERENCES. *)
18
+
19
+
(** Threading algorithm used to organize messages into threads.
20
+
21
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-3> RFC 5256 Section 3 *)
22
+
type algorithm =
23
+
| Orderedsubject
24
+
(** ORDEREDSUBJECT algorithm (RFC 5256 Section 3.1).
25
+
Groups messages by base subject (stripping Re:/Fwd: prefixes),
26
+
then sorts each group by sent date. Simple but effective for
27
+
basic threading. *)
28
+
| References
29
+
(** REFERENCES algorithm (RFC 5256 Section 3.2).
30
+
Implements the JWZ threading algorithm using Message-ID,
31
+
In-Reply-To, and References headers to build a complete
32
+
parent/child thread tree. More accurate than ORDEREDSUBJECT
33
+
but computationally more expensive. *)
34
+
| Extension of string
35
+
(** Future algorithm extensions. Servers may advertise additional
36
+
threading algorithms via the THREAD capability. *)
37
+
38
+
(** {1 Thread Result Structure}
39
+
40
+
Thread results form a forest of trees. Each tree represents a
41
+
conversation thread, with messages as nodes. *)
42
+
43
+
(** A thread node in the result tree.
44
+
45
+
Thread responses use a nested parenthesized structure where each
46
+
message may have zero or more child messages (replies).
47
+
48
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
49
+
type 'a node =
50
+
| Message of 'a * 'a node list
51
+
(** A message with its sequence number or UID (depending on whether
52
+
UID THREAD was used) and a list of child messages (replies).
53
+
The children are ordered by the threading algorithm. *)
54
+
| Dummy of 'a node list
55
+
(** A placeholder for a missing parent message. This occurs when
56
+
replies reference a message that is not in the search results
57
+
(e.g., it was deleted or not matched by the search criteria).
58
+
The REFERENCES algorithm may produce dummy nodes to maintain
59
+
thread structure. *)
60
+
61
+
(** Thread result: a list of root-level thread trees.
62
+
63
+
Each element is a top-level thread. The threads are ordered according
64
+
to the threading algorithm (typically by date of the first message
65
+
in each thread).
66
+
67
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
68
+
type 'a t = 'a node list
69
+
70
+
(** {1 Pretty Printers} *)
71
+
72
+
let pp_algorithm ppf = function
73
+
| Orderedsubject -> Fmt.string ppf "ORDEREDSUBJECT"
74
+
| References -> Fmt.string ppf "REFERENCES"
75
+
| Extension s -> Fmt.pf ppf "%s" (String.uppercase_ascii s)
76
+
77
+
let algorithm_to_string alg = Fmt.str "%a" pp_algorithm alg
78
+
79
+
let algorithm_of_string s =
80
+
match String.uppercase_ascii s with
81
+
| "ORDEREDSUBJECT" -> Orderedsubject
82
+
| "REFERENCES" -> References
83
+
| other -> Extension other
84
+
85
+
let rec pp_node pp_elt ppf = function
86
+
| Message (elt, []) ->
87
+
pp_elt ppf elt
88
+
| Message (elt, children) ->
89
+
Fmt.pf ppf "(%a %a)" pp_elt elt
90
+
Fmt.(list ~sep:sp (pp_node pp_elt)) children
91
+
| Dummy children ->
92
+
Fmt.pf ppf "(%a)" Fmt.(list ~sep:sp (pp_node pp_elt)) children
93
+
94
+
let pp pp_elt ppf threads =
95
+
Fmt.(list ~sep:sp (pp_node pp_elt)) ppf threads
+86
lib/imap/thread.mli
+86
lib/imap/thread.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** {0 RFC 5256 THREAD Extension}
7
+
8
+
Message threading algorithms as specified in
9
+
{{:https://datatracker.ietf.org/doc/html/rfc5256}RFC 5256 Section 3}.
10
+
11
+
The THREAD command allows clients to retrieve messages organized into
12
+
conversation threads based on message relationships. *)
13
+
14
+
(** {1 Threading Algorithms}
15
+
16
+
RFC 5256 Section 3 defines two threading algorithms. Servers MUST
17
+
implement at least ORDEREDSUBJECT and SHOULD implement REFERENCES. *)
18
+
19
+
(** Threading algorithm used to organize messages into threads.
20
+
21
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-3> RFC 5256 Section 3 *)
22
+
type algorithm =
23
+
| Orderedsubject
24
+
(** ORDEREDSUBJECT algorithm (RFC 5256 Section 3.1).
25
+
Groups messages by base subject (stripping Re:/Fwd: prefixes),
26
+
then sorts each group by sent date. Simple but effective for
27
+
basic threading. *)
28
+
| References
29
+
(** REFERENCES algorithm (RFC 5256 Section 3.2).
30
+
Implements the JWZ threading algorithm using Message-ID,
31
+
In-Reply-To, and References headers to build a complete
32
+
parent/child thread tree. More accurate than ORDEREDSUBJECT
33
+
but computationally more expensive. *)
34
+
| Extension of string
35
+
(** Future algorithm extensions. Servers may advertise additional
36
+
threading algorithms via the THREAD capability. *)
37
+
38
+
(** {1 Thread Result Structure}
39
+
40
+
Thread results form a forest of trees. Each tree represents a
41
+
conversation thread, with messages as nodes. *)
42
+
43
+
(** A thread node in the result tree.
44
+
45
+
Thread responses use a nested parenthesized structure where each
46
+
message may have zero or more child messages (replies).
47
+
48
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
49
+
type 'a node =
50
+
| Message of 'a * 'a node list
51
+
(** A message with its sequence number or UID (depending on whether
52
+
UID THREAD was used) and a list of child messages (replies).
53
+
The children are ordered by the threading algorithm. *)
54
+
| Dummy of 'a node list
55
+
(** A placeholder for a missing parent message. This occurs when
56
+
replies reference a message that is not in the search results
57
+
(e.g., it was deleted or not matched by the search criteria).
58
+
The REFERENCES algorithm may produce dummy nodes to maintain
59
+
thread structure. *)
60
+
61
+
(** Thread result: a list of root-level thread trees.
62
+
63
+
Each element is a top-level thread. The threads are ordered according
64
+
to the threading algorithm (typically by date of the first message
65
+
in each thread).
66
+
67
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
68
+
type 'a t = 'a node list
69
+
70
+
(** {1 Pretty Printers} *)
71
+
72
+
val pp_algorithm : Format.formatter -> algorithm -> unit
73
+
(** [pp_algorithm ppf alg] prints the algorithm name in IMAP wire format. *)
74
+
75
+
val algorithm_to_string : algorithm -> string
76
+
(** [algorithm_to_string alg] returns the algorithm name as a string. *)
77
+
78
+
val algorithm_of_string : string -> algorithm
79
+
(** [algorithm_of_string s] parses an algorithm name from a string.
80
+
Unrecognized names are returned as [Extension s]. *)
81
+
82
+
val pp_node : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a node -> unit
83
+
(** [pp_node pp_elt ppf node] prints a thread node using [pp_elt] for elements. *)
84
+
85
+
val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
86
+
(** [pp pp_elt ppf threads] prints a thread result using [pp_elt] for elements. *)
+45
-5
lib/imap/write.ml
+45
-5
lib/imap/write.ml
···
116
116
flags;
117
117
W.char w ')'
118
118
119
+
(** {1 Search Return Options (RFC 4731 ESEARCH)} *)
120
+
121
+
let search_return_opt w = function
122
+
| Command.Return_min -> W.string w "MIN"
123
+
| Command.Return_max -> W.string w "MAX"
124
+
| Command.Return_all -> W.string w "ALL"
125
+
| Command.Return_count -> W.string w "COUNT"
126
+
127
+
let search_return_opts w opts =
128
+
W.string w "RETURN (";
129
+
List.iteri (fun i opt ->
130
+
if i > 0 then sp w;
131
+
search_return_opt w opt
132
+
) opts;
133
+
W.char w ')'
134
+
119
135
(** {1 Search Keys} *)
120
136
121
137
let rec search_key w = function
···
245
261
write_partial w partial
246
262
| Fetch.Binary_size section ->
247
263
W.string w "BINARY.SIZE["; W.string w section; W.char w ']'
264
+
| Fetch.Modseq ->
265
+
(* RFC 7162 Section 3.1.5: MODSEQ fetch data item *)
266
+
W.string w "MODSEQ"
248
267
249
268
let fetch_items w = function
250
269
| [ item ] -> fetch_item w item
···
266
285
| Status.Unseen -> W.string w "UNSEEN"
267
286
| Status.Deleted -> W.string w "DELETED"
268
287
| Status.Size -> W.string w "SIZE"
288
+
| Status.Highestmodseq -> W.string w "HIGHESTMODSEQ" (* RFC 7162 CONDSTORE *)
269
289
270
290
let status_items w items =
271
291
W.char w '(';
···
307
327
criteria;
308
328
W.char w ')'
309
329
330
+
(** {1 Thread Algorithm} *)
331
+
332
+
let thread_algorithm w = function
333
+
| Thread.Orderedsubject -> W.string w "ORDEREDSUBJECT"
334
+
| Thread.References -> W.string w "REFERENCES"
335
+
| Thread.Extension s -> W.string w (String.uppercase_ascii s)
336
+
310
337
(** {1 ID Parameters} *)
311
338
312
339
let id_params w = function
···
324
351
325
352
(** {1 Commands} *)
326
353
327
-
let write_search w charset criteria =
354
+
let write_search w charset criteria return_opts =
328
355
W.string w "SEARCH";
356
+
Option.iter (fun opts -> sp w; search_return_opts w opts) return_opts;
329
357
Option.iter (fun cs -> W.string w " CHARSET "; astring w cs) charset;
330
358
sp w;
331
359
search_key w criteria
···
333
361
let write_sort w charset criteria search =
334
362
W.string w "SORT ";
335
363
sort_criteria w criteria;
364
+
sp w;
365
+
astring w charset;
366
+
sp w;
367
+
search_key w search
368
+
369
+
let write_thread w algorithm charset search =
370
+
W.string w "THREAD ";
371
+
thread_algorithm w algorithm;
336
372
sp w;
337
373
astring w charset;
338
374
sp w;
···
403
439
| Command.Close -> W.string w "CLOSE"
404
440
| Command.Unselect -> W.string w "UNSELECT"
405
441
| Command.Expunge -> W.string w "EXPUNGE"
406
-
| Command.Search { charset; criteria } ->
407
-
write_search w charset criteria
442
+
| Command.Search { charset; criteria; return_opts } ->
443
+
write_search w charset criteria return_opts
408
444
| Command.Sort { charset; criteria; search } ->
409
445
write_sort w charset criteria search
446
+
| Command.Thread { algorithm; charset; search } ->
447
+
write_thread w algorithm charset search
410
448
| Command.Fetch { sequence; items; changedsince } ->
411
449
W.string w "FETCH ";
412
450
sequence_set w sequence;
···
476
514
sequence_set w sequence;
477
515
sp w;
478
516
astring w mailbox
479
-
| Command.Uid_search { charset; criteria } ->
480
-
write_search w charset criteria
517
+
| Command.Uid_search { charset; criteria; return_opts } ->
518
+
write_search w charset criteria return_opts
481
519
| Command.Uid_sort { charset; criteria; search } ->
482
520
write_sort w charset criteria search
521
+
| Command.Uid_thread { algorithm; charset; search } ->
522
+
write_thread w algorithm charset search
483
523
| Command.Uid_expunge set ->
484
524
W.string w "EXPUNGE ";
485
525
sequence_set w set)
+4
lib/imap/write.mli
+4
lib/imap/write.mli
+2
-2
lib/imapd/client.ml
+2
-2
lib/imapd/client.ml
···
132
132
| Flags_response f -> flags := f
133
133
| Capability_response c -> caps := c
134
134
| Enabled e -> enabled := e
135
-
| List_response { flags = f; delimiter; name } ->
135
+
| List_response { flags = f; delimiter; name; _ } ->
136
136
list_entries := { flags = f; delimiter; name } :: !list_entries
137
137
| Status_response { mailbox; items } ->
138
138
let messages =
···
554
554
555
555
let list t ~reference ~pattern =
556
556
require_authenticated t;
557
-
let responses = run_command t (List { reference; pattern }) in
557
+
let responses = run_command t (List (List_basic { reference; pattern })) in
558
558
let _, _, _, _, _, _, _, _, entries, _, _, _, _, _, _, _ =
559
559
process_untagged responses
560
560
in
+91
-1
lib/imapd/grammar.mly
+91
-1
lib/imapd/grammar.mly
···
61
61
%token CHARSET MIME PEEK HEADER_FIELDS HEADER_FIELDS_NOT SILENT
62
62
%token RETURN SUBSCRIBED CHILDREN REMOTE RECURSIVEMATCH DONE
63
63
64
+
(* LIST-EXTENDED - RFC 5258, RFC 6154 *)
65
+
%token SPECIAL_USE
66
+
67
+
(* QUOTA extension - RFC 9208 *)
68
+
%token GETQUOTA GETQUOTAROOT SETQUOTA STORAGE MAILBOX ANNOTATION_STORAGE
69
+
64
70
(* Entry point *)
65
71
%start <Protocol.tagged_command> command
66
72
%start <Protocol.response> response_parser
···
382
388
| RENAME SP old_mb = mailbox SP new_mb = mailbox { Rename { old_name = old_mb; new_name = new_mb } }
383
389
| SUBSCRIBE SP mb = mailbox { Subscribe mb }
384
390
| UNSUBSCRIBE SP mb = mailbox { Unsubscribe mb }
385
-
| LIST SP ref = astring SP pat = list_mailbox { List { reference = ref; pattern = pat } }
391
+
(* LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
392
+
| LIST SP ref = astring SP pat = list_mailbox
393
+
{ List (List_basic { reference = ref; pattern = pat }) }
394
+
(* LIST-EXTENDED: LIST (selection-opts) reference patterns [RETURN (return-opts)]
395
+
Per RFC 5258 Section 3 *)
396
+
| LIST SP sel = list_select_opts SP ref = astring SP pats = list_patterns
397
+
{ List (List_extended { selection = sel; reference = ref; patterns = pats; return_opts = [] }) }
398
+
| LIST SP sel = list_select_opts SP ref = astring SP pats = list_patterns SP ret = list_return_opts
399
+
{ List (List_extended { selection = sel; reference = ref; patterns = pats; return_opts = ret }) }
386
400
| NAMESPACE { Namespace }
387
401
| STATUS SP mb = mailbox SP LPAREN atts = status_att_list RPAREN { Status { mailbox = mb; items = atts } }
388
402
| APPEND SP mb = mailbox SP fl = flag_list SP dt = date_time SP msg = append_message
···
392
406
| APPEND SP mb = mailbox SP msg = append_message
393
407
{ Append { mailbox = mb; flags = []; date = None; message = msg } }
394
408
| IDLE { Idle }
409
+
(* QUOTA extension - RFC 9208 *)
410
+
| GETQUOTA SP root = astring { Getquota root }
411
+
| GETQUOTAROOT SP mb = mailbox { Getquotaroot mb }
412
+
| SETQUOTA SP root = astring SP LPAREN limits = quota_limits RPAREN
413
+
{ Setquota { root; limits } }
414
+
| SETQUOTA SP root = astring SP LPAREN RPAREN
415
+
{ Setquota { root; limits = [] } }
416
+
;
417
+
418
+
(* Quota resource type - RFC 9208 Section 5 *)
419
+
quota_resource:
420
+
| STORAGE { Quota_storage }
421
+
| MESSAGES { Quota_message } (* MESSAGE uses MESSAGES token *)
422
+
| MAILBOX { Quota_mailbox }
423
+
| ANNOTATION_STORAGE { Quota_annotation_storage }
424
+
;
425
+
426
+
(* Quota limit list for SETQUOTA *)
427
+
quota_limits:
428
+
| res = quota_resource SP limit = number { [(res, limit)] }
429
+
| res = quota_resource SP limit = number SP rest = quota_limits { (res, limit) :: rest }
395
430
;
396
431
397
432
enable_caps:
···
402
437
list_mailbox:
403
438
| s = astring { s }
404
439
| s = QUOTED_STRING { s }
440
+
;
441
+
442
+
(* === LIST-EXTENDED grammar - RFC 5258 Section 3 === *)
443
+
444
+
(* list-select-opts = "(" [list-select-opt *(SP list-select-opt)] ")"
445
+
RFC 5258 Section 3.1 *)
446
+
list_select_opts:
447
+
| LPAREN RPAREN { [] }
448
+
| LPAREN opts = list_select_opt_list RPAREN { opts }
449
+
;
450
+
451
+
list_select_opt_list:
452
+
| o = list_select_opt { [o] }
453
+
| o = list_select_opt SP rest = list_select_opt_list { o :: rest }
454
+
;
455
+
456
+
(* list-select-opt = "SUBSCRIBED" / "REMOTE" / "RECURSIVEMATCH" / "SPECIAL-USE"
457
+
RFC 5258 Section 3.1, RFC 6154 *)
458
+
list_select_opt:
459
+
| SUBSCRIBED { List_select_subscribed }
460
+
| REMOTE { List_select_remote }
461
+
| RECURSIVEMATCH { List_select_recursivematch }
462
+
| SPECIAL_USE { List_select_special_use }
463
+
;
464
+
465
+
(* Multiple patterns: "(" mbox-or-pat *(SP mbox-or-pat) ")" or single pattern
466
+
RFC 5258 Section 3 *)
467
+
list_patterns:
468
+
| pat = list_mailbox { [pat] }
469
+
| LPAREN pats = list_pattern_list RPAREN { pats }
470
+
;
471
+
472
+
list_pattern_list:
473
+
| p = list_mailbox { [p] }
474
+
| p = list_mailbox SP rest = list_pattern_list { p :: rest }
475
+
;
476
+
477
+
(* list-return-opts = "RETURN" SP "(" [list-return-opt *(SP list-return-opt)] ")"
478
+
RFC 5258 Section 3.2 *)
479
+
list_return_opts:
480
+
| RETURN SP LPAREN RPAREN { [] }
481
+
| RETURN SP LPAREN opts = list_return_opt_list RPAREN { opts }
482
+
;
483
+
484
+
list_return_opt_list:
485
+
| o = list_return_opt { [o] }
486
+
| o = list_return_opt SP rest = list_return_opt_list { o :: rest }
487
+
;
488
+
489
+
(* list-return-opt = "SUBSCRIBED" / "CHILDREN" / "SPECIAL-USE"
490
+
RFC 5258 Section 3.2, RFC 6154 *)
491
+
list_return_opt:
492
+
| SUBSCRIBED { List_return_subscribed }
493
+
| CHILDREN { List_return_children }
494
+
| SPECIAL_USE { List_return_special_use }
405
495
;
406
496
407
497
append_message:
+10
lib/imapd/lexer.mll
+10
lib/imapd/lexer.mll
···
123
123
("REMOTE", REMOTE);
124
124
("RECURSIVEMATCH", RECURSIVEMATCH);
125
125
("DONE", DONE);
126
+
(* LIST-EXTENDED - RFC 5258, RFC 6154 *)
127
+
("SPECIAL-USE", SPECIAL_USE);
128
+
(* QUOTA extension - RFC 9208 *)
129
+
("GETQUOTA", GETQUOTA);
130
+
("GETQUOTAROOT", GETQUOTAROOT);
131
+
("SETQUOTA", SETQUOTA);
132
+
("STORAGE", STORAGE);
133
+
("MAILBOX", MAILBOX);
134
+
("ANNOTATION-STORAGE", ANNOTATION_STORAGE);
135
+
(* Note: MESSAGE already exists as MESSAGES for STATUS *)
126
136
]
127
137
128
138
let lookup_keyword s =
+116
-3
lib/imapd/parser.ml
+116
-3
lib/imapd/parser.ml
···
12
12
open Protocol
13
13
14
14
(* Re-export types from Types for backward compatibility *)
15
+
type thread_algorithm = Protocol.thread_algorithm =
16
+
| Thread_orderedsubject
17
+
| Thread_references
18
+
| Thread_extension of string
19
+
20
+
type thread_node = Protocol.thread_node =
21
+
| Thread_message of int * thread_node list
22
+
| Thread_dummy of thread_node list
23
+
24
+
type thread_result = Protocol.thread_result
25
+
15
26
type command = Protocol.command =
16
27
| Capability
17
28
| Noop
···
27
38
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
28
39
| Subscribe of mailbox_name
29
40
| Unsubscribe of mailbox_name
30
-
| List of { reference : string; pattern : string }
41
+
| List of list_command (** LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
31
42
| Namespace
32
43
| Status of { mailbox : mailbox_name; items : status_item list }
33
44
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
···
42
53
| Move of { sequence : sequence_set; mailbox : mailbox_name }
43
54
| Uid of uid_command
44
55
| Id of (string * string) list option
56
+
(* QUOTA extension - RFC 9208 *)
57
+
| Getquota of string
58
+
| Getquotaroot of mailbox_name
59
+
| Setquota of { root : string; limits : (quota_resource * int64) list }
60
+
(* THREAD extension - RFC 5256 *)
61
+
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
45
62
46
63
type uid_command = Protocol.uid_command =
47
64
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
···
50
67
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
51
68
| Uid_search of { charset : string option; criteria : search_key }
52
69
| Uid_expunge of sequence_set
70
+
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
53
71
54
72
type tagged_command = Protocol.tagged_command = {
55
73
tag : string;
···
64
82
| Bye of { code : response_code option; text : string }
65
83
| Capability_response of string list
66
84
| Enabled of string list
67
-
| List_response of { flags : list_flag list; delimiter : char option; name : mailbox_name }
85
+
| List_response of list_response_data (** RFC 9051, RFC 5258 LIST-EXTENDED *)
68
86
| Namespace_response of namespace_data
69
87
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
70
88
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
···
74
92
| Fetch_response of { seq : int; items : fetch_response_item list }
75
93
| Continuation of string option
76
94
| Id_response of (string * string) list option
95
+
(* QUOTA extension responses - RFC 9208 *)
96
+
| Quota_response of { root : string; resources : quota_resource_info list }
97
+
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
98
+
(* THREAD extension response - RFC 5256 *)
99
+
| Thread_response of thread_result
77
100
78
101
(* ===== Menhir Parser Interface ===== *)
79
102
···
113
136
write_string f "}\r\n";
114
137
write_string f s
115
138
139
+
(** Convert quota resource to IMAP string.
140
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5}RFC 9208 Section 5}. *)
141
+
let quota_resource_to_string = function
142
+
| Quota_storage -> "STORAGE"
143
+
| Quota_message -> "MESSAGE"
144
+
| Quota_mailbox -> "MAILBOX"
145
+
| Quota_annotation_storage -> "ANNOTATION-STORAGE"
146
+
116
147
let write_flag f flag =
117
148
write_string f (flag_to_string flag)
118
149
···
219
250
List.iter (fun c -> write_sp f; write_string f c) caps;
220
251
write_crlf f
221
252
222
-
| List_response { flags; delimiter; name } ->
253
+
| List_response { flags; delimiter; name; extended } ->
254
+
(* LIST response per RFC 9051 Section 7.3.1, RFC 5258 Section 3.4 *)
223
255
write_string f "* LIST (";
224
256
List.iteri (fun i flag ->
225
257
if i > 0 then write_sp f;
···
231
263
| List_subscribed -> write_string f "\\Subscribed"
232
264
| List_haschildren -> write_string f "\\HasChildren"
233
265
| List_hasnochildren -> write_string f "\\HasNoChildren"
266
+
| List_nonexistent -> write_string f "\\NonExistent" (* RFC 5258 Section 3.4 *)
267
+
| List_remote -> write_string f "\\Remote" (* RFC 5258 Section 3.4 *)
234
268
| List_all -> write_string f "\\All"
235
269
| List_archive -> write_string f "\\Archive"
236
270
| List_drafts -> write_string f "\\Drafts"
···
246
280
| None -> write_string f "NIL");
247
281
write_sp f;
248
282
write_quoted_string f name;
283
+
(* Extended data per RFC 5258 Section 3.5 *)
284
+
List.iter (fun ext ->
285
+
match ext with
286
+
| Childinfo subscriptions ->
287
+
(* CHILDINFO extended data item: "CHILDINFO" SP "(" tag-list ")" *)
288
+
write_sp f;
289
+
write_string f "(\"CHILDINFO\" (";
290
+
List.iteri (fun i tag ->
291
+
if i > 0 then write_sp f;
292
+
write_quoted_string f tag
293
+
) subscriptions;
294
+
write_string f "))"
295
+
) extended;
249
296
write_crlf f
250
297
251
298
| Namespace_response { personal; other; shared } ->
···
371
418
write_quoted_string f value
372
419
) pairs;
373
420
write_char f ')');
421
+
write_crlf f
422
+
423
+
(* QUOTA extension responses - RFC 9208 *)
424
+
| Quota_response { root; resources } ->
425
+
(* QUOTA response format: * QUOTA root (resource usage limit ...) *)
426
+
write_string f "* QUOTA ";
427
+
write_quoted_string f root;
428
+
write_string f " (";
429
+
List.iteri (fun i { resource; usage; limit } ->
430
+
if i > 0 then write_sp f;
431
+
write_string f (quota_resource_to_string resource);
432
+
write_sp f;
433
+
write_string f (Int64.to_string usage);
434
+
write_sp f;
435
+
write_string f (Int64.to_string limit)
436
+
) resources;
437
+
write_char f ')';
438
+
write_crlf f
439
+
440
+
| Quotaroot_response { mailbox; roots } ->
441
+
(* QUOTAROOT response format: * QUOTAROOT mailbox root ... *)
442
+
write_string f "* QUOTAROOT ";
443
+
write_quoted_string f mailbox;
444
+
List.iter (fun root ->
445
+
write_sp f;
446
+
write_quoted_string f root
447
+
) roots;
448
+
write_crlf f
449
+
450
+
(* THREAD extension response - RFC 5256 Section 4 *)
451
+
| Thread_response threads ->
452
+
(* THREAD response format: * THREAD [SP 1*thread-list]
453
+
Each thread node is either:
454
+
- (n) for a single message
455
+
- (n children...) for a message with children
456
+
- ((children...)) for a dummy parent
457
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
458
+
let rec write_thread_node = function
459
+
| Thread_message (n, []) ->
460
+
(* Single message with no children: (n) *)
461
+
write_char f '(';
462
+
write_string f (string_of_int n);
463
+
write_char f ')'
464
+
| Thread_message (n, children) ->
465
+
(* Message with children: (n child1 child2 ...) *)
466
+
write_char f '(';
467
+
write_string f (string_of_int n);
468
+
List.iter (fun child ->
469
+
write_sp f;
470
+
write_thread_node child
471
+
) children;
472
+
write_char f ')'
473
+
| Thread_dummy children ->
474
+
(* Dummy node (missing parent): ((child1)(child2)...) *)
475
+
write_char f '(';
476
+
List.iteri (fun i child ->
477
+
if i > 0 then write_sp f;
478
+
write_thread_node child
479
+
) children;
480
+
write_char f ')'
481
+
in
482
+
write_string f "* THREAD";
483
+
List.iter (fun thread ->
484
+
write_sp f;
485
+
write_thread_node thread
486
+
) threads;
374
487
write_crlf f
375
488
376
489
let response_to_string resp =
+19
-2
lib/imapd/parser.mli
+19
-2
lib/imapd/parser.mli
···
15
15
16
16
Types are defined in {!Protocol} and re-exported here for convenience. *)
17
17
18
+
type thread_algorithm = Protocol.thread_algorithm =
19
+
| Thread_orderedsubject
20
+
| Thread_references
21
+
| Thread_extension of string
22
+
18
23
type command = Protocol.command =
19
24
| Capability
20
25
| Noop
···
30
35
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
31
36
| Subscribe of mailbox_name
32
37
| Unsubscribe of mailbox_name
33
-
| List of { reference : string; pattern : string }
38
+
| List of list_command
34
39
| Namespace
35
40
| Status of { mailbox : mailbox_name; items : status_item list }
36
41
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
···
45
50
| Move of { sequence : sequence_set; mailbox : mailbox_name }
46
51
| Uid of uid_command
47
52
| Id of (string * string) list option
53
+
(* QUOTA extension - RFC 9208 *)
54
+
| Getquota of string
55
+
| Getquotaroot of mailbox_name
56
+
| Setquota of { root : string; limits : (quota_resource * int64) list }
57
+
(* THREAD extension - RFC 5256 *)
58
+
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
48
59
49
60
type uid_command = Protocol.uid_command =
50
61
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
···
53
64
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
54
65
| Uid_search of { charset : string option; criteria : search_key }
55
66
| Uid_expunge of sequence_set
67
+
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
56
68
57
69
type tagged_command = Protocol.tagged_command = {
58
70
tag : string;
···
67
79
| Bye of { code : response_code option; text : string }
68
80
| Capability_response of string list
69
81
| Enabled of string list
70
-
| List_response of { flags : list_flag list; delimiter : char option; name : mailbox_name }
82
+
| List_response of list_response_data
71
83
| Namespace_response of namespace_data
72
84
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
73
85
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
···
77
89
| Fetch_response of { seq : int; items : fetch_response_item list }
78
90
| Continuation of string option
79
91
| Id_response of (string * string) list option
92
+
(* QUOTA extension responses - RFC 9208 *)
93
+
| Quota_response of { root : string; resources : quota_resource_info list }
94
+
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
95
+
(* THREAD extension response - RFC 5256 *)
96
+
| Thread_response of thread_result
80
97
81
98
(** {1 Parsing} *)
82
99
+127
-3
lib/imapd/protocol.ml
+127
-3
lib/imapd/protocol.ml
···
183
183
| Status_deleted
184
184
| Status_size
185
185
186
-
(* LIST flags - RFC 9051 Section 7.3.1 *)
186
+
(* LIST flags - RFC 9051 Section 7.3.1, RFC 5258 Section 3.4 *)
187
187
type list_flag =
188
188
| List_noinferiors
189
189
| List_noselect
···
192
192
| List_subscribed
193
193
| List_haschildren
194
194
| List_hasnochildren
195
+
| List_nonexistent (** RFC 5258 Section 3.4 - Mailbox name refers to non-existent mailbox *)
196
+
| List_remote (** RFC 5258 Section 3.4 - Mailbox is remote, not on this server *)
195
197
| List_all
196
198
| List_archive
197
199
| List_drafts
···
200
202
| List_sent
201
203
| List_trash
202
204
| List_extension of string
205
+
206
+
(** LIST selection options per RFC 5258 Section 3.1
207
+
208
+
Selection options control which mailboxes are returned by LIST:
209
+
- SUBSCRIBED: Return subscribed mailboxes (like LSUB)
210
+
- REMOTE: Include remote mailboxes (not on this server)
211
+
- RECURSIVEMATCH: Include ancestors of matched mailboxes
212
+
- SPECIAL-USE: Return only special-use mailboxes (RFC 6154) *)
213
+
type list_select_option =
214
+
| List_select_subscribed (** RFC 5258 Section 3.1.1 *)
215
+
| List_select_remote (** RFC 5258 Section 3.1.2 *)
216
+
| List_select_recursivematch (** RFC 5258 Section 3.1.3 *)
217
+
| List_select_special_use (** RFC 6154 Section 3 *)
218
+
219
+
(** LIST return options per RFC 5258 Section 3.2
220
+
221
+
Return options control what additional data is returned:
222
+
- SUBSCRIBED: Include \Subscribed flag
223
+
- CHILDREN: Include \HasChildren/\HasNoChildren flags
224
+
- SPECIAL-USE: Include special-use flags (RFC 6154) *)
225
+
type list_return_option =
226
+
| List_return_subscribed (** RFC 5258 Section 3.2.1 *)
227
+
| List_return_children (** RFC 5258 Section 3.2.2 *)
228
+
| List_return_special_use (** RFC 6154 Section 3 *)
229
+
230
+
(** Extended data items in LIST response per RFC 5258 Section 3.5 *)
231
+
type list_extended_item =
232
+
| Childinfo of string list (** RFC 5258 Section 3.5 - CHILDINFO extended data *)
233
+
234
+
(** LIST command variants per RFC 5258 *)
235
+
type list_command =
236
+
| List_basic of {
237
+
reference : string; (** Reference name (context for pattern) *)
238
+
pattern : string; (** Mailbox pattern with wildcards *)
239
+
}
240
+
| List_extended of {
241
+
selection : list_select_option list; (** RFC 5258 Section 3.1 *)
242
+
reference : string;
243
+
patterns : string list; (** Multiple patterns allowed *)
244
+
return_opts : list_return_option list; (** RFC 5258 Section 3.2 *)
245
+
}
246
+
247
+
(** Extended LIST response per RFC 5258 Section 3.4 *)
248
+
type list_response_data = {
249
+
flags : list_flag list;
250
+
delimiter : char option;
251
+
name : mailbox_name;
252
+
extended : list_extended_item list; (** RFC 5258 Section 3.5 *)
253
+
}
203
254
204
255
(* Connection state - RFC 9051 Section 3 *)
205
256
type connection_state =
···
334
385
else
335
386
None
336
387
388
+
(* === THREAD Types - RFC 5256 === *)
389
+
390
+
(** Threading algorithm for the THREAD command.
391
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
392
+
type thread_algorithm =
393
+
| Thread_orderedsubject
394
+
(** ORDEREDSUBJECT algorithm (RFC 5256 Section 3.1).
395
+
Groups messages by base subject, then sorts by sent date. *)
396
+
| Thread_references
397
+
(** REFERENCES algorithm (RFC 5256 Section 3.2).
398
+
Implements the JWZ threading algorithm using Message-ID,
399
+
In-Reply-To, and References headers. *)
400
+
| Thread_extension of string
401
+
(** Future algorithm extensions. *)
402
+
403
+
(** A thread node in the THREAD response.
404
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
405
+
type thread_node =
406
+
| Thread_message of int * thread_node list
407
+
(** A message with its sequence number/UID and child threads. *)
408
+
| Thread_dummy of thread_node list
409
+
(** A placeholder for a missing parent message. *)
410
+
411
+
(** Thread result: a list of root-level thread trees.
412
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
413
+
type thread_result = thread_node list
414
+
415
+
(* === Quota Types - RFC 9208 === *)
416
+
417
+
(** Quota resource types.
418
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5}RFC 9208 Section 5}. *)
419
+
type quota_resource =
420
+
| Quota_storage (** STORAGE - physical space in KB.
421
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
422
+
| Quota_message (** MESSAGE - number of messages.
423
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
424
+
| Quota_mailbox (** MAILBOX - number of mailboxes.
425
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.3}RFC 9208 Section 5.3}. *)
426
+
| Quota_annotation_storage (** ANNOTATION-STORAGE - annotation size in KB.
427
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.4}RFC 9208 Section 5.4}. *)
428
+
429
+
(** A single quota resource with usage and limit.
430
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2.2}RFC 9208 Section 4.2.2}. *)
431
+
type quota_resource_info = {
432
+
resource : quota_resource;
433
+
usage : int64; (** Current usage *)
434
+
limit : int64; (** Maximum allowed *)
435
+
}
436
+
337
437
(* === Commands - RFC 9051 Section 6 === *)
338
438
339
439
type command =
···
351
451
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
352
452
| Subscribe of mailbox_name
353
453
| Unsubscribe of mailbox_name
354
-
| List of { reference : string; pattern : string }
454
+
| List of list_command (** LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
355
455
| Namespace
356
456
| Status of { mailbox : mailbox_name; items : status_item list }
357
457
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
···
366
466
| Move of { sequence : sequence_set; mailbox : mailbox_name }
367
467
| Uid of uid_command
368
468
| Id of (string * string) list option (** RFC 2971 - NIL or list of field/value pairs *)
469
+
(* QUOTA extension - RFC 9208 *)
470
+
| Getquota of string (** GETQUOTA quota-root.
471
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2}RFC 9208 Section 4.2}. *)
472
+
| Getquotaroot of mailbox_name (** GETQUOTAROOT mailbox.
473
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.3}RFC 9208 Section 4.3}. *)
474
+
| Setquota of { root : string; limits : (quota_resource * int64) list } (** SETQUOTA.
475
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.1}RFC 9208 Section 4.1}. *)
476
+
(* THREAD extension - RFC 5256 *)
477
+
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
478
+
(** THREAD command.
479
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
369
480
370
481
and uid_command =
371
482
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
···
374
485
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
375
486
| Uid_search of { charset : string option; criteria : search_key }
376
487
| Uid_expunge of sequence_set
488
+
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
489
+
(** UID THREAD command - RFC 5256. Returns UIDs instead of sequence numbers. *)
377
490
378
491
type tagged_command = {
379
492
tag : string;
···
419
532
| Bye of { code : response_code option; text : string }
420
533
| Capability_response of string list
421
534
| Enabled of string list
422
-
| List_response of { flags : list_flag list; delimiter : char option; name : mailbox_name }
535
+
| List_response of list_response_data (** RFC 9051, RFC 5258 LIST-EXTENDED *)
423
536
| Namespace_response of namespace_data
424
537
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
425
538
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
···
429
542
| Fetch_response of { seq : int; items : fetch_response_item list }
430
543
| Continuation of string option
431
544
| Id_response of (string * string) list option (** RFC 2971 - NIL or list of field/value pairs *)
545
+
(* QUOTA extension responses - RFC 9208 *)
546
+
| Quota_response of { root : string; resources : quota_resource_info list }
547
+
(** QUOTA response.
548
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
549
+
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
550
+
(** QUOTAROOT response.
551
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
552
+
(* THREAD extension response - RFC 5256 *)
553
+
| Thread_response of thread_result
554
+
(** THREAD response - a list of thread trees.
555
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
+115
-2
lib/imapd/protocol.mli
+115
-2
lib/imapd/protocol.mli
···
245
245
| List_subscribed (** \Subscribed *)
246
246
| List_haschildren (** \HasChildren *)
247
247
| List_hasnochildren (** \HasNoChildren *)
248
+
| List_nonexistent (** \NonExistent - RFC 5258 Section 3.4 *)
249
+
| List_remote (** \Remote - RFC 5258 Section 3.4 *)
248
250
| List_all (** \All - special-use *)
249
251
| List_archive (** \Archive *)
250
252
| List_drafts (** \Drafts *)
···
253
255
| List_sent (** \Sent *)
254
256
| List_trash (** \Trash *)
255
257
| List_extension of string (** Other flags *)
258
+
259
+
(** LIST selection options per RFC 5258 Section 3.1 *)
260
+
type list_select_option =
261
+
| List_select_subscribed (** RFC 5258 Section 3.1.1 *)
262
+
| List_select_remote (** RFC 5258 Section 3.1.2 *)
263
+
| List_select_recursivematch (** RFC 5258 Section 3.1.3 *)
264
+
| List_select_special_use (** RFC 6154 Section 3 *)
265
+
266
+
(** LIST return options per RFC 5258 Section 3.2 *)
267
+
type list_return_option =
268
+
| List_return_subscribed (** RFC 5258 Section 3.2.1 *)
269
+
| List_return_children (** RFC 5258 Section 3.2.2 *)
270
+
| List_return_special_use (** RFC 6154 Section 3 *)
271
+
272
+
(** Extended data items in LIST response per RFC 5258 Section 3.5 *)
273
+
type list_extended_item =
274
+
| Childinfo of string list (** RFC 5258 Section 3.5 - CHILDINFO extended data *)
275
+
276
+
(** LIST command variants per RFC 5258 *)
277
+
type list_command =
278
+
| List_basic of {
279
+
reference : string; (** Reference name *)
280
+
pattern : string; (** Mailbox pattern *)
281
+
}
282
+
| List_extended of {
283
+
selection : list_select_option list;
284
+
reference : string;
285
+
patterns : string list;
286
+
return_opts : list_return_option list;
287
+
}
288
+
289
+
(** Extended LIST response per RFC 5258 Section 3.4 *)
290
+
type list_response_data = {
291
+
flags : list_flag list;
292
+
delimiter : char option;
293
+
name : mailbox_name;
294
+
extended : list_extended_item list;
295
+
}
256
296
257
297
(** {1 Connection State}
258
298
···
332
372
| Code_unknown_cte
333
373
| Code_other of string * string option
334
374
375
+
(** {1 Quota Types}
376
+
377
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208}RFC 9208 - IMAP QUOTA Extension}. *)
378
+
379
+
(** Quota resource types.
380
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5}RFC 9208 Section 5}. *)
381
+
type quota_resource =
382
+
| Quota_storage (** STORAGE - physical space in KB.
383
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
384
+
| Quota_message (** MESSAGE - number of messages.
385
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
386
+
| Quota_mailbox (** MAILBOX - number of mailboxes.
387
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.3}RFC 9208 Section 5.3}. *)
388
+
| Quota_annotation_storage (** ANNOTATION-STORAGE - annotation size in KB.
389
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.4}RFC 9208 Section 5.4}. *)
390
+
391
+
(** A single quota resource with usage and limit.
392
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2.2}RFC 9208 Section 4.2.2}. *)
393
+
type quota_resource_info = {
394
+
resource : quota_resource;
395
+
usage : int64; (** Current usage *)
396
+
limit : int64; (** Maximum allowed *)
397
+
}
398
+
399
+
(** {1 Thread Types}
400
+
401
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256}RFC 5256 - IMAP SORT and THREAD Extensions}. *)
402
+
403
+
(** Threading algorithm for the THREAD command.
404
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
405
+
type thread_algorithm =
406
+
| Thread_orderedsubject
407
+
(** ORDEREDSUBJECT algorithm (RFC 5256 Section 3.1). *)
408
+
| Thread_references
409
+
(** REFERENCES algorithm (RFC 5256 Section 3.2). *)
410
+
| Thread_extension of string
411
+
(** Future algorithm extensions. *)
412
+
413
+
(** A thread node in the THREAD response.
414
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
415
+
type thread_node =
416
+
| Thread_message of int * thread_node list
417
+
(** A message with its sequence number/UID and child threads. *)
418
+
| Thread_dummy of thread_node list
419
+
(** A placeholder for a missing parent message. *)
420
+
421
+
(** Thread result: a list of root-level thread trees. *)
422
+
type thread_result = thread_node list
423
+
335
424
(** {1 Commands}
336
425
337
426
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6}RFC 9051 Section 6}. *)
···
351
440
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
352
441
| Subscribe of mailbox_name
353
442
| Unsubscribe of mailbox_name
354
-
| List of { reference : string; pattern : string }
443
+
| List of list_command (** LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
355
444
| Namespace
356
445
| Status of { mailbox : mailbox_name; items : status_item list }
357
446
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
···
366
455
| Move of { sequence : sequence_set; mailbox : mailbox_name }
367
456
| Uid of uid_command
368
457
| Id of (string * string) list option (** RFC 2971 *)
458
+
(* QUOTA extension - RFC 9208 *)
459
+
| Getquota of string (** GETQUOTA quota-root.
460
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2}RFC 9208 Section 4.2}. *)
461
+
| Getquotaroot of mailbox_name (** GETQUOTAROOT mailbox.
462
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.3}RFC 9208 Section 4.3}. *)
463
+
| Setquota of { root : string; limits : (quota_resource * int64) list } (** SETQUOTA.
464
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.1}RFC 9208 Section 4.1}. *)
465
+
(* THREAD extension - RFC 5256 *)
466
+
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
467
+
(** THREAD command.
468
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
369
469
370
470
and uid_command =
371
471
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
···
374
474
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
375
475
| Uid_search of { charset : string option; criteria : search_key }
376
476
| Uid_expunge of sequence_set
477
+
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
478
+
(** UID THREAD command - RFC 5256. Returns UIDs instead of sequence numbers. *)
377
479
378
480
type tagged_command = {
379
481
tag : string;
···
421
523
| Bye of { code : response_code option; text : string }
422
524
| Capability_response of string list
423
525
| Enabled of string list
424
-
| List_response of { flags : list_flag list; delimiter : char option; name : mailbox_name }
526
+
| List_response of list_response_data (** RFC 9051, RFC 5258 LIST-EXTENDED *)
425
527
| Namespace_response of namespace_data
426
528
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
427
529
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
···
431
533
| Fetch_response of { seq : int; items : fetch_response_item list }
432
534
| Continuation of string option
433
535
| Id_response of (string * string) list option (** RFC 2971 *)
536
+
(* QUOTA extension responses - RFC 9208 *)
537
+
| Quota_response of { root : string; resources : quota_resource_info list }
538
+
(** QUOTA response.
539
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
540
+
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
541
+
(** QUOTAROOT response.
542
+
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
543
+
(* THREAD extension response - RFC 5256 *)
544
+
| Thread_response of thread_result
545
+
(** THREAD response containing thread tree.
546
+
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
434
547
435
548
(** {1 Utility Functions} *)
436
549
+1
-1
lib/imapd/read.ml
+1
-1
lib/imapd/read.ml
+172
-49
lib/imapd/server.ml
+172
-49
lib/imapd/server.ml
···
13
13
(* Module alias to access Storage types without conflicting with functor parameter *)
14
14
module Storage_types = Storage
15
15
16
-
(* Base capabilities per RFC 9051 *)
16
+
(** Base capabilities per RFC 9051.
17
+
@see <https://datatracker.ietf.org/doc/html/rfc9051> RFC 9051: IMAP4rev2
18
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3: UTF8=ACCEPT *)
17
19
let base_capabilities_pre_tls = [
18
20
"IMAP4rev2";
19
21
"IMAP4rev1"; (* For compatibility *)
···
26
28
"ENABLE";
27
29
"LITERAL+";
28
30
"ID";
31
+
"UNSELECT"; (* RFC 3691 *)
32
+
"SPECIAL-USE"; (* RFC 6154 *)
33
+
"LIST-EXTENDED"; (* RFC 5258 *)
34
+
"CONDSTORE"; (* RFC 7162 - modification sequences for flags *)
35
+
(* QUOTA extension - RFC 9208 *)
36
+
"QUOTA";
37
+
"QUOTA=RES-STORAGE"; (* RFC 9208 Section 5.1 *)
38
+
"QUOTA=RES-MESSAGE"; (* RFC 9208 Section 5.2 *)
39
+
(* UTF-8 support - RFC 6855 *)
40
+
"UTF8=ACCEPT"; (* RFC 6855 Section 3 *)
41
+
(* THREAD extension - RFC 5256 *)
42
+
"THREAD=ORDEREDSUBJECT"; (* RFC 5256 Section 3.1 *)
43
+
"THREAD=REFERENCES"; (* RFC 5256 Section 3.2 *)
29
44
]
30
45
31
46
let base_capabilities_post_tls = [
···
39
54
"ENABLE";
40
55
"LITERAL+";
41
56
"ID";
57
+
"UNSELECT"; (* RFC 3691 *)
58
+
"SPECIAL-USE"; (* RFC 6154 *)
59
+
"LIST-EXTENDED"; (* RFC 5258 *)
60
+
"CONDSTORE"; (* RFC 7162 - modification sequences for flags *)
61
+
(* QUOTA extension - RFC 9208 *)
62
+
"QUOTA";
63
+
"QUOTA=RES-STORAGE"; (* RFC 9208 Section 5.1 *)
64
+
"QUOTA=RES-MESSAGE"; (* RFC 9208 Section 5.2 *)
65
+
(* UTF-8 support - RFC 6855 *)
66
+
"UTF8=ACCEPT"; (* RFC 6855 Section 3 *)
67
+
(* THREAD extension - RFC 5256 *)
68
+
"THREAD=ORDEREDSUBJECT"; (* RFC 5256 Section 3.1 *)
69
+
"THREAD=REFERENCES"; (* RFC 5256 Section 3.2 *)
42
70
]
43
71
44
72
(* Server configuration *)
···
62
90
(Storage : Storage.STORAGE)
63
91
(Auth : Auth.AUTH) = struct
64
92
93
+
(** Connection state with UTF-8 mode tracking.
94
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3 *)
65
95
type connection_state =
66
96
| Not_authenticated
67
-
| Authenticated of { username : string }
68
-
| Selected of { username : string; mailbox : string; readonly : bool }
97
+
| Authenticated of { username : string; utf8_enabled : bool }
98
+
| Selected of { username : string; mailbox : string; readonly : bool; utf8_enabled : bool }
69
99
| Logout
70
100
71
101
(* Action returned by command handlers *)
···
151
181
code = Some (Code_capability caps);
152
182
text = "LOGIN completed"
153
183
});
154
-
Authenticated { username }
184
+
Authenticated { username; utf8_enabled = false }
155
185
end else begin
156
186
send_response flow (No {
157
187
tag = Some tag;
···
170
200
171
201
(* Process SELECT/EXAMINE command - only valid in Authenticated/Selected state *)
172
202
let handle_select t flow tag mailbox ~readonly state =
173
-
let username = match state with
174
-
| Authenticated { username } -> Some username
175
-
| Selected { username; _ } -> Some username
176
-
| _ -> None
203
+
let username, utf8_enabled = match state with
204
+
| Authenticated { username; utf8_enabled } -> Some username, utf8_enabled
205
+
| Selected { username; utf8_enabled; _ } -> Some username, utf8_enabled
206
+
| _ -> None, false
177
207
in
178
208
match username with
179
209
| None ->
···
191
221
code = None;
192
222
text = "Invalid mailbox name"
193
223
});
194
-
Authenticated { username }
224
+
Authenticated { username; utf8_enabled }
195
225
end else
196
226
match Storage.select_mailbox t.storage ~username mailbox ~readonly with
197
227
| Error _ ->
···
200
230
code = Some Code_nonexistent;
201
231
text = "Mailbox does not exist"
202
232
});
203
-
Authenticated { username }
233
+
Authenticated { username; utf8_enabled }
204
234
| Ok mb_state ->
205
235
(* Send untagged responses *)
206
236
send_response flow (Flags_response mb_state.flags);
···
227
257
code;
228
258
text = if readonly then "EXAMINE completed" else "SELECT completed"
229
259
});
230
-
Selected { username; mailbox; readonly }
260
+
Selected { username; mailbox; readonly; utf8_enabled }
231
261
232
-
(* Process LIST command *)
233
-
let handle_list t flow tag ~reference ~pattern state =
262
+
(* Process LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
263
+
let handle_list t flow tag list_cmd state =
234
264
let username = match state with
235
-
| Authenticated { username } -> Some username
265
+
| Authenticated { username; _ } -> Some username
236
266
| Selected { username; _ } -> Some username
237
267
| _ -> None
238
268
in
···
245
275
});
246
276
state
247
277
| Some username ->
248
-
let mailboxes = Storage.list_mailboxes t.storage ~username ~reference ~pattern in
278
+
(* Extract reference and patterns from list command *)
279
+
let reference, patterns = match list_cmd with
280
+
| List_basic { reference; pattern } -> (reference, [pattern])
281
+
| List_extended { reference; patterns; _ } -> (reference, patterns)
282
+
in
283
+
(* Process each pattern and collect mailboxes *)
284
+
let all_mailboxes = List.concat_map (fun pattern ->
285
+
Storage.list_mailboxes t.storage ~username ~reference ~pattern
286
+
) patterns in
287
+
(* Send LIST responses with extended data if needed *)
249
288
List.iter (fun (mb : Storage_types.mailbox_info) ->
250
289
send_response flow (List_response {
251
290
flags = mb.flags;
252
291
delimiter = mb.delimiter;
253
292
name = mb.name;
293
+
extended = []; (* Extended data can be populated based on return options *)
254
294
})
255
-
) mailboxes;
295
+
) all_mailboxes;
256
296
send_response flow (Ok { tag = Some tag; code = None; text = "LIST completed" });
257
297
state
258
298
···
264
304
state
265
305
end else
266
306
let username = match state with
267
-
| Authenticated { username } -> Some username
307
+
| Authenticated { username; _ } -> Some username
268
308
| Selected { username; _ } -> Some username
269
309
| _ -> None
270
310
in
···
320
360
(* Process STORE command *)
321
361
let handle_store t flow tag ~sequence ~silent ~action ~flags state =
322
362
match state with
323
-
| Selected { username; mailbox; readonly } ->
363
+
| Selected { username; mailbox; readonly; _ } ->
324
364
if readonly then begin
325
365
send_response flow (No { tag = Some tag; code = None; text = "Mailbox is read-only" });
326
366
state
···
351
391
(* Process EXPUNGE command *)
352
392
let handle_expunge t flow tag state =
353
393
match state with
354
-
| Selected { username; mailbox; readonly } ->
394
+
| Selected { username; mailbox; readonly; _ } ->
355
395
if readonly then begin
356
396
send_response flow (No { tag = Some tag; code = None; text = "Mailbox is read-only" });
357
397
state
···
376
416
(* Process CLOSE command *)
377
417
let handle_close t flow tag state =
378
418
match state with
379
-
| Selected { username; mailbox; readonly } ->
419
+
| Selected { username; mailbox; readonly; utf8_enabled } ->
380
420
(* Silently expunge if not readonly *)
381
421
if not readonly then
382
422
ignore (Storage.expunge t.storage ~username ~mailbox);
383
423
send_response flow (Ok { tag = Some tag; code = None; text = "CLOSE completed" });
384
-
Authenticated { username }
424
+
Authenticated { username; utf8_enabled }
385
425
| _ ->
386
426
send_response flow (Bad {
387
427
tag = Some tag;
···
393
433
(* Process UNSELECT command *)
394
434
let handle_unselect flow tag state =
395
435
match state with
396
-
| Selected { username; _ } ->
436
+
| Selected { username; utf8_enabled; _ } ->
397
437
send_response flow (Ok { tag = Some tag; code = None; text = "UNSELECT completed" });
398
-
Authenticated { username }
438
+
Authenticated { username; utf8_enabled }
399
439
| _ ->
400
440
send_response flow (Bad {
401
441
tag = Some tag;
···
412
452
state
413
453
end else
414
454
let username = match state with
415
-
| Authenticated { username } -> Some username
455
+
| Authenticated { username; _ } -> Some username
416
456
| Selected { username; _ } -> Some username
417
457
| _ -> None
418
458
in
···
448
488
state
449
489
end else
450
490
let username = match state with
451
-
| Authenticated { username } -> Some username
491
+
| Authenticated { username; _ } -> Some username
452
492
| Selected { username; _ } -> Some username
453
493
| _ -> None
454
494
in
···
485
525
state
486
526
end else
487
527
let username = match state with
488
-
| Authenticated { username } -> Some username
528
+
| Authenticated { username; _ } -> Some username
489
529
| Selected { username; _ } -> Some username
490
530
| _ -> None
491
531
in
···
567
607
state
568
608
end else
569
609
match state with
570
-
| Selected { username; mailbox = src_mailbox; readonly } ->
610
+
| Selected { username; mailbox = src_mailbox; readonly; _ } ->
571
611
if readonly then begin
572
612
send_response flow (No { tag = Some tag; code = None; text = "Mailbox is read-only" });
573
613
state
···
605
645
});
606
646
state
607
647
608
-
(* Process SEARCH command *)
609
-
let handle_search t flow tag ~charset:_ ~criteria state =
648
+
(** Process SEARCH command.
649
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3
650
+
After ENABLE UTF8=ACCEPT, SEARCH with CHARSET is rejected. *)
651
+
let handle_search t flow tag ~charset ~criteria state =
610
652
match state with
611
-
| Selected { username; mailbox; _ } ->
612
-
(match Storage.search t.storage ~username ~mailbox ~criteria with
613
-
| Result.Error _ ->
614
-
send_response flow (No { tag = Some tag; code = None; text = "SEARCH failed" })
615
-
| Result.Ok uids ->
616
-
(* Send ESEARCH response per RFC 9051 *)
617
-
let results = if List.length uids > 0 then
618
-
[Esearch_count (List.length uids); Esearch_all (List.map (fun uid -> Single (Int32.to_int uid)) uids)]
619
-
else
620
-
[Esearch_count 0]
621
-
in
622
-
send_response flow (Esearch { tag = Some tag; uid = false; results });
623
-
send_response flow (Ok { tag = Some tag; code = None; text = "SEARCH completed" }));
624
-
state
653
+
| Selected { username; mailbox; utf8_enabled; _ } ->
654
+
(* RFC 6855 Section 3: After ENABLE UTF8=ACCEPT, reject SEARCH with CHARSET *)
655
+
if utf8_enabled && Option.is_some charset then begin
656
+
send_response flow (Bad {
657
+
tag = Some tag;
658
+
code = None;
659
+
text = "CHARSET not allowed after ENABLE UTF8=ACCEPT"
660
+
});
661
+
state
662
+
end else begin
663
+
match Storage.search t.storage ~username ~mailbox ~criteria with
664
+
| Result.Error _ ->
665
+
send_response flow (No { tag = Some tag; code = None; text = "SEARCH failed" });
666
+
state
667
+
| Result.Ok uids ->
668
+
(* Send ESEARCH response per RFC 9051 *)
669
+
let results = if List.length uids > 0 then
670
+
[Esearch_count (List.length uids); Esearch_all (List.map (fun uid -> Single (Int32.to_int uid)) uids)]
671
+
else
672
+
[Esearch_count 0]
673
+
in
674
+
send_response flow (Esearch { tag = Some tag; uid = false; results });
675
+
send_response flow (Ok { tag = Some tag; code = None; text = "SEARCH completed" });
676
+
state
677
+
end
625
678
| _ ->
626
679
send_response flow (Bad {
627
680
tag = Some tag;
···
630
683
});
631
684
state
632
685
686
+
(** Process THREAD command - RFC 5256.
687
+
688
+
The THREAD command is used to retrieve message threads from a mailbox.
689
+
It takes an algorithm, charset, and search criteria, returning threads
690
+
of messages matching the criteria.
691
+
692
+
Note: This is a basic stub implementation that returns empty threads.
693
+
A full implementation would require:
694
+
- ORDEREDSUBJECT: subject.ml for base subject extraction (RFC 5256 Section 2.1)
695
+
- REFERENCES: Message-ID/In-Reply-To/References header parsing
696
+
697
+
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-3> RFC 5256 Section 3 *)
698
+
let handle_thread _t flow tag ~algorithm ~charset:_ ~criteria:_ state =
699
+
match state with
700
+
| Selected { username = _; mailbox = _; _ } ->
701
+
(* TODO: Implement actual threading algorithms.
702
+
For now, return empty thread result.
703
+
Full implementation would:
704
+
1. Search for messages matching criteria
705
+
2. Apply ORDEREDSUBJECT or REFERENCES algorithm
706
+
3. Build thread tree structure *)
707
+
let _ = algorithm in (* Acknowledge the algorithm parameter *)
708
+
send_response flow (Thread_response []);
709
+
send_response flow (Ok { tag = Some tag; code = None; text = "THREAD completed" });
710
+
state
711
+
| _ ->
712
+
send_response flow (Bad {
713
+
tag = Some tag;
714
+
code = None;
715
+
text = "THREAD requires selected state"
716
+
});
717
+
state
718
+
633
719
(* Process APPEND command *)
634
720
let handle_append t flow tag ~mailbox ~flags ~date ~message state =
635
721
(* Security: Validate mailbox name *)
···
638
724
state
639
725
end else
640
726
let username = match state with
641
-
| Authenticated { username } -> Some username
727
+
| Authenticated { username; _ } -> Some username
642
728
| Selected { username; _ } -> Some username
643
729
| _ -> None
644
730
in
···
694
780
});
695
781
state
696
782
697
-
(* Process ENABLE command - RFC 5161 *)
783
+
(** Process ENABLE command - RFC 5161, RFC 6855.
784
+
After ENABLE UTF8=ACCEPT, the session accepts UTF-8 in quoted-strings.
785
+
@see <https://datatracker.ietf.org/doc/html/rfc5161> RFC 5161: ENABLE Extension
786
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3 *)
698
787
let handle_enable flow tag ~capabilities state =
699
788
match state with
700
-
| Authenticated _ ->
789
+
| Authenticated { username; utf8_enabled } ->
701
790
(* Filter to capabilities we actually support *)
702
791
let enabled = List.filter (fun cap ->
703
792
let cap_upper = String.uppercase_ascii cap in
704
793
cap_upper = "IMAP4REV2" || cap_upper = "UTF8=ACCEPT"
705
794
) capabilities in
795
+
(* Check if UTF8=ACCEPT was requested and enabled *)
796
+
let new_utf8_enabled = utf8_enabled || List.exists (fun cap ->
797
+
String.uppercase_ascii cap = "UTF8=ACCEPT"
798
+
) enabled in
706
799
if List.length enabled > 0 then
707
800
send_response flow (Enabled enabled);
708
801
send_response flow (Ok { tag = Some tag; code = None; text = "ENABLE completed" });
709
-
state
802
+
Authenticated { username; utf8_enabled = new_utf8_enabled }
710
803
| _ ->
711
804
send_response flow (Bad {
712
805
tag = Some tag;
···
779
872
| Login { username; password } -> (handle_login t flow tag ~username ~password ~tls_active state, Continue)
780
873
| Select mailbox -> (handle_select t flow tag mailbox ~readonly:false state, Continue)
781
874
| Examine mailbox -> (handle_select t flow tag mailbox ~readonly:true state, Continue)
782
-
| List { reference; pattern } -> (handle_list t flow tag ~reference ~pattern state, Continue)
875
+
| List list_cmd -> (handle_list t flow tag list_cmd state, Continue)
783
876
| Status { mailbox; items } -> (handle_status t flow tag mailbox ~items state, Continue)
784
877
| Fetch { sequence; items } -> (handle_fetch t flow tag ~sequence ~items state, Continue)
785
878
| Store { sequence; silent; action; flags } -> (handle_store t flow tag ~sequence ~silent ~action ~flags state, Continue)
···
792
885
| Copy { sequence; mailbox } -> (handle_copy t flow tag ~sequence ~mailbox state, Continue)
793
886
| Move { sequence; mailbox } -> (handle_move t flow tag ~sequence ~mailbox state, Continue)
794
887
| Search { charset; criteria } -> (handle_search t flow tag ~charset ~criteria state, Continue)
888
+
| Thread { algorithm; charset; criteria } -> (handle_thread t flow tag ~algorithm ~charset ~criteria state, Continue)
795
889
| Append { mailbox; flags; date; message } -> (handle_append t flow tag ~mailbox ~flags ~date ~message state, Continue)
796
890
| Namespace -> (handle_namespace flow tag state, Continue)
797
891
| Enable caps -> (handle_enable flow tag ~capabilities:caps state, Continue)
···
816
910
| Authenticate _ ->
817
911
send_response flow (No { tag = Some tag; code = None; text = "Use LOGIN instead" });
818
912
(state, Continue)
913
+
(* QUOTA extension - RFC 9208 *)
914
+
| Getquota root ->
915
+
(* GETQUOTA returns quota information for a quota root *)
916
+
(* For now, return empty quota - storage backend would provide real data *)
917
+
send_response flow (Quota_response { root; resources = [] });
918
+
send_response flow (Ok { tag = Some tag; code = None; text = "GETQUOTA completed" });
919
+
(state, Continue)
920
+
| Getquotaroot mailbox ->
921
+
(* GETQUOTAROOT returns the quota roots for a mailbox *)
922
+
(* Typically the user's root is the quota root *)
923
+
let roots = [mailbox] in (* Simplified: use mailbox as its own quota root *)
924
+
send_response flow (Quotaroot_response { mailbox; roots });
925
+
(* Also send QUOTA responses for each root *)
926
+
List.iter (fun root ->
927
+
send_response flow (Quota_response { root; resources = [] })
928
+
) roots;
929
+
send_response flow (Ok { tag = Some tag; code = None; text = "GETQUOTAROOT completed" });
930
+
(state, Continue)
931
+
| Setquota { root; limits = _ } ->
932
+
(* SETQUOTA is admin-only in most implementations *)
933
+
send_response flow (No {
934
+
tag = Some tag;
935
+
code = Some Code_noperm;
936
+
text = Printf.sprintf "Cannot set quota for %s" root
937
+
});
938
+
(state, Continue)
819
939
820
940
(* Handle UID prefixed commands *)
821
941
and handle_uid_command t flow tag ~read_line_fn:_ uid_cmd state =
···
834
954
| Uid_expunge _sequence ->
835
955
(* UID EXPUNGE only expunges messages in the given UID set *)
836
956
handle_expunge t flow tag state
957
+
| Uid_thread { algorithm; charset; criteria } ->
958
+
(* UID THREAD returns UIDs instead of sequence numbers *)
959
+
handle_thread t flow tag ~algorithm ~charset ~criteria state
837
960
838
961
(* Maximum line length to prevent DoS attacks via memory exhaustion.
839
962
RFC 9051 Section 4 recommends supporting lines up to 8192 octets. *)
···
990
1113
text = "LOGIN completed"
991
1114
});
992
1115
(* Continue session as authenticated user *)
993
-
let state = Authenticated { username } in
1116
+
let state = Authenticated { username; utf8_enabled = false } in
994
1117
ignore (command_loop t flow state tls_active)
995
1118
end else begin
996
1119
(* Failed to drop privileges *)
+14
-2
lib/imapd/storage.ml
+14
-2
lib/imapd/storage.ml
···
60
60
flags : list_flag list;
61
61
}
62
62
63
+
(** Get SPECIAL-USE flags for a mailbox based on its name (RFC 6154) *)
64
+
let get_special_use_for_mailbox name =
65
+
match String.lowercase_ascii name with
66
+
| "drafts" -> [List_drafts]
67
+
| "sent" | "sent messages" | "sent items" -> [List_sent]
68
+
| "trash" | "deleted messages" | "deleted items" -> [List_trash]
69
+
| "junk" | "spam" -> [List_junk]
70
+
| "archive" -> [List_archive]
71
+
| _ -> []
72
+
63
73
(* Storage backend signature *)
64
74
module type STORAGE = sig
65
75
type t
···
168
178
ensure_inbox user;
169
179
Hashtbl.fold (fun name _mb acc ->
170
180
if matches_pattern ~pattern name then
171
-
{ name; delimiter = Some '/'; flags = [] } :: acc
181
+
let flags = get_special_use_for_mailbox name in
182
+
{ name; delimiter = Some '/'; flags } :: acc
172
183
else acc
173
184
) user.mailboxes []
174
185
···
700
711
let name = String.sub entry 1 (String.length entry - 1) in
701
712
let name = String.map (fun c -> if c = '.' then '/' else c) name in
702
713
if Memory_storage.matches_pattern ~pattern name then
703
-
{ name; delimiter = Some '/'; flags = [] } :: acc
714
+
let flags = get_special_use_for_mailbox name in
715
+
{ name; delimiter = Some '/'; flags } :: acc
704
716
else acc
705
717
else acc
706
718
else acc
+181
lib/imapd/utf8.ml
+181
lib/imapd/utf8.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** UTF-8 validation per RFC 3629 for RFC 6855 IMAP UTF-8 support.
7
+
@see <https://datatracker.ietf.org/doc/html/rfc6855> RFC 6855: IMAP Support for UTF-8
8
+
@see <https://datatracker.ietf.org/doc/html/rfc3629> RFC 3629: UTF-8 encoding *)
9
+
10
+
(** Check if a string contains any non-ASCII characters (bytes >= 128). *)
11
+
let has_non_ascii s =
12
+
let len = String.length s in
13
+
let rec loop i =
14
+
if i >= len then false
15
+
else if Char.code s.[i] >= 128 then true
16
+
else loop (i + 1)
17
+
in
18
+
loop 0
19
+
20
+
(** Validate UTF-8 encoding per RFC 3629 Section 4.
21
+
22
+
UTF-8 encoding (RFC 3629):
23
+
- 1-byte: 0xxxxxxx (U+0000..U+007F)
24
+
- 2-byte: 110xxxxx 10xxxxxx (U+0080..U+07FF)
25
+
- 3-byte: 1110xxxx 10xxxxxx 10xxxxxx (U+0800..U+FFFF)
26
+
- 4-byte: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx (U+10000..U+10FFFF)
27
+
28
+
Continuation bytes always have form 10xxxxxx.
29
+
30
+
@see <https://datatracker.ietf.org/doc/html/rfc3629#section-4> RFC 3629 Section 4 *)
31
+
let is_valid_utf8 s =
32
+
let len = String.length s in
33
+
let rec loop i =
34
+
if i >= len then true
35
+
else
36
+
let b0 = Char.code s.[i] in
37
+
if b0 <= 0x7F then
38
+
(* 1-byte sequence: ASCII *)
39
+
loop (i + 1)
40
+
else if b0 land 0xE0 = 0xC0 then begin
41
+
(* 2-byte sequence: 110xxxxx 10xxxxxx *)
42
+
if i + 1 >= len then false
43
+
else
44
+
let b1 = Char.code s.[i + 1] in
45
+
(* Check continuation byte *)
46
+
if b1 land 0xC0 <> 0x80 then false
47
+
else
48
+
(* Check for overlong encoding: must encode U+0080 or higher *)
49
+
let codepoint = ((b0 land 0x1F) lsl 6) lor (b1 land 0x3F) in
50
+
if codepoint < 0x80 then false
51
+
else loop (i + 2)
52
+
end
53
+
else if b0 land 0xF0 = 0xE0 then begin
54
+
(* 3-byte sequence: 1110xxxx 10xxxxxx 10xxxxxx *)
55
+
if i + 2 >= len then false
56
+
else
57
+
let b1 = Char.code s.[i + 1] in
58
+
let b2 = Char.code s.[i + 2] in
59
+
(* Check continuation bytes *)
60
+
if b1 land 0xC0 <> 0x80 || b2 land 0xC0 <> 0x80 then false
61
+
else
62
+
let codepoint =
63
+
((b0 land 0x0F) lsl 12) lor
64
+
((b1 land 0x3F) lsl 6) lor
65
+
(b2 land 0x3F)
66
+
in
67
+
(* Check for overlong encoding: must encode U+0800 or higher *)
68
+
if codepoint < 0x800 then false
69
+
(* Check for surrogate pairs (U+D800..U+DFFF are invalid) *)
70
+
else if codepoint >= 0xD800 && codepoint <= 0xDFFF then false
71
+
else loop (i + 3)
72
+
end
73
+
else if b0 land 0xF8 = 0xF0 then begin
74
+
(* 4-byte sequence: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx *)
75
+
if i + 3 >= len then false
76
+
else
77
+
let b1 = Char.code s.[i + 1] in
78
+
let b2 = Char.code s.[i + 2] in
79
+
let b3 = Char.code s.[i + 3] in
80
+
(* Check continuation bytes *)
81
+
if b1 land 0xC0 <> 0x80 ||
82
+
b2 land 0xC0 <> 0x80 ||
83
+
b3 land 0xC0 <> 0x80 then false
84
+
else
85
+
let codepoint =
86
+
((b0 land 0x07) lsl 18) lor
87
+
((b1 land 0x3F) lsl 12) lor
88
+
((b2 land 0x3F) lsl 6) lor
89
+
(b3 land 0x3F)
90
+
in
91
+
(* Check for overlong encoding: must encode U+10000 or higher *)
92
+
if codepoint < 0x10000 then false
93
+
(* Check valid Unicode range: max is U+10FFFF *)
94
+
else if codepoint > 0x10FFFF then false
95
+
else loop (i + 4)
96
+
end
97
+
else
98
+
(* Invalid start byte *)
99
+
false
100
+
in
101
+
loop 0
102
+
103
+
(** Decode a single UTF-8 codepoint at position [i] in string [s].
104
+
Returns the codepoint and the number of bytes consumed, or None if invalid.
105
+
Assumes is_valid_utf8 has already passed. *)
106
+
let decode_codepoint s i =
107
+
let len = String.length s in
108
+
if i >= len then None
109
+
else
110
+
let b0 = Char.code s.[i] in
111
+
if b0 <= 0x7F then
112
+
Some (b0, 1)
113
+
else if b0 land 0xE0 = 0xC0 && i + 1 < len then
114
+
let b1 = Char.code s.[i + 1] in
115
+
let cp = ((b0 land 0x1F) lsl 6) lor (b1 land 0x3F) in
116
+
Some (cp, 2)
117
+
else if b0 land 0xF0 = 0xE0 && i + 2 < len then
118
+
let b1 = Char.code s.[i + 1] in
119
+
let b2 = Char.code s.[i + 2] in
120
+
let cp =
121
+
((b0 land 0x0F) lsl 12) lor
122
+
((b1 land 0x3F) lsl 6) lor
123
+
(b2 land 0x3F)
124
+
in
125
+
Some (cp, 3)
126
+
else if b0 land 0xF8 = 0xF0 && i + 3 < len then
127
+
let b1 = Char.code s.[i + 1] in
128
+
let b2 = Char.code s.[i + 2] in
129
+
let b3 = Char.code s.[i + 3] in
130
+
let cp =
131
+
((b0 land 0x07) lsl 18) lor
132
+
((b1 land 0x3F) lsl 12) lor
133
+
((b2 land 0x3F) lsl 6) lor
134
+
(b3 land 0x3F)
135
+
in
136
+
Some (cp, 4)
137
+
else
138
+
None
139
+
140
+
(** Check if a codepoint is disallowed in mailbox names per RFC 6855 Section 3.
141
+
142
+
Disallowed characters:
143
+
- U+0000..U+001F: C0 control characters
144
+
- U+007F: DELETE
145
+
- U+0080..U+009F: C1 control characters
146
+
- U+2028: LINE SEPARATOR
147
+
- U+2029: PARAGRAPH SEPARATOR
148
+
149
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3
150
+
@see <https://datatracker.ietf.org/doc/html/rfc5198#section-2> RFC 5198 Section 2 *)
151
+
let is_disallowed_mailbox_codepoint cp =
152
+
(* C0 control characters U+0000..U+001F *)
153
+
(cp >= 0x0000 && cp <= 0x001F) ||
154
+
(* DELETE U+007F *)
155
+
cp = 0x007F ||
156
+
(* C1 control characters U+0080..U+009F *)
157
+
(cp >= 0x0080 && cp <= 0x009F) ||
158
+
(* LINE SEPARATOR U+2028 *)
159
+
cp = 0x2028 ||
160
+
(* PARAGRAPH SEPARATOR U+2029 *)
161
+
cp = 0x2029
162
+
163
+
(** Validate a mailbox name for UTF-8 compliance per RFC 6855 Section 3.
164
+
165
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3 *)
166
+
let is_valid_utf8_mailbox_name s =
167
+
(* First check basic UTF-8 validity *)
168
+
if not (is_valid_utf8 s) then false
169
+
else
170
+
(* Then check for disallowed codepoints *)
171
+
let len = String.length s in
172
+
let rec loop i =
173
+
if i >= len then true
174
+
else
175
+
match decode_codepoint s i with
176
+
| None -> false
177
+
| Some (cp, bytes) ->
178
+
if is_disallowed_mailbox_codepoint cp then false
179
+
else loop (i + bytes)
180
+
in
181
+
loop 0
+33
lib/imapd/utf8.mli
+33
lib/imapd/utf8.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** UTF-8 validation per RFC 3629 for RFC 6855 IMAP UTF-8 support.
7
+
@see <https://datatracker.ietf.org/doc/html/rfc6855> RFC 6855: IMAP Support for UTF-8
8
+
@see <https://datatracker.ietf.org/doc/html/rfc3629> RFC 3629: UTF-8 encoding *)
9
+
10
+
(** {1 UTF-8 Validation} *)
11
+
12
+
val is_valid_utf8 : string -> bool
13
+
(** [is_valid_utf8 s] returns [true] if [s] contains only valid UTF-8 sequences
14
+
per RFC 3629. Returns [true] for empty strings and pure ASCII strings.
15
+
@see <https://datatracker.ietf.org/doc/html/rfc3629#section-4> RFC 3629 Section 4 *)
16
+
17
+
val has_non_ascii : string -> bool
18
+
(** [has_non_ascii s] returns [true] if [s] contains any bytes with value >= 128.
19
+
This is useful for detecting when UTF-8 validation is needed. *)
20
+
21
+
(** {1 Mailbox Name Validation} *)
22
+
23
+
val is_valid_utf8_mailbox_name : string -> bool
24
+
(** [is_valid_utf8_mailbox_name s] validates a mailbox name for UTF-8 compliance
25
+
per RFC 6855 Section 3. Mailbox names must:
26
+
- Contain only valid UTF-8 sequences
27
+
- Comply with Net-Unicode (RFC 5198 Section 2)
28
+
- Not contain control characters U+0000-U+001F, U+0080-U+009F
29
+
- Not contain delete U+007F
30
+
- Not contain line separator U+2028 or paragraph separator U+2029
31
+
32
+
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3
33
+
@see <https://datatracker.ietf.org/doc/html/rfc5198#section-2> RFC 5198 Section 2 *)
+90
-5
lib/imapd/write.ml
+90
-5
lib/imapd/write.ml
···
350
350
| Unsubscribe mailbox ->
351
351
W.string w "UNSUBSCRIBE ";
352
352
astring w mailbox
353
-
| List { reference; pattern } ->
353
+
| List list_cmd ->
354
354
W.string w "LIST ";
355
-
astring w reference;
356
-
sp w;
357
-
astring w pattern
355
+
(match list_cmd with
356
+
| List_basic { reference; pattern } ->
357
+
astring w reference;
358
+
sp w;
359
+
astring w pattern
360
+
| List_extended { selection; reference; patterns; return_opts } ->
361
+
(* Selection options - RFC 5258 Section 3.1 *)
362
+
W.char w '(';
363
+
List.iteri (fun i opt ->
364
+
if i > 0 then sp w;
365
+
match opt with
366
+
| List_select_subscribed -> W.string w "SUBSCRIBED"
367
+
| List_select_remote -> W.string w "REMOTE"
368
+
| List_select_recursivematch -> W.string w "RECURSIVEMATCH"
369
+
| List_select_special_use -> W.string w "SPECIAL-USE"
370
+
) selection;
371
+
W.char w ')';
372
+
sp w;
373
+
astring w reference;
374
+
sp w;
375
+
(* Patterns - multiple patterns in parentheses *)
376
+
(match patterns with
377
+
| [p] -> astring w p
378
+
| ps ->
379
+
W.char w '(';
380
+
List.iteri (fun i p ->
381
+
if i > 0 then sp w;
382
+
astring w p
383
+
) ps;
384
+
W.char w ')');
385
+
(* Return options - RFC 5258 Section 3.2 *)
386
+
(match return_opts with
387
+
| [] -> ()
388
+
| opts ->
389
+
sp w;
390
+
W.string w "RETURN (";
391
+
List.iteri (fun i opt ->
392
+
if i > 0 then sp w;
393
+
match opt with
394
+
| List_return_subscribed -> W.string w "SUBSCRIBED"
395
+
| List_return_children -> W.string w "CHILDREN"
396
+
| List_return_special_use -> W.string w "SPECIAL-USE"
397
+
) opts;
398
+
W.char w ')'))
358
399
| Namespace -> W.string w "NAMESPACE"
359
400
| Status { mailbox; items } ->
360
401
W.string w "STATUS ";
···
449
490
search_key w criteria
450
491
| Uid_expunge set ->
451
492
W.string w "EXPUNGE ";
452
-
sequence_set w set)
493
+
sequence_set w set
494
+
| Uid_thread { algorithm; charset; criteria } ->
495
+
W.string w "THREAD ";
496
+
(match algorithm with
497
+
| Thread_orderedsubject -> W.string w "ORDEREDSUBJECT"
498
+
| Thread_references -> W.string w "REFERENCES"
499
+
| Thread_extension ext -> astring w ext);
500
+
sp w;
501
+
astring w charset;
502
+
sp w;
503
+
search_key w criteria)
453
504
| Id params ->
454
505
W.string w "ID ";
455
506
id_params w params
507
+
(* QUOTA extension - RFC 9208 *)
508
+
| Getquota root ->
509
+
W.string w "GETQUOTA ";
510
+
astring w root
511
+
| Getquotaroot mailbox ->
512
+
W.string w "GETQUOTAROOT ";
513
+
astring w mailbox
514
+
| Setquota { root; limits } ->
515
+
W.string w "SETQUOTA ";
516
+
astring w root;
517
+
sp w;
518
+
W.char w '(';
519
+
List.iteri (fun i (res, limit) ->
520
+
if i > 0 then sp w;
521
+
(match res with
522
+
| Quota_storage -> W.string w "STORAGE"
523
+
| Quota_message -> W.string w "MESSAGE"
524
+
| Quota_mailbox -> W.string w "MAILBOX"
525
+
| Quota_annotation_storage -> W.string w "ANNOTATION-STORAGE");
526
+
sp w;
527
+
W.string w (Int64.to_string limit)
528
+
) limits;
529
+
W.char w ')'
530
+
(* THREAD extension - RFC 5256 *)
531
+
| Thread { algorithm; charset; criteria } ->
532
+
W.string w "THREAD ";
533
+
(match algorithm with
534
+
| Thread_orderedsubject -> W.string w "ORDEREDSUBJECT"
535
+
| Thread_references -> W.string w "REFERENCES"
536
+
| Thread_extension ext -> astring w ext);
537
+
sp w;
538
+
astring w charset;
539
+
sp w;
540
+
search_key w criteria
456
541
457
542
let command w ~tag cmd =
458
543
atom w tag;
+8
test/dune
+8
test/dune
+1
-1
test/test_parser.ml
+1
-1
test/test_parser.ml
···
64
64
65
65
let test_parse_list () =
66
66
match parse_command "A008 LIST \"\" \"*\"\r\n" with
67
-
| Ok { tag; command = List { reference; pattern } } ->
67
+
| Ok { tag; command = List (List_basic { reference; pattern }) } ->
68
68
Alcotest.(check string) "tag" "A008" tag;
69
69
Alcotest.(check string) "reference" "" reference;
70
70
Alcotest.(check string) "pattern" "*" pattern
+449
test/test_read.ml
+449
test/test_read.ml
···
81
81
let is_enabled = function Imap.Response.Enabled _ -> true | _ -> false
82
82
let is_id = function Imap.Response.Id _ -> true | _ -> false
83
83
let is_fetch = function Imap.Response.Fetch _ -> true | _ -> false
84
+
let is_search = function Imap.Response.Search _ -> true | _ -> false
85
+
let is_sort = function Imap.Response.Sort _ -> true | _ -> false
84
86
85
87
let test_response_ok_tagged () =
86
88
let result = with_reader "A001 OK Success\r\n" (fun r -> Imap.Read.response r) in
···
288
290
Alcotest.(check int) "untagged count" 2 (List.length untagged);
289
291
Alcotest.(check bool) "final is OK" true (is_ok final)
290
292
293
+
(* BODY/BODYSTRUCTURE parsing tests *)
294
+
295
+
let is_body_text body =
296
+
match body.Imap.Body.body_type with
297
+
| Imap.Body.Text _ -> true
298
+
| _ -> false
299
+
300
+
let is_body_basic body =
301
+
match body.Imap.Body.body_type with
302
+
| Imap.Body.Basic _ -> true
303
+
| _ -> false
304
+
305
+
let is_body_multipart body =
306
+
match body.Imap.Body.body_type with
307
+
| Imap.Body.Multipart _ -> true
308
+
| _ -> false
309
+
310
+
let test_fetch_body_text_plain () =
311
+
(* Simple TEXT/PLAIN body structure *)
312
+
let result =
313
+
with_reader "* 1 FETCH (BODY (\"TEXT\" \"PLAIN\" (\"CHARSET\" \"UTF-8\") NIL NIL \"7BIT\" 100 5))\r\n"
314
+
(fun r -> Imap.Read.response r)
315
+
in
316
+
Alcotest.(check bool) "is FETCH" true (is_fetch result);
317
+
match result with
318
+
| Imap.Response.Fetch { items; _ } ->
319
+
let body_opt =
320
+
List.find_map
321
+
(function Imap.Fetch.Item_body b -> Some b | _ -> None)
322
+
items
323
+
in
324
+
(match body_opt with
325
+
| Some body ->
326
+
Alcotest.(check bool) "is text type" true (is_body_text body);
327
+
(match body.body_type with
328
+
| Imap.Body.Text { subtype; fields; lines } ->
329
+
Alcotest.(check string) "subtype" "PLAIN" subtype;
330
+
Alcotest.(check int64) "size" 100L fields.size;
331
+
Alcotest.(check int64) "lines" 5L lines;
332
+
Alcotest.(check string) "encoding" "7BIT" fields.encoding
333
+
| _ -> Alcotest.fail "expected Text body type")
334
+
| None -> Alcotest.fail "expected BODY item")
335
+
| _ -> Alcotest.fail "expected FETCH"
336
+
337
+
let test_fetch_body_basic () =
338
+
(* Basic APPLICATION/OCTET-STREAM body structure *)
339
+
let result =
340
+
with_reader "* 1 FETCH (BODY (\"APPLICATION\" \"OCTET-STREAM\" NIL NIL NIL \"BASE64\" 2048))\r\n"
341
+
(fun r -> Imap.Read.response r)
342
+
in
343
+
match result with
344
+
| Imap.Response.Fetch { items; _ } ->
345
+
let body_opt =
346
+
List.find_map
347
+
(function Imap.Fetch.Item_body b -> Some b | _ -> None)
348
+
items
349
+
in
350
+
(match body_opt with
351
+
| Some body ->
352
+
Alcotest.(check bool) "is basic type" true (is_body_basic body);
353
+
(match body.body_type with
354
+
| Imap.Body.Basic { media_type; subtype; fields } ->
355
+
Alcotest.(check string) "media_type" "APPLICATION" media_type;
356
+
Alcotest.(check string) "subtype" "OCTET-STREAM" subtype;
357
+
Alcotest.(check int64) "size" 2048L fields.size
358
+
| _ -> Alcotest.fail "expected Basic body type")
359
+
| None -> Alcotest.fail "expected BODY item")
360
+
| _ -> Alcotest.fail "expected FETCH"
361
+
362
+
let test_fetch_bodystructure_multipart () =
363
+
(* Multipart ALTERNATIVE body structure *)
364
+
let result =
365
+
with_reader "* 1 FETCH (BODYSTRUCTURE ((\"TEXT\" \"PLAIN\" NIL NIL NIL \"7BIT\" 50 2)(\"TEXT\" \"HTML\" NIL NIL NIL \"QUOTED-PRINTABLE\" 200 10) \"ALTERNATIVE\"))\r\n"
366
+
(fun r -> Imap.Read.response r)
367
+
in
368
+
match result with
369
+
| Imap.Response.Fetch { items; _ } ->
370
+
let body_opt =
371
+
List.find_map
372
+
(function Imap.Fetch.Item_bodystructure b -> Some b | _ -> None)
373
+
items
374
+
in
375
+
(match body_opt with
376
+
| Some body ->
377
+
Alcotest.(check bool) "is multipart" true (is_body_multipart body);
378
+
(match body.body_type with
379
+
| Imap.Body.Multipart { subtype; parts; _ } ->
380
+
Alcotest.(check string) "subtype" "ALTERNATIVE" subtype;
381
+
Alcotest.(check int) "parts count" 2 (List.length parts)
382
+
| _ -> Alcotest.fail "expected Multipart body type")
383
+
| None -> Alcotest.fail "expected BODYSTRUCTURE item")
384
+
| _ -> Alcotest.fail "expected FETCH"
385
+
386
+
let test_fetch_body_section () =
387
+
(* BODY[TEXT] with literal content *)
388
+
let result =
389
+
with_reader "* 1 FETCH (BODY[TEXT] {10}\r\nHello test)\r\n"
390
+
(fun r -> Imap.Read.response r)
391
+
in
392
+
match result with
393
+
| Imap.Response.Fetch { items; _ } ->
394
+
let section_opt =
395
+
List.find_map
396
+
(function
397
+
| Imap.Fetch.Item_body_section { section; origin; data } ->
398
+
Some (section, origin, data)
399
+
| _ -> None)
400
+
items
401
+
in
402
+
(match section_opt with
403
+
| Some (section, origin, data) ->
404
+
(match section with
405
+
| Some Imap.Body.Text -> ()
406
+
| _ -> Alcotest.fail "expected TEXT section");
407
+
Alcotest.(check (option int)) "no origin" None origin;
408
+
Alcotest.(check (option string)) "data" (Some "Hello test") data
409
+
| None -> Alcotest.fail "expected BODY section item")
410
+
| _ -> Alcotest.fail "expected FETCH"
411
+
412
+
let test_fetch_body_section_header () =
413
+
(* BODY[HEADER] with quoted string content *)
414
+
(* Note: IMAP quoted strings treat \r and \n as literal backslash + char *)
415
+
let result =
416
+
with_reader "* 1 FETCH (BODY[HEADER] \"Subject: Test\")\r\n"
417
+
(fun r -> Imap.Read.response r)
418
+
in
419
+
match result with
420
+
| Imap.Response.Fetch { items; _ } ->
421
+
let section_opt =
422
+
List.find_map
423
+
(function
424
+
| Imap.Fetch.Item_body_section { section; data; _ } ->
425
+
Some (section, data)
426
+
| _ -> None)
427
+
items
428
+
in
429
+
(match section_opt with
430
+
| Some (section, data) ->
431
+
(match section with
432
+
| Some Imap.Body.Header -> ()
433
+
| _ -> Alcotest.fail "expected HEADER section");
434
+
Alcotest.(check (option string)) "data" (Some "Subject: Test") data
435
+
| None -> Alcotest.fail "expected BODY section item")
436
+
| _ -> Alcotest.fail "expected FETCH"
437
+
438
+
let test_fetch_body_section_with_origin () =
439
+
(* BODY[]<0> with partial origin *)
440
+
let result =
441
+
with_reader "* 1 FETCH (BODY[]<0> {5}\r\nhello)\r\n"
442
+
(fun r -> Imap.Read.response r)
443
+
in
444
+
match result with
445
+
| Imap.Response.Fetch { items; _ } ->
446
+
let section_opt =
447
+
List.find_map
448
+
(function
449
+
| Imap.Fetch.Item_body_section { section; origin; data } ->
450
+
Some (section, origin, data)
451
+
| _ -> None)
452
+
items
453
+
in
454
+
(match section_opt with
455
+
| Some (section, origin, data) ->
456
+
Alcotest.(check (option int)) "origin" (Some 0) origin;
457
+
Alcotest.(check bool) "no section" true (Option.is_none section);
458
+
Alcotest.(check (option string)) "data" (Some "hello") data
459
+
| None -> Alcotest.fail "expected BODY section item")
460
+
| _ -> Alcotest.fail "expected FETCH"
461
+
462
+
let test_fetch_body_section_part () =
463
+
(* BODY[1.2] for nested part *)
464
+
let result =
465
+
with_reader "* 1 FETCH (BODY[1.2] \"part data\")\r\n"
466
+
(fun r -> Imap.Read.response r)
467
+
in
468
+
match result with
469
+
| Imap.Response.Fetch { items; _ } ->
470
+
let section_opt =
471
+
List.find_map
472
+
(function
473
+
| Imap.Fetch.Item_body_section { section; data; _ } ->
474
+
Some (section, data)
475
+
| _ -> None)
476
+
items
477
+
in
478
+
(match section_opt with
479
+
| Some (section, data) ->
480
+
(match section with
481
+
| Some (Imap.Body.Part ([1; 2], None)) -> ()
482
+
| Some (Imap.Body.Part (nums, _)) ->
483
+
Alcotest.fail (Printf.sprintf "wrong part numbers: [%s]"
484
+
(String.concat "; " (List.map string_of_int nums)))
485
+
| _ -> Alcotest.fail "expected Part section");
486
+
Alcotest.(check (option string)) "data" (Some "part data") data
487
+
| None -> Alcotest.fail "expected BODY section item")
488
+
| _ -> Alcotest.fail "expected FETCH"
489
+
490
+
let test_fetch_body_section_nil () =
491
+
(* BODY[TEXT] with NIL content *)
492
+
let result =
493
+
with_reader "* 1 FETCH (BODY[TEXT] NIL)\r\n"
494
+
(fun r -> Imap.Read.response r)
495
+
in
496
+
match result with
497
+
| Imap.Response.Fetch { items; _ } ->
498
+
let section_opt =
499
+
List.find_map
500
+
(function
501
+
| Imap.Fetch.Item_body_section { data; _ } -> Some data
502
+
| _ -> None)
503
+
items
504
+
in
505
+
(match section_opt with
506
+
| Some data ->
507
+
Alcotest.(check (option string)) "nil data" None data
508
+
| None -> Alcotest.fail "expected BODY section item")
509
+
| _ -> Alcotest.fail "expected FETCH"
510
+
511
+
let test_fetch_bodystructure_with_extensions () =
512
+
(* BODYSTRUCTURE with extension data (disposition, language, location) *)
513
+
let result =
514
+
with_reader "* 1 FETCH (BODYSTRUCTURE (\"TEXT\" \"PLAIN\" (\"CHARSET\" \"UTF-8\") NIL NIL \"7BIT\" 100 5 NIL (\"INLINE\" NIL) \"EN\" NIL))\r\n"
515
+
(fun r -> Imap.Read.response r)
516
+
in
517
+
match result with
518
+
| Imap.Response.Fetch { items; _ } ->
519
+
let body_opt =
520
+
List.find_map
521
+
(function Imap.Fetch.Item_bodystructure b -> Some b | _ -> None)
522
+
items
523
+
in
524
+
(match body_opt with
525
+
| Some body ->
526
+
Alcotest.(check bool) "is text type" true (is_body_text body);
527
+
(match body.disposition with
528
+
| Some (disp_type, _) ->
529
+
Alcotest.(check string) "disposition" "INLINE" disp_type
530
+
| None -> Alcotest.fail "expected disposition");
531
+
(match body.language with
532
+
| Some [lang] -> Alcotest.(check string) "language" "EN" lang
533
+
| _ -> Alcotest.fail "expected language")
534
+
| None -> Alcotest.fail "expected BODYSTRUCTURE item")
535
+
| _ -> Alcotest.fail "expected FETCH"
536
+
537
+
let test_response_search () =
538
+
let result =
539
+
with_reader "* SEARCH 2 4 7 11\r\n" (fun r -> Imap.Read.response r)
540
+
in
541
+
Alcotest.(check bool) "is SEARCH" true (is_search result);
542
+
match result with
543
+
| Imap.Response.Search seqs ->
544
+
Alcotest.(check (list int)) "search results" [2; 4; 7; 11] seqs
545
+
| _ -> Alcotest.fail "expected SEARCH"
546
+
547
+
let test_response_search_empty () =
548
+
let result =
549
+
with_reader "* SEARCH\r\n" (fun r -> Imap.Read.response r)
550
+
in
551
+
Alcotest.(check bool) "is SEARCH" true (is_search result);
552
+
match result with
553
+
| Imap.Response.Search seqs ->
554
+
Alcotest.(check (list int)) "empty search" [] seqs
555
+
| _ -> Alcotest.fail "expected SEARCH"
556
+
557
+
let test_response_search_single () =
558
+
let result =
559
+
with_reader "* SEARCH 42\r\n" (fun r -> Imap.Read.response r)
560
+
in
561
+
match result with
562
+
| Imap.Response.Search seqs ->
563
+
Alcotest.(check (list int)) "single search result" [42] seqs
564
+
| _ -> Alcotest.fail "expected SEARCH"
565
+
566
+
let test_response_sort () =
567
+
let result =
568
+
with_reader "* SORT 5 3 1 8\r\n" (fun r -> Imap.Read.response r)
569
+
in
570
+
Alcotest.(check bool) "is SORT" true (is_sort result);
571
+
match result with
572
+
| Imap.Response.Sort seqs ->
573
+
Alcotest.(check (list int64)) "sort results" [5L; 3L; 1L; 8L] seqs
574
+
| _ -> Alcotest.fail "expected SORT"
575
+
576
+
let test_response_sort_empty () =
577
+
let result =
578
+
with_reader "* SORT\r\n" (fun r -> Imap.Read.response r)
579
+
in
580
+
match result with
581
+
| Imap.Response.Sort seqs ->
582
+
Alcotest.(check (list int64)) "empty sort" [] seqs
583
+
| _ -> Alcotest.fail "expected SORT"
584
+
585
+
let test_response_appenduid () =
586
+
let result =
587
+
with_reader "A001 OK [APPENDUID 38505 3955] APPEND completed\r\n" (fun r -> Imap.Read.response r)
588
+
in
589
+
match result with
590
+
| Imap.Response.Ok { code = Some (Imap.Code.Appenduid (uidvalidity, uid)); _ } ->
591
+
Alcotest.(check int64) "uidvalidity" 38505L uidvalidity;
592
+
Alcotest.(check int64) "uid" 3955L uid
593
+
| _ -> Alcotest.fail "expected APPENDUID"
594
+
595
+
let test_response_copyuid_single () =
596
+
let result =
597
+
with_reader "A002 OK [COPYUID 38505 304 3956] Done\r\n" (fun r -> Imap.Read.response r)
598
+
in
599
+
match result with
600
+
| Imap.Response.Ok { code = Some (Imap.Code.Copyuid (uidvalidity, source_uids, dest_uids)); _ } ->
601
+
Alcotest.(check int64) "uidvalidity" 38505L uidvalidity;
602
+
Alcotest.(check int) "source count" 1 (List.length source_uids);
603
+
Alcotest.(check int) "dest count" 1 (List.length dest_uids)
604
+
| _ -> Alcotest.fail "expected COPYUID"
605
+
606
+
let test_response_copyuid_range () =
607
+
let result =
608
+
with_reader "A002 OK [COPYUID 38505 304,319:320 3956:3958] Done\r\n" (fun r -> Imap.Read.response r)
609
+
in
610
+
match result with
611
+
| Imap.Response.Ok { code = Some (Imap.Code.Copyuid (uidvalidity, source_uids, dest_uids)); _ } ->
612
+
Alcotest.(check int64) "uidvalidity" 38505L uidvalidity;
613
+
(* source_uids should have 2 ranges: 304 and 319:320 *)
614
+
Alcotest.(check int) "source count" 2 (List.length source_uids);
615
+
(* dest_uids should have 1 range: 3956:3958 *)
616
+
Alcotest.(check int) "dest count" 1 (List.length dest_uids)
617
+
| _ -> Alcotest.fail "expected COPYUID"
618
+
619
+
(* Helper to check if response is THREAD *)
620
+
let is_thread = function Imap.Response.Thread _ -> true | _ -> false
621
+
622
+
(* RFC 5256 THREAD response tests *)
623
+
let test_response_thread_empty () =
624
+
(* Empty THREAD response - no matching messages or no threads *)
625
+
let result =
626
+
with_reader "* THREAD\r\n" (fun r -> Imap.Read.response r)
627
+
in
628
+
Alcotest.(check bool) "is THREAD" true (is_thread result);
629
+
match result with
630
+
| Imap.Response.Thread threads ->
631
+
Alcotest.(check int) "empty threads" 0 (List.length threads)
632
+
| _ -> Alcotest.fail "expected THREAD"
633
+
634
+
let test_response_thread_single () =
635
+
(* Single thread with one message: (2) *)
636
+
let result =
637
+
with_reader "* THREAD (2)\r\n" (fun r -> Imap.Read.response r)
638
+
in
639
+
Alcotest.(check bool) "is THREAD" true (is_thread result);
640
+
match result with
641
+
| Imap.Response.Thread threads ->
642
+
Alcotest.(check int) "thread count" 1 (List.length threads);
643
+
(match List.hd threads with
644
+
| Imap.Thread.Message (n, children) ->
645
+
Alcotest.(check int) "message number" 2 n;
646
+
Alcotest.(check int) "no children" 0 (List.length children)
647
+
| _ -> Alcotest.fail "expected Message node")
648
+
| _ -> Alcotest.fail "expected THREAD"
649
+
650
+
let test_response_thread_multiple_roots () =
651
+
(* Multiple independent threads: (2)(3) *)
652
+
let result =
653
+
with_reader "* THREAD (2)(3)\r\n" (fun r -> Imap.Read.response r)
654
+
in
655
+
match result with
656
+
| Imap.Response.Thread threads ->
657
+
Alcotest.(check int) "thread count" 2 (List.length threads)
658
+
| _ -> Alcotest.fail "expected THREAD"
659
+
660
+
let test_response_thread_with_children () =
661
+
(* Thread with parent-child: (3 (6)) means 3 has child 6 *)
662
+
let result =
663
+
with_reader "* THREAD (3 (6))\r\n" (fun r -> Imap.Read.response r)
664
+
in
665
+
match result with
666
+
| Imap.Response.Thread threads ->
667
+
Alcotest.(check int) "thread count" 1 (List.length threads);
668
+
(match List.hd threads with
669
+
| Imap.Thread.Message (n, children) ->
670
+
Alcotest.(check int) "parent message" 3 n;
671
+
Alcotest.(check int) "one child" 1 (List.length children);
672
+
(match List.hd children with
673
+
| Imap.Thread.Message (cn, _) ->
674
+
Alcotest.(check int) "child message" 6 cn
675
+
| _ -> Alcotest.fail "expected child Message node")
676
+
| _ -> Alcotest.fail "expected Message node")
677
+
| _ -> Alcotest.fail "expected THREAD"
678
+
679
+
let test_response_thread_complex () =
680
+
(* Complex thread structure:
681
+
(2)(3 (6) (4 (23))(44 (7) (96)))
682
+
- Thread 1: Message 2 alone
683
+
- Thread 2: Message 3 with children 6, (4 with child 23), and (44 with children 7 and 96) *)
684
+
let result =
685
+
with_reader "* THREAD (2)(3 (6) (4 (23))(44 (7) (96)))\r\n" (fun r -> Imap.Read.response r)
686
+
in
687
+
match result with
688
+
| Imap.Response.Thread threads ->
689
+
Alcotest.(check int) "thread count" 2 (List.length threads);
690
+
(* First thread should be message 2 *)
691
+
(match List.hd threads with
692
+
| Imap.Thread.Message (n, _) ->
693
+
Alcotest.(check int) "first thread root" 2 n
694
+
| _ -> Alcotest.fail "expected Message node for first thread")
695
+
| _ -> Alcotest.fail "expected THREAD"
696
+
697
+
let test_response_thread_dummy_node () =
698
+
(* Dummy node (missing parent): ((5)(6)) - two messages sharing missing parent *)
699
+
let result =
700
+
with_reader "* THREAD ((5)(6))\r\n" (fun r -> Imap.Read.response r)
701
+
in
702
+
match result with
703
+
| Imap.Response.Thread threads ->
704
+
Alcotest.(check int) "thread count" 1 (List.length threads);
705
+
(match List.hd threads with
706
+
| Imap.Thread.Dummy children ->
707
+
Alcotest.(check int) "two orphaned children" 2 (List.length children)
708
+
| _ -> Alcotest.fail "expected Dummy node")
709
+
| _ -> Alcotest.fail "expected THREAD"
710
+
291
711
let () =
292
712
let open Alcotest in
293
713
run "imap_read"
···
337
757
test_case "ENABLED" `Quick test_response_enabled;
338
758
test_case "ID" `Quick test_response_id;
339
759
test_case "ID NIL" `Quick test_response_id_nil;
760
+
test_case "SEARCH" `Quick test_response_search;
761
+
test_case "SEARCH empty" `Quick test_response_search_empty;
762
+
test_case "SEARCH single" `Quick test_response_search_single;
763
+
test_case "SORT" `Quick test_response_sort;
764
+
test_case "SORT empty" `Quick test_response_sort_empty;
765
+
test_case "APPENDUID" `Quick test_response_appenduid;
766
+
test_case "COPYUID single" `Quick test_response_copyuid_single;
767
+
test_case "COPYUID range" `Quick test_response_copyuid_range;
340
768
test_case "responses until tagged" `Quick test_responses_until_tagged;
769
+
] );
770
+
( "body",
771
+
[
772
+
test_case "BODY TEXT/PLAIN" `Quick test_fetch_body_text_plain;
773
+
test_case "BODY basic" `Quick test_fetch_body_basic;
774
+
test_case "BODYSTRUCTURE multipart" `Quick test_fetch_bodystructure_multipart;
775
+
test_case "BODY[TEXT] section" `Quick test_fetch_body_section;
776
+
test_case "BODY[HEADER] section" `Quick test_fetch_body_section_header;
777
+
test_case "BODY[]<origin>" `Quick test_fetch_body_section_with_origin;
778
+
test_case "BODY[1.2] part" `Quick test_fetch_body_section_part;
779
+
test_case "BODY[TEXT] NIL" `Quick test_fetch_body_section_nil;
780
+
test_case "BODYSTRUCTURE extensions" `Quick test_fetch_bodystructure_with_extensions;
781
+
] );
782
+
( "thread",
783
+
[
784
+
test_case "THREAD empty" `Quick test_response_thread_empty;
785
+
test_case "THREAD single message" `Quick test_response_thread_single;
786
+
test_case "THREAD multiple roots" `Quick test_response_thread_multiple_roots;
787
+
test_case "THREAD with children" `Quick test_response_thread_with_children;
788
+
test_case "THREAD complex" `Quick test_response_thread_complex;
789
+
test_case "THREAD dummy node" `Quick test_response_thread_dummy_node;
341
790
] );
342
791
]
+3
-2
test/test_server.ml
+3
-2
test/test_server.ml
···
66
66
(contains_substring ~substring:"STARTTLS" serialized)
67
67
68
68
let test_list_response () =
69
-
let response = List_response { flags = []; delimiter = Some '/'; name = "INBOX" } in
69
+
let response = List_response { flags = []; delimiter = Some '/'; name = "INBOX"; extended = [] } in
70
70
let serialized = response_to_string response in
71
71
Alcotest.(check bool) "has LIST" true
72
72
(contains_substring ~substring:"LIST" serialized);
···
172
172
| Result.Ok cmd ->
173
173
Alcotest.(check string) "tag" "A005" cmd.tag;
174
174
(match cmd.command with
175
-
| List { reference; pattern } ->
175
+
| List (List_basic { reference; pattern }) ->
176
176
Alcotest.(check string) "reference" "" reference;
177
177
Alcotest.(check string) "pattern" "*" pattern
178
+
| List (List_extended _) -> Alcotest.fail "Expected basic List command"
178
179
| _ -> Alcotest.fail "Expected List command")
179
180
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
180
181
+142
test/test_subject.ml
+142
test/test_subject.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Subject base extraction (RFC 5256 Section 2.1) *)
7
+
8
+
open Imap
9
+
10
+
(* Test basic Re: prefix removal *)
11
+
let test_re_prefix () =
12
+
Alcotest.(check string) "Re: prefix" "test" (Subject.base_subject "Re: test");
13
+
Alcotest.(check string) "RE: uppercase" "test" (Subject.base_subject "RE: test");
14
+
Alcotest.(check string) "re: lowercase" "test" (Subject.base_subject "re: test");
15
+
Alcotest.(check string) "Re: extra space" "test" (Subject.base_subject "Re: test")
16
+
17
+
(* Test Fw: and Fwd: prefix removal *)
18
+
let test_fw_fwd_prefix () =
19
+
Alcotest.(check string) "Fw: prefix" "test" (Subject.base_subject "Fw: test");
20
+
Alcotest.(check string) "FW: uppercase" "test" (Subject.base_subject "FW: test");
21
+
Alcotest.(check string) "Fwd: prefix" "test" (Subject.base_subject "Fwd: test");
22
+
Alcotest.(check string) "FWD: uppercase" "test" (Subject.base_subject "FWD: test");
23
+
Alcotest.(check string) "fwd: lowercase" "test" (Subject.base_subject "fwd: test")
24
+
25
+
(* Test nested prefixes *)
26
+
let test_nested_prefixes () =
27
+
Alcotest.(check string) "Re: Re:" "test" (Subject.base_subject "Re: Re: test");
28
+
Alcotest.(check string) "Re: Re: Re:" "test" (Subject.base_subject "Re: Re: Re: test");
29
+
Alcotest.(check string) "Fwd: Re:" "test" (Subject.base_subject "Fwd: Re: test");
30
+
Alcotest.(check string) "Re: Fwd:" "test" (Subject.base_subject "Re: Fwd: test");
31
+
Alcotest.(check string) "Re: Fw: Re:" "test" (Subject.base_subject "Re: Fw: Re: test")
32
+
33
+
(* Test trailing (fwd) removal *)
34
+
let test_fwd_trailer () =
35
+
Alcotest.(check string) "trailing (fwd)" "test" (Subject.base_subject "test (fwd)");
36
+
Alcotest.(check string) "trailing (FWD)" "test" (Subject.base_subject "test (FWD)");
37
+
Alcotest.(check string) "trailing (Fwd)" "test" (Subject.base_subject "test (Fwd)");
38
+
Alcotest.(check string) "multiple (fwd)" "test" (Subject.base_subject "test (fwd) (fwd)")
39
+
40
+
(* Test [blob] removal *)
41
+
let test_blob_removal () =
42
+
Alcotest.(check string) "[PATCH] prefix" "test" (Subject.base_subject "[PATCH] test");
43
+
Alcotest.(check string) "[ocaml-list] prefix" "test" (Subject.base_subject "[ocaml-list] test");
44
+
Alcotest.(check string) "multiple blobs" "test" (Subject.base_subject "[PATCH] [v2] test");
45
+
Alcotest.(check string) "blob after Re:" "test" (Subject.base_subject "Re: [PATCH] test");
46
+
Alcotest.(check string) "Re: with blob" "test" (Subject.base_subject "Re[PATCH]: test")
47
+
48
+
(* Test combined patterns *)
49
+
let test_combined_patterns () =
50
+
Alcotest.(check string) "[PATCH] Re: [ocaml] test" "test"
51
+
(Subject.base_subject "[PATCH] Re: [ocaml] test");
52
+
Alcotest.(check string) "Re: [list] Re: subject" "subject"
53
+
(Subject.base_subject "Re: [list] Re: subject");
54
+
Alcotest.(check string) "complex nested" "actual subject"
55
+
(Subject.base_subject "Re: [list] Fwd: Re: [PATCH] actual subject")
56
+
57
+
(* Test [fwd: ...] wrapper *)
58
+
let test_fwd_wrapper () =
59
+
Alcotest.(check string) "[fwd: wrapped]" "wrapped" (Subject.base_subject "[fwd: wrapped]");
60
+
Alcotest.(check string) "[FWD: wrapped]" "wrapped" (Subject.base_subject "[FWD: wrapped]");
61
+
Alcotest.(check string) "[fwd: Re: test]" "test" (Subject.base_subject "[fwd: Re: test]")
62
+
63
+
(* Test whitespace normalization *)
64
+
let test_whitespace () =
65
+
Alcotest.(check string) "leading spaces" "spaced" (Subject.base_subject " spaced");
66
+
Alcotest.(check string) "trailing spaces" "spaced" (Subject.base_subject "spaced ");
67
+
Alcotest.(check string) "both sides" "spaced" (Subject.base_subject " spaced ");
68
+
Alcotest.(check string) "multiple internal" "hello world" (Subject.base_subject "hello world");
69
+
Alcotest.(check string) "tabs" "hello world" (Subject.base_subject "hello\tworld");
70
+
Alcotest.(check string) "mixed whitespace" "hello world" (Subject.base_subject " hello \t world ")
71
+
72
+
(* Test edge cases *)
73
+
let test_edge_cases () =
74
+
Alcotest.(check string) "empty string" "" (Subject.base_subject "");
75
+
Alcotest.(check string) "only Re:" "" (Subject.base_subject "Re:");
76
+
Alcotest.(check string) "only spaces" "" (Subject.base_subject " ");
77
+
Alcotest.(check string) "just a blob" "[PATCH]" (Subject.base_subject "[PATCH]");
78
+
Alcotest.(check string) "incomplete fwd wrapper" "[fwd: test" (Subject.base_subject "[fwd: test");
79
+
Alcotest.(check string) "Re without colon" "Re test" (Subject.base_subject "Re test")
80
+
81
+
(* Test is_reply_or_forward *)
82
+
let test_is_reply_or_forward () =
83
+
Alcotest.(check bool) "Re: is reply" true (Subject.is_reply_or_forward "Re: test");
84
+
Alcotest.(check bool) "Fwd: is forward" true (Subject.is_reply_or_forward "Fwd: test");
85
+
Alcotest.(check bool) "Fw: is forward" true (Subject.is_reply_or_forward "Fw: test");
86
+
Alcotest.(check bool) "(fwd) is forward" true (Subject.is_reply_or_forward "test (fwd)");
87
+
Alcotest.(check bool) "[fwd:] is forward" true (Subject.is_reply_or_forward "[fwd: test]");
88
+
Alcotest.(check bool) "plain is not reply" false (Subject.is_reply_or_forward "test");
89
+
Alcotest.(check bool) "[PATCH] is not reply" false (Subject.is_reply_or_forward "[PATCH] test")
90
+
91
+
(* Test real-world examples *)
92
+
let test_real_world () =
93
+
Alcotest.(check string) "mailing list style"
94
+
"How to use functors?"
95
+
(Subject.base_subject "[ocaml-list] Re: How to use functors?");
96
+
Alcotest.(check string) "patch series"
97
+
"Add new feature"
98
+
(Subject.base_subject "[PATCH v3 1/5] Add new feature");
99
+
Alcotest.(check string) "forwarded thread"
100
+
"Meeting tomorrow"
101
+
(Subject.base_subject "Fwd: Re: Re: Meeting tomorrow");
102
+
Alcotest.(check string) "bug tracker style"
103
+
"Fix memory leak"
104
+
(Subject.base_subject "Re: [Bug 12345] Fix memory leak (fwd)")
105
+
106
+
let () =
107
+
let open Alcotest in
108
+
run "subject" [
109
+
"re_prefix", [
110
+
test_case "Re: prefix removal" `Quick test_re_prefix;
111
+
];
112
+
"fw_fwd_prefix", [
113
+
test_case "Fw:/Fwd: prefix removal" `Quick test_fw_fwd_prefix;
114
+
];
115
+
"nested_prefixes", [
116
+
test_case "Nested prefixes" `Quick test_nested_prefixes;
117
+
];
118
+
"fwd_trailer", [
119
+
test_case "(fwd) trailer removal" `Quick test_fwd_trailer;
120
+
];
121
+
"blob_removal", [
122
+
test_case "[blob] removal" `Quick test_blob_removal;
123
+
];
124
+
"combined", [
125
+
test_case "Combined patterns" `Quick test_combined_patterns;
126
+
];
127
+
"fwd_wrapper", [
128
+
test_case "[fwd: ...] wrapper" `Quick test_fwd_wrapper;
129
+
];
130
+
"whitespace", [
131
+
test_case "Whitespace normalization" `Quick test_whitespace;
132
+
];
133
+
"edge_cases", [
134
+
test_case "Edge cases" `Quick test_edge_cases;
135
+
];
136
+
"is_reply_or_forward", [
137
+
test_case "is_reply_or_forward" `Quick test_is_reply_or_forward;
138
+
];
139
+
"real_world", [
140
+
test_case "Real-world examples" `Quick test_real_world;
141
+
];
142
+
]
+104
test/test_utf8.ml
+104
test/test_utf8.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for UTF-8 validation per RFC 6855.
7
+
@see <https://datatracker.ietf.org/doc/html/rfc6855> RFC 6855: IMAP Support for UTF-8
8
+
@see <https://datatracker.ietf.org/doc/html/rfc3629> RFC 3629: UTF-8 encoding *)
9
+
10
+
open Imapd.Utf8
11
+
12
+
(* Test is_valid_utf8 function *)
13
+
14
+
let test_valid_utf8_ascii () =
15
+
Alcotest.(check bool) "empty string" true (is_valid_utf8 "");
16
+
Alcotest.(check bool) "ASCII string" true (is_valid_utf8 "Hello, World!");
17
+
Alcotest.(check bool) "ASCII with digits" true (is_valid_utf8 "Test123");
18
+
Alcotest.(check bool) "ASCII with special chars" true (is_valid_utf8 "a@b.com")
19
+
20
+
let test_valid_utf8_multibyte () =
21
+
(* 2-byte UTF-8: U+00E9 (e with acute) = 0xC3 0xA9 *)
22
+
Alcotest.(check bool) "2-byte UTF-8: cafe" true (is_valid_utf8 "caf\xc3\xa9");
23
+
(* 3-byte UTF-8: U+4E2D (Chinese character) = 0xE4 0xB8 0xAD *)
24
+
Alcotest.(check bool) "3-byte UTF-8: Chinese" true (is_valid_utf8 "\xe4\xb8\xad\xe6\x96\x87");
25
+
(* 4-byte UTF-8: U+1F600 (grinning face emoji) = 0xF0 0x9F 0x98 0x80 *)
26
+
Alcotest.(check bool) "4-byte UTF-8: emoji" true (is_valid_utf8 "\xf0\x9f\x98\x80");
27
+
(* Mixed ASCII and UTF-8 *)
28
+
Alcotest.(check bool) "mixed" true (is_valid_utf8 "Hello \xe4\xb8\x96\xe7\x95\x8c")
29
+
30
+
let test_invalid_utf8 () =
31
+
(* Invalid start bytes *)
32
+
Alcotest.(check bool) "invalid 0xFF" false (is_valid_utf8 "\xff");
33
+
Alcotest.(check bool) "invalid 0xFE" false (is_valid_utf8 "\xfe");
34
+
(* Continuation byte without start *)
35
+
Alcotest.(check bool) "orphan continuation" false (is_valid_utf8 "\x80");
36
+
(* Truncated sequences *)
37
+
Alcotest.(check bool) "truncated 2-byte" false (is_valid_utf8 "\xc3");
38
+
Alcotest.(check bool) "truncated 3-byte" false (is_valid_utf8 "\xe4\xb8");
39
+
Alcotest.(check bool) "truncated 4-byte" false (is_valid_utf8 "\xf0\x9f\x98");
40
+
(* Overlong encodings (RFC 3629 explicitly forbids these) *)
41
+
Alcotest.(check bool) "overlong NUL" false (is_valid_utf8 "\xc0\x80"); (* U+0000 as 2 bytes *)
42
+
Alcotest.(check bool) "overlong /" false (is_valid_utf8 "\xc0\xaf"); (* U+002F as 2 bytes *)
43
+
(* Surrogate pairs (U+D800..U+DFFF are invalid in UTF-8) *)
44
+
Alcotest.(check bool) "surrogate D800" false (is_valid_utf8 "\xed\xa0\x80"); (* U+D800 *)
45
+
Alcotest.(check bool) "surrogate DFFF" false (is_valid_utf8 "\xed\xbf\xbf"); (* U+DFFF *)
46
+
(* Code points above U+10FFFF *)
47
+
Alcotest.(check bool) "above max" false (is_valid_utf8 "\xf4\x90\x80\x80") (* U+110000 *)
48
+
49
+
(* Test has_non_ascii function *)
50
+
51
+
let test_has_non_ascii () =
52
+
Alcotest.(check bool) "ASCII only" false (has_non_ascii "Hello");
53
+
Alcotest.(check bool) "empty" false (has_non_ascii "");
54
+
Alcotest.(check bool) "with accented" true (has_non_ascii "caf\xc3\xa9");
55
+
Alcotest.(check bool) "all high bytes" true (has_non_ascii "\x80\x81\x82")
56
+
57
+
(* Test is_valid_utf8_mailbox_name function *)
58
+
59
+
let test_valid_mailbox_names () =
60
+
Alcotest.(check bool) "INBOX" true (is_valid_utf8_mailbox_name "INBOX");
61
+
Alcotest.(check bool) "Sent/2024" true (is_valid_utf8_mailbox_name "Sent/2024");
62
+
Alcotest.(check bool) "Drafts" true (is_valid_utf8_mailbox_name "Drafts");
63
+
(* Chinese "Sent" folder *)
64
+
Alcotest.(check bool) "Chinese mailbox" true
65
+
(is_valid_utf8_mailbox_name "\xe5\x8f\x91\xe4\xbb\xb6\xe7\xae\xb1");
66
+
(* Japanese "Inbox" folder *)
67
+
Alcotest.(check bool) "Japanese mailbox" true
68
+
(is_valid_utf8_mailbox_name "\xe5\x8f\x97\xe4\xbf\xa1\xe7\xae\xb1")
69
+
70
+
let test_invalid_mailbox_names () =
71
+
(* C0 control characters (U+0000..U+001F) *)
72
+
Alcotest.(check bool) "NUL char" false (is_valid_utf8_mailbox_name "INBOX\x00");
73
+
Alcotest.(check bool) "control 0x01" false (is_valid_utf8_mailbox_name "Test\x01Name");
74
+
Alcotest.(check bool) "control 0x1F" false (is_valid_utf8_mailbox_name "Test\x1f");
75
+
(* DELETE (U+007F) *)
76
+
Alcotest.(check bool) "DELETE char" false (is_valid_utf8_mailbox_name "Test\x7fName");
77
+
(* C1 control characters (U+0080..U+009F) - these are 2-byte UTF-8 sequences *)
78
+
Alcotest.(check bool) "C1 control 0x80" false (is_valid_utf8_mailbox_name "Test\xc2\x80Name");
79
+
Alcotest.(check bool) "C1 control 0x9F" false (is_valid_utf8_mailbox_name "Test\xc2\x9fName");
80
+
(* Line separator U+2028 = 0xE2 0x80 0xA8 *)
81
+
Alcotest.(check bool) "line separator" false
82
+
(is_valid_utf8_mailbox_name "Test\xe2\x80\xa8Name");
83
+
(* Paragraph separator U+2029 = 0xE2 0x80 0xA9 *)
84
+
Alcotest.(check bool) "paragraph separator" false
85
+
(is_valid_utf8_mailbox_name "Test\xe2\x80\xa9Name");
86
+
(* Invalid UTF-8 should also fail *)
87
+
Alcotest.(check bool) "invalid UTF-8" false (is_valid_utf8_mailbox_name "\xff\xfe")
88
+
89
+
let () =
90
+
let open Alcotest in
91
+
run "utf8" [
92
+
"is_valid_utf8", [
93
+
test_case "ASCII strings" `Quick test_valid_utf8_ascii;
94
+
test_case "multibyte UTF-8" `Quick test_valid_utf8_multibyte;
95
+
test_case "invalid UTF-8" `Quick test_invalid_utf8;
96
+
];
97
+
"has_non_ascii", [
98
+
test_case "detect non-ASCII" `Quick test_has_non_ascii;
99
+
];
100
+
"is_valid_utf8_mailbox_name", [
101
+
test_case "valid mailbox names" `Quick test_valid_mailbox_names;
102
+
test_case "invalid mailbox names" `Quick test_invalid_mailbox_names;
103
+
];
104
+
]
+2
-1
test/test_write.ml
+2
-1
test/test_write.ml
···
195
195
let result =
196
196
serialize (fun w ->
197
197
Imap.Write.command w ~tag:"A014"
198
-
(Imap.Command.Search { charset = None; criteria = Imap.Search.Unseen }))
198
+
(Imap.Command.Search { charset = None; criteria = Imap.Search.Unseen; return_opts = None }))
199
199
in
200
200
Alcotest.(check string) "search" "A014 SEARCH UNSEEN\r\n" result
201
201
···
209
209
{
210
210
charset = None;
211
211
criteria = Imap.Search.And [ Imap.Search.Unseen; Imap.Search.From "alice@example.com" ];
212
+
return_opts = None;
212
213
}))
213
214
in
214
215
Alcotest.(check string) "search complex"