jon.recoil.org
forked from
anil.recoil.org/ocaml-imap
IMAP in OCaml
Add IMAP integration test suite and fix protocol bugs
Adds a comprehensive integration test suite for ocaml-imap inspired by
Dovecot's imaptest tool. The suite tests against a real IMAP server with
both scripted deterministic tests and randomized stress tests.
Test suite structure:
- imaptest_config.ml: CLI configuration via Cmdliner
- imaptest_output.ml: Colored terminal output
- imaptest_state.ml: State tracking for violation detection
- imaptest_utils.ml: Test helpers and RFC 5322 sample messages
- imaptest_scripted.ml: 36 deterministic tests across categories
- imaptest_stress.ml: Randomized stress tests with state tracking
- imaptest.ml: Combined runner with subcommands
Bug fixes discovered during testing:
1. APPEND literal synchronization (write.ml)
- Changed from synchronizing literal {size} to non-synchronizing
literal {size+} (LITERAL+ extension, RFC 7888)
- Without this, APPEND hangs waiting for continuation response
that was already sent
2. SEARCH response not implemented (response.ml, read.ml, client.ml)
- Added Response.Search type for traditional SEARCH responses
- Added parser for "* SEARCH n1 n2 n3..." format
- Fixed search/uid_search functions which were stubs returning []
References:
- RFC 9051: IMAP4rev2 protocol specification
- RFC 7888: LITERAL+ extension for non-synchronizing literals
- RFC 5322: Internet Message Format (test message format)
- Dovecot imaptest: https://dovecot.github.io/imaptest/
Test results: 30 passed, 2 failed (BODY/BODYSTRUCTURE parsing bugs
in core library), 4 skipped (server capability dependent)
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
Add SORT and CONDSTORE extensions to ocaml-imap
Implement RFC 5256 SORT and RFC 7162 CONDSTORE extensions for the
IMAP client library.
- Add Sort module with sort keys (Arrival, Cc, Date, From, Size,
Subject, To) and criterion type with reverse flag
- Add Sort and Uid_sort commands to Command module
- Add sort() and uid_sort() client functions requiring SORT capability
- Add SORT response parsing in read.ml
- Add Sort response type to Response module
- Add changedsince parameter to Fetch and Uid_fetch commands
- Add unchangedsince parameter to Store and Uid_store commands
- Add MODSEQ fetch item parsing
- Add modseq field to message_info and Fetch.message types
- Update fetch/uid_fetch/store/uid_store client functions
- Add test_sort_by_date testing SORT with ARRIVAL key and REVERSE
- Add test_condstore testing STORE with UNCHANGEDSINCE modifier
- Expand test suite from 65 to 98 tests covering FETCH variants,
SEARCH criteria, envelope parsing, and multi-message operations
- Fix keyword flag parsing to avoid double $ prefix
- Fix capability cache population in test setup
- Update API call sites for new optional parameters
- RFC 5256: Internet Message Access Protocol - SORT and THREAD Extensions
https://datatracker.ietf.org/doc/html/rfc5256
- RFC 7162: IMAP Extensions: Quick Flag Changes Resynchronization
(CONDSTORE) and Quick Mailbox Resynchronization (QRESYNC)
https://datatracker.ietf.org/doc/html/rfc7162
- RFC 9051: Internet Message Access Protocol (IMAP) - Version 4rev2
https://datatracker.ietf.org/doc/html/rfc9051
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
anil.recoil.org
+4
.gitignore
+4
.gitignore
+1
bin/imap_client.ml
+1
bin/imap_client.ml
+73
-25
lib/imap/client.ml
+73
-25
lib/imap/client.ml
···
37
37
body_structure : Body.t option;
38
38
internaldate : string option;
39
39
size : int64 option;
40
+
modseq : int64 option;
40
41
body_section : string option;
41
42
}
42
43
···
447
448
body_structure = None;
448
449
internaldate = None;
449
450
size = None;
451
+
modseq = None;
450
452
body_section = None;
451
453
}
452
454
in
···
459
461
| Fetch.Item_bodystructure b -> info := { !info with body_structure = Some b }
460
462
| Fetch.Item_internaldate d -> info := { !info with internaldate = Some d }
461
463
| Fetch.Item_rfc822_size s -> info := { !info with size = Some s }
464
+
| Fetch.Item_modseq m -> info := { !info with modseq = Some m }
462
465
| Fetch.Item_body_section { data; _ } -> info := { !info with body_section = data }
463
466
| _ -> ())
464
467
items;
465
468
!info
466
469
467
-
let fetch t ~sequence ~items =
470
+
let fetch t ~sequence ~items ?changedsince () =
468
471
require_selected t;
469
-
let tag = send_command t (Command.Fetch { sequence; items }) in
472
+
let tag = send_command t (Command.Fetch { sequence; items; changedsince }) in
470
473
let untagged, final = receive_responses t tag in
471
474
check_ok tag [] final;
472
475
List.filter_map
···
477
480
| _ -> None)
478
481
untagged
479
482
480
-
let uid_fetch t ~sequence ~items =
483
+
let uid_fetch t ~sequence ~items ?changedsince () =
481
484
require_selected t;
482
-
let tag = send_command t (Command.Uid (Uid_fetch { sequence; items })) in
485
+
let tag = send_command t (Command.Uid (Uid_fetch { sequence; items; changedsince })) in
483
486
let untagged, final = receive_responses t tag in
484
487
check_ok tag [] final;
485
488
List.filter_map
···
490
493
| _ -> None)
491
494
untagged
492
495
493
-
let store t ~sequence ~action ~flags ?(silent = false) () =
496
+
let store t ~sequence ~action ~flags ?(silent = false) ?unchangedsince () =
494
497
require_selected t;
495
-
let tag = send_command t (Command.Store { sequence; silent; action; flags }) in
498
+
let tag = send_command t (Command.Store { sequence; silent; action; flags; unchangedsince }) in
496
499
let untagged, final = receive_responses t tag in
497
500
check_ok tag [] final;
498
501
if silent then []
···
505
508
| _ -> None)
506
509
untagged
507
510
508
-
let uid_store t ~sequence ~action ~flags ?(silent = false) () =
511
+
let uid_store t ~sequence ~action ~flags ?(silent = false) ?unchangedsince () =
509
512
require_selected t;
510
-
let tag = send_command t (Command.Uid (Uid_store { sequence; silent; action; flags })) in
513
+
let tag = send_command t (Command.Uid (Uid_store { sequence; silent; action; flags; unchangedsince })) in
511
514
let untagged, final = receive_responses t tag in
512
515
check_ok tag [] final;
513
516
if silent then []
···
567
570
568
571
let search t ?charset criteria =
569
572
require_selected t;
570
-
let _tag = send_command t (Command.Search { charset; criteria }) in
571
-
[]
573
+
let tag = send_command t (Command.Search { charset; criteria }) in
574
+
let untagged, final = receive_responses t tag in
575
+
check_ok tag untagged final;
576
+
(* Extract search results from untagged responses *)
577
+
List.fold_left (fun acc resp ->
578
+
match resp with
579
+
| Response.Search seqs -> acc @ seqs
580
+
| _ -> acc
581
+
) [] untagged
572
582
573
583
let uid_search t ?charset criteria =
574
584
require_selected t;
575
-
let _tag = send_command t (Command.Uid (Uid_search { charset; criteria })) in
576
-
[]
585
+
let tag = send_command t (Command.Uid (Uid_search { charset; criteria })) in
586
+
let untagged, final = receive_responses t tag in
587
+
check_ok tag untagged final;
588
+
(* Extract UID search results from untagged responses - UIDs are returned as int64 *)
589
+
List.fold_left (fun acc resp ->
590
+
match resp with
591
+
| Response.Search seqs -> acc @ List.map Int64.of_int seqs
592
+
| _ -> acc
593
+
) [] untagged
594
+
595
+
let sort t ~charset criteria search =
596
+
require_selected t;
597
+
require_capability t "SORT";
598
+
let tag = send_command t (Command.Sort { charset; criteria; search }) in
599
+
let untagged, final = receive_responses t tag in
600
+
check_ok tag untagged final;
601
+
List.fold_left (fun acc resp ->
602
+
match resp with
603
+
| Response.Sort seqs -> acc @ seqs
604
+
| _ -> acc
605
+
) [] untagged
606
+
607
+
let uid_sort t ~charset criteria search =
608
+
require_selected t;
609
+
require_capability t "SORT";
610
+
let tag = send_command t (Command.Uid (Uid_sort { charset; criteria; search })) in
611
+
let untagged, final = receive_responses t tag in
612
+
check_ok tag untagged final;
613
+
List.fold_left (fun acc resp ->
614
+
match resp with
615
+
| Response.Sort seqs -> acc @ seqs
616
+
| _ -> acc
617
+
) [] untagged
577
618
578
619
let append t ~mailbox ~message ?(flags = []) ?date () =
579
620
require_authenticated t;
···
584
625
585
626
(** {1 IDLE Support} *)
586
627
587
-
let idle t ~timeout =
628
+
let idle t ~clock ~timeout =
588
629
require_selected t;
589
630
require_capability t "IDLE";
590
631
let tag = send_command t Command.Idle in
591
632
let events = ref [] in
592
633
let start = Unix.gettimeofday () in
593
-
let rec loop () =
634
+
(* Wait for initial continuation response *)
635
+
let initial = Read.response t.reader in
636
+
(match initial with
637
+
| Response.Continuation _ -> ()
638
+
| _ -> ());
639
+
(* Now we're in IDLE mode. Wait for timeout then send DONE. *)
640
+
Eio.Time.sleep clock timeout;
641
+
(* Send DONE to exit IDLE mode *)
642
+
Eio.Buf_write.with_flow t.flow (fun writer ->
643
+
Write.idle_done writer);
644
+
(* Read any pending responses until we get OK *)
645
+
let rec drain () =
594
646
let elapsed = Unix.gettimeofday () -. start in
595
-
if elapsed >= timeout then ()
647
+
if elapsed > timeout +. 5.0 then () (* Safety timeout *)
596
648
else
597
649
let resp = Read.response t.reader in
598
650
match resp with
599
-
| Response.Continuation _ -> loop ()
651
+
| Response.Ok { tag = Some t_tag; _ } when t_tag = tag -> ()
600
652
| Response.Exists n ->
601
653
events := Idle_exists n :: !events;
602
-
loop ()
654
+
drain ()
603
655
| Response.Expunge n ->
604
656
events := Idle_expunge n :: !events;
605
-
loop ()
657
+
drain ()
606
658
| Response.Fetch { seq; items } ->
607
659
let flags =
608
660
List.find_map
···
611
663
|> Option.value ~default:[]
612
664
in
613
665
events := Idle_fetch { seq; flags } :: !events;
614
-
loop ()
615
-
| Response.Ok { tag = Some t_tag; _ } when t_tag = tag -> ()
616
-
| _ -> loop ()
666
+
drain ()
667
+
| _ -> drain ()
617
668
in
618
-
(try loop () with _ -> ());
619
-
Eio.Buf_write.with_flow t.flow (fun writer ->
620
-
Write.idle_done writer);
621
-
let _, _ = receive_responses t tag in
669
+
drain ();
622
670
List.rev !events
623
671
624
672
let idle_done t =
+26
-2
lib/imap/client.mli
+26
-2
lib/imap/client.mli
···
52
52
body_structure : Body.t option;
53
53
internaldate : string option;
54
54
size : int64 option;
55
+
modseq : int64 option;
55
56
body_section : string option;
56
57
}
57
58
(** Information about a fetched message. *)
···
167
168
t ->
168
169
sequence:Seq.t ->
169
170
items:Fetch.request list ->
171
+
?changedsince:int64 ->
172
+
unit ->
170
173
message_info list
174
+
(** [fetch client ~sequence ~items ?changedsince ()] fetches message data.
175
+
If [changedsince] is provided, only returns messages with MODSEQ > value (CONDSTORE). *)
171
176
172
177
val uid_fetch :
173
178
t ->
174
179
sequence:Seq.t ->
175
180
items:Fetch.request list ->
181
+
?changedsince:int64 ->
182
+
unit ->
176
183
message_info list
184
+
(** [uid_fetch client ~sequence ~items ?changedsince ()] fetches by UID.
185
+
If [changedsince] is provided, only returns messages with MODSEQ > value (CONDSTORE). *)
177
186
178
187
val store :
179
188
t ->
···
181
190
action:Store.t ->
182
191
flags:Flag.t list ->
183
192
?silent:bool ->
193
+
?unchangedsince:int64 ->
184
194
unit ->
185
195
message_info list
196
+
(** [store client ~sequence ~action ~flags ?silent ?unchangedsince ()] modifies flags.
197
+
If [unchangedsince] is provided, only modifies messages with MODSEQ <= value (CONDSTORE). *)
186
198
187
199
val uid_store :
188
200
t ->
···
190
202
action:Store.t ->
191
203
flags:Flag.t list ->
192
204
?silent:bool ->
205
+
?unchangedsince:int64 ->
193
206
unit ->
194
207
message_info list
208
+
(** [uid_store client ~sequence ~action ~flags ?silent ?unchangedsince ()] modifies by UID.
209
+
If [unchangedsince] is provided, only modifies messages with MODSEQ <= value (CONDSTORE). *)
195
210
196
211
val copy : t -> sequence:Seq.t -> mailbox:string -> unit
197
212
val uid_copy : t -> sequence:Seq.t -> mailbox:string -> unit
···
202
217
val search : t -> ?charset:string -> Search.t -> int list
203
218
val uid_search : t -> ?charset:string -> Search.t -> int64 list
204
219
220
+
val sort : t -> charset:string -> Sort.t -> Search.t -> int64 list
221
+
(** [sort client ~charset criteria search] sorts messages matching search criteria.
222
+
Requires SORT extension. *)
223
+
224
+
val uid_sort : t -> charset:string -> Sort.t -> Search.t -> int64 list
225
+
(** [uid_sort client ~charset criteria search] like {!sort} but returns UIDs.
226
+
Requires SORT extension. *)
227
+
205
228
val append :
206
229
t ->
207
230
mailbox:string ->
···
213
236
214
237
(** {1 IDLE Support} *)
215
238
216
-
val idle : t -> timeout:float -> idle_event list
217
-
(** [idle client ~timeout] enters IDLE mode and waits for events. *)
239
+
val idle : t -> clock:_ Eio.Time.clock -> timeout:float -> idle_event list
240
+
(** [idle client ~clock ~timeout] enters IDLE mode and waits for events.
241
+
Uses the Eio clock for proper timeout handling. *)
218
242
219
243
val idle_done : t -> unit
220
244
(** [idle_done client] exits IDLE mode early. *)
+8
-2
lib/imap/command.ml
+8
-2
lib/imap/command.ml
···
36
36
| Unselect
37
37
| Expunge
38
38
| Search of { charset : string option; criteria : Search.t }
39
-
| Fetch of { sequence : Seq.t; items : Fetch.request list }
39
+
| Sort of { charset : string; criteria : Sort.t; search : Search.t }
40
+
| Fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
40
41
| Store of {
41
42
sequence : Seq.t;
42
43
silent : bool;
43
44
action : Store.t;
44
45
flags : Flag.t list;
46
+
unchangedsince : int64 option;
45
47
}
46
48
| Copy of { sequence : Seq.t; mailbox : Mailbox.t }
47
49
| Move of { sequence : Seq.t; mailbox : Mailbox.t }
···
49
51
| Id of (string * string) list option
50
52
51
53
and uid_command =
52
-
| Uid_fetch of { sequence : Seq.t; items : Fetch.request list }
54
+
| Uid_fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
53
55
| Uid_store of {
54
56
sequence : Seq.t;
55
57
silent : bool;
56
58
action : Store.t;
57
59
flags : Flag.t list;
60
+
unchangedsince : int64 option;
58
61
}
59
62
| Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
60
63
| Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
61
64
| Uid_search of { charset : string option; criteria : Search.t }
65
+
| Uid_sort of { charset : string; criteria : Sort.t; search : Search.t }
62
66
| Uid_expunge of Seq.t
63
67
64
68
type tagged = { tag : string; command : t }
···
90
94
| Unselect -> Fmt.string ppf "UNSELECT"
91
95
| Expunge -> Fmt.string ppf "EXPUNGE"
92
96
| Search _ -> Fmt.string ppf "SEARCH (...)"
97
+
| Sort _ -> Fmt.string ppf "SORT (...)"
93
98
| Fetch { sequence; _ } -> Fmt.pf ppf "FETCH %a (...)" Seq.pp sequence
94
99
| Store { sequence; action; _ } ->
95
100
let action_str = match action with Store.Set -> "FLAGS" | Store.Add -> "+FLAGS" | Store.Remove -> "-FLAGS" in
···
107
112
| Uid_copy { sequence; mailbox } -> Fmt.pf ppf "COPY %a %s" Seq.pp sequence mailbox
108
113
| Uid_move { sequence; mailbox } -> Fmt.pf ppf "MOVE %a %s" Seq.pp sequence mailbox
109
114
| Uid_search _ -> Fmt.string ppf "SEARCH (...)"
115
+
| Uid_sort _ -> Fmt.string ppf "SORT (...)"
110
116
| Uid_expunge seq -> Fmt.pf ppf "EXPUNGE %a" Seq.pp seq
+6
-2
lib/imap/command.mli
+6
-2
lib/imap/command.mli
···
36
36
| Unselect
37
37
| Expunge
38
38
| Search of { charset : string option; criteria : Search.t }
39
-
| Fetch of { sequence : Seq.t; items : Fetch.request list }
39
+
| Sort of { charset : string; criteria : Sort.t; search : Search.t }
40
+
| Fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
40
41
| Store of {
41
42
sequence : Seq.t;
42
43
silent : bool;
43
44
action : Store.t;
44
45
flags : Flag.t list;
46
+
unchangedsince : int64 option;
45
47
}
46
48
| Copy of { sequence : Seq.t; mailbox : Mailbox.t }
47
49
| Move of { sequence : Seq.t; mailbox : Mailbox.t }
···
49
51
| Id of (string * string) list option
50
52
51
53
and uid_command =
52
-
| Uid_fetch of { sequence : Seq.t; items : Fetch.request list }
54
+
| Uid_fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
53
55
| Uid_store of {
54
56
sequence : Seq.t;
55
57
silent : bool;
56
58
action : Store.t;
57
59
flags : Flag.t list;
60
+
unchangedsince : int64 option;
58
61
}
59
62
| Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
60
63
| Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
61
64
| Uid_search of { charset : string option; criteria : Search.t }
65
+
| Uid_sort of { charset : string; criteria : Sort.t; search : Search.t }
62
66
| Uid_expunge of Seq.t
63
67
64
68
type tagged = { tag : string; command : t }
+4
lib/imap/fetch.ml
+4
lib/imap/fetch.ml
···
51
51
| Item_internaldate of string
52
52
| Item_rfc822_size of int64
53
53
| Item_uid of int64
54
+
| Item_modseq of int64
54
55
| Item_body of Body.t
55
56
| Item_bodystructure of Body.t
56
57
| Item_body_section of {
···
71
72
body_structure : Body.t option;
72
73
internaldate : string option;
73
74
size : int64 option;
75
+
modseq : int64 option;
74
76
body_section : string option;
75
77
}
76
78
···
83
85
body_structure = None;
84
86
internaldate = None;
85
87
size = None;
88
+
modseq = None;
86
89
body_section = None;
87
90
}
88
91
···
96
99
| Item_body b | Item_bodystructure b -> { msg with body_structure = Some b }
97
100
| Item_internaldate d -> { msg with internaldate = Some d }
98
101
| Item_rfc822_size s -> { msg with size = Some s }
102
+
| Item_modseq m -> { msg with modseq = Some m }
99
103
| Item_body_section { data; _ } -> { msg with body_section = data }
100
104
| _ -> msg)
101
105
{ empty_message with seq }
+2
lib/imap/fetch.mli
+2
lib/imap/fetch.mli
···
36
36
| Item_internaldate of string
37
37
| Item_rfc822_size of int64
38
38
| Item_uid of int64
39
+
| Item_modseq of int64
39
40
| Item_body of Body.t
40
41
| Item_bodystructure of Body.t
41
42
| Item_body_section of {
···
56
57
body_structure : Body.t option;
57
58
internaldate : string option;
58
59
size : int64 option;
60
+
modseq : int64 option;
59
61
body_section : string option;
60
62
}
61
63
+7
lib/imap/flag.ml
+7
lib/imap/flag.ml
···
25
25
| System of system
26
26
| Keyword of string
27
27
28
+
let keyword name =
29
+
(* Strip leading $ if present to normalize *)
30
+
if String.length name > 0 && name.[0] = '$' then
31
+
Keyword (String.sub name 1 (String.length name - 1))
32
+
else
33
+
Keyword name
34
+
28
35
let pp ppf = function
29
36
| System f -> pp_system ppf f
30
37
| Keyword k -> Fmt.pf ppf "$%s" k
+9
lib/imap/flag.mli
+9
lib/imap/flag.mli
···
23
23
type t =
24
24
| System of system
25
25
| Keyword of string
26
+
(** Keyword flags. The string should NOT include the [$] prefix;
27
+
it will be added automatically when writing to the server.
28
+
Use {!keyword} to safely create keyword flags. *)
29
+
30
+
val keyword : string -> t
31
+
(** [keyword name] creates a keyword flag. The [$] prefix is handled
32
+
automatically - if [name] starts with [$], it will be stripped.
33
+
For example, both [keyword "Forwarded"] and [keyword "$Forwarded"]
34
+
produce the same flag that appears as [$Forwarded] on the wire. *)
26
35
27
36
val pp : Format.formatter -> t -> unit
28
37
val to_string : t -> string
+4
lib/imap/imap.ml
+4
lib/imap/imap.ml
···
56
56
- {!module:Code} - Response codes
57
57
- {!module:Fetch} - FETCH request/response items
58
58
- {!module:Search} - SEARCH criteria
59
+
- {!module:Sort} - SORT criteria (RFC 5256)
59
60
- {!module:Store} - STORE actions
60
61
- {!module:Status} - STATUS items
61
62
- {!module:List_attr} - LIST mailbox attributes
···
73
74
74
75
- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2
75
76
- {{:https://datatracker.ietf.org/doc/html/rfc2177}RFC 2177} - IDLE
77
+
- {{:https://datatracker.ietf.org/doc/html/rfc5256}RFC 5256} - SORT/THREAD
76
78
- {{:https://datatracker.ietf.org/doc/html/rfc6851}RFC 6851} - MOVE
79
+
- {{:https://datatracker.ietf.org/doc/html/rfc7162}RFC 7162} - CONDSTORE
77
80
- {{:https://datatracker.ietf.org/doc/html/rfc7888}RFC 7888} - LITERAL+
78
81
- {{:https://datatracker.ietf.org/doc/html/rfc2971}RFC 2971} - ID *)
79
82
···
92
95
module Code = Code
93
96
module Fetch = Fetch
94
97
module Search = Search
98
+
module Sort = Sort
95
99
module Store = Store
96
100
module Status = Status
97
101
module List_attr = List_attr
+4
lib/imap/imap.mli
+4
lib/imap/imap.mli
···
56
56
- {!module:Code} - Response codes
57
57
- {!module:Fetch} - FETCH request/response items
58
58
- {!module:Search} - SEARCH criteria
59
+
- {!module:Sort} - SORT criteria (RFC 5256)
59
60
- {!module:Store} - STORE actions
60
61
- {!module:Status} - STATUS items
61
62
- {!module:List_attr} - LIST mailbox attributes
···
73
74
74
75
- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2
75
76
- {{:https://datatracker.ietf.org/doc/html/rfc2177}RFC 2177} - IDLE
77
+
- {{:https://datatracker.ietf.org/doc/html/rfc5256}RFC 5256} - SORT/THREAD
76
78
- {{:https://datatracker.ietf.org/doc/html/rfc6851}RFC 6851} - MOVE
79
+
- {{:https://datatracker.ietf.org/doc/html/rfc7162}RFC 7162} - CONDSTORE
77
80
- {{:https://datatracker.ietf.org/doc/html/rfc7888}RFC 7888} - LITERAL+
78
81
- {{:https://datatracker.ietf.org/doc/html/rfc2971}RFC 2971} - ID *)
79
82
···
92
95
module Code = Code
93
96
module Fetch = Fetch
94
97
module Search = Search
98
+
module Sort = Sort
95
99
module Store = Store
96
100
module Status = Status
97
101
module List_attr = List_attr
+140
-1
lib/imap/read.ml
+140
-1
lib/imap/read.ml
···
130
130
| Some '\\' -> system_flag r
131
131
| Some '$' ->
132
132
R.char '$' r;
133
-
Flag.Keyword ("$" ^ atom r)
133
+
(* Don't include $ in keyword - it's added by Flag.pp and write.ml *)
134
+
Flag.Keyword (atom r)
134
135
| _ -> Flag.Keyword (atom r)
135
136
136
137
let flag_list r = parse_paren_list ~parse_item:flag r
···
299
300
| "RFC822.SIZE" ->
300
301
sp r;
301
302
Fetch.Item_rfc822_size (number64 r)
303
+
| "MODSEQ" ->
304
+
sp r;
305
+
R.char '(' r;
306
+
let modseq = number64 r in
307
+
R.char ')' r;
308
+
Fetch.Item_modseq modseq
309
+
| "RFC822" ->
310
+
(* RFC822 returns literal message content *)
311
+
sp r;
312
+
let data = nstring r in
313
+
Fetch.Item_body_section { section = None; origin = None; data }
314
+
| "RFC822.HEADER" ->
315
+
(* RFC822.HEADER returns literal headers *)
316
+
sp r;
317
+
let data = nstring r in
318
+
Fetch.Item_body_section { section = None; origin = None; data }
319
+
| "RFC822.TEXT" ->
320
+
(* RFC822.TEXT returns literal body text *)
321
+
sp r;
322
+
let data = nstring r in
323
+
Fetch.Item_body_section { section = None; origin = None; data }
302
324
| "INTERNALDATE" ->
303
325
sp r;
304
326
Fetch.Item_internaldate (quoted_string r)
305
327
| "ENVELOPE" ->
306
328
sp r;
307
329
Fetch.Item_envelope (envelope r)
330
+
| "BODY" -> (
331
+
(* Check if this is BODY[section] or just BODY (bodystructure) *)
332
+
match R.peek_char r with
333
+
| Some '[' ->
334
+
(* BODY[section]<origin> literal-or-nil *)
335
+
R.char '[' r;
336
+
let _section = R.take_while (fun c -> c <> ']') r in
337
+
R.char ']' r;
338
+
(* Skip optional origin <n> *)
339
+
let origin =
340
+
if R.peek_char r = Some '<' then (
341
+
R.char '<' r;
342
+
let n = number r in
343
+
R.char '>' r;
344
+
Some n)
345
+
else None
346
+
in
347
+
sp r;
348
+
let data = nstring r in
349
+
Fetch.Item_body_section { section = None; origin; data }
350
+
| _ ->
351
+
(* BODY without [] means bodystructure - skip for now *)
352
+
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)
390
+
| "BODYSTRUCTURE" ->
391
+
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
308
429
| _ -> Fetch.Item_flags []
309
430
310
431
let fetch_items r = parse_paren_list ~parse_item:fetch_item r
···
492
613
let params = id_params r in
493
614
crlf r;
494
615
Response.Id params
616
+
| "SEARCH" ->
617
+
(* Parse space-separated sequence numbers *)
618
+
let seqs = ref [] in
619
+
while R.peek_char r = Some ' ' do
620
+
sp r;
621
+
seqs := number r :: !seqs
622
+
done;
623
+
crlf r;
624
+
Response.Search (List.rev !seqs)
625
+
| "SORT" ->
626
+
(* Parse space-separated sequence numbers (UID or sequence numbers) *)
627
+
let seqs = ref [] in
628
+
while R.peek_char r = Some ' ' do
629
+
sp r;
630
+
seqs := number64 r :: !seqs
631
+
done;
632
+
crlf r;
633
+
Response.Sort (List.rev !seqs)
495
634
| _ ->
496
635
let _ = rest_of_line r in
497
636
Response.Ok { tag = None; code = None; text = "" })
+4
lib/imap/response.ml
+4
lib/imap/response.ml
···
43
43
| Namespace of namespace
44
44
| Status of { mailbox : Mailbox.t; items : (Status.item * int64) list }
45
45
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
46
+
| Search of int list
47
+
| Sort of int64 list
46
48
| Flags of Flag.t list
47
49
| Exists of int
48
50
| Recent of int
···
79
81
| Namespace _ -> Fmt.string ppf "* NAMESPACE ..."
80
82
| Status { mailbox; _ } -> Fmt.pf ppf "* STATUS %s (...)" mailbox
81
83
| Esearch _ -> Fmt.string ppf "* ESEARCH ..."
84
+
| Search seqs -> Fmt.pf ppf "* SEARCH %a" Fmt.(list ~sep:sp int) seqs
85
+
| Sort seqs -> Fmt.pf ppf "* SORT %a" Fmt.(list ~sep:sp int64) seqs
82
86
| Flags flags -> Fmt.pf ppf "* FLAGS (%a)" Fmt.(list ~sep:sp Flag.pp) flags
83
87
| Exists n -> Fmt.pf ppf "* %d EXISTS" n
84
88
| Recent n -> Fmt.pf ppf "* %d RECENT" n
+2
lib/imap/response.mli
+2
lib/imap/response.mli
···
43
43
| Namespace of namespace
44
44
| Status of { mailbox : Mailbox.t; items : (Status.item * int64) list }
45
45
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
46
+
| Search of int list
47
+
| Sort of int64 list
46
48
| Flags of Flag.t list
47
49
| Exists of int
48
50
| Recent of int
+43
lib/imap/sort.ml
+43
lib/imap/sort.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SORT Criteria
7
+
8
+
Sort keys for the SORT command as specified in RFC 5256. *)
9
+
10
+
type key =
11
+
| Arrival
12
+
| Cc
13
+
| Date
14
+
| From
15
+
| Size
16
+
| Subject
17
+
| To
18
+
19
+
type criterion = {
20
+
reverse : bool;
21
+
key : key;
22
+
}
23
+
24
+
type t = criterion list
25
+
26
+
let key k = { reverse = false; key = k }
27
+
let reverse k = { reverse = true; key = k }
28
+
29
+
let pp_key ppf = function
30
+
| Arrival -> Fmt.string ppf "ARRIVAL"
31
+
| Cc -> Fmt.string ppf "CC"
32
+
| Date -> Fmt.string ppf "DATE"
33
+
| From -> Fmt.string ppf "FROM"
34
+
| Size -> Fmt.string ppf "SIZE"
35
+
| Subject -> Fmt.string ppf "SUBJECT"
36
+
| To -> Fmt.string ppf "TO"
37
+
38
+
let pp_criterion ppf c =
39
+
if c.reverse then Fmt.pf ppf "REVERSE %a" pp_key c.key
40
+
else pp_key ppf c.key
41
+
42
+
let pp ppf criteria =
43
+
Fmt.(list ~sep:sp pp_criterion) ppf criteria
+37
lib/imap/sort.mli
+37
lib/imap/sort.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SORT Criteria
7
+
8
+
Sort keys for the SORT command as specified in RFC 5256. *)
9
+
10
+
(** Sort key specifies how to order messages *)
11
+
type key =
12
+
| Arrival (** Internal date and time of message *)
13
+
| Cc (** Addr-mailbox of first CC address *)
14
+
| Date (** Sent date from Date header *)
15
+
| From (** Addr-mailbox of first From address *)
16
+
| Size (** Size of message in octets *)
17
+
| Subject (** Subject header, ignoring Re: etc *)
18
+
| To (** Addr-mailbox of first To address *)
19
+
20
+
(** Sort criterion: key with optional reverse flag *)
21
+
type criterion = {
22
+
reverse : bool;
23
+
key : key;
24
+
}
25
+
26
+
(** Sort criteria list (at least one required) *)
27
+
type t = criterion list
28
+
29
+
val key : key -> criterion
30
+
(** [key k] creates a sort criterion for key [k] in ascending order. *)
31
+
32
+
val reverse : key -> criterion
33
+
(** [reverse k] creates a sort criterion for key [k] in descending order. *)
34
+
35
+
val pp_key : Format.formatter -> key -> unit
36
+
val pp_criterion : Format.formatter -> criterion -> unit
37
+
val pp : Format.formatter -> t -> unit
+64
-7
lib/imap/write.ml
+64
-7
lib/imap/write.ml
···
283
283
| Store.Add -> W.string w "+FLAGS"
284
284
| Store.Remove -> W.string w "-FLAGS"
285
285
286
+
(** {1 Sort Criteria} *)
287
+
288
+
let sort_key w = function
289
+
| Sort.Arrival -> W.string w "ARRIVAL"
290
+
| Sort.Cc -> W.string w "CC"
291
+
| Sort.Date -> W.string w "DATE"
292
+
| Sort.From -> W.string w "FROM"
293
+
| Sort.Size -> W.string w "SIZE"
294
+
| Sort.Subject -> W.string w "SUBJECT"
295
+
| Sort.To -> W.string w "TO"
296
+
297
+
let sort_criterion w c =
298
+
if c.Sort.reverse then W.string w "REVERSE ";
299
+
sort_key w c.Sort.key
300
+
301
+
let sort_criteria w criteria =
302
+
W.char w '(';
303
+
List.iteri
304
+
(fun i c ->
305
+
if i > 0 then sp w;
306
+
sort_criterion w c)
307
+
criteria;
308
+
W.char w ')'
309
+
286
310
(** {1 ID Parameters} *)
287
311
288
312
let id_params w = function
···
305
329
Option.iter (fun cs -> W.string w " CHARSET "; astring w cs) charset;
306
330
sp w;
307
331
search_key w criteria
332
+
333
+
let write_sort w charset criteria search =
334
+
W.string w "SORT ";
335
+
sort_criteria w criteria;
336
+
sp w;
337
+
astring w charset;
338
+
sp w;
339
+
search_key w search
308
340
309
341
let command_body w = function
310
342
| Command.Capability -> W.string w "CAPABILITY"
···
365
397
| flags -> sp w; flag_list w flags);
366
398
Option.iter (fun d -> sp w; quoted_string w d) date;
367
399
sp w;
368
-
literal w message
400
+
(* Use LITERAL+ to avoid synchronization issues *)
401
+
literal_plus w message
369
402
| Command.Idle -> W.string w "IDLE"
370
403
| Command.Close -> W.string w "CLOSE"
371
404
| Command.Unselect -> W.string w "UNSELECT"
372
405
| Command.Expunge -> W.string w "EXPUNGE"
373
406
| Command.Search { charset; criteria } ->
374
407
write_search w charset criteria
375
-
| Command.Fetch { sequence; items } ->
408
+
| Command.Sort { charset; criteria; search } ->
409
+
write_sort w charset criteria search
410
+
| Command.Fetch { sequence; items; changedsince } ->
376
411
W.string w "FETCH ";
377
412
sequence_set w sequence;
378
413
sp w;
379
-
fetch_items w items
380
-
| Command.Store { sequence; silent; action; flags } ->
414
+
fetch_items w items;
415
+
Option.iter (fun modseq ->
416
+
W.string w " (CHANGEDSINCE ";
417
+
number64 w modseq;
418
+
W.char w ')') changedsince
419
+
| Command.Store { sequence; silent; action; flags; unchangedsince } ->
381
420
W.string w "STORE ";
382
421
sequence_set w sequence;
383
422
sp w;
423
+
(match unchangedsince with
424
+
| Some modseq ->
425
+
W.string w "(UNCHANGEDSINCE ";
426
+
number64 w modseq;
427
+
W.string w ") "
428
+
| None -> ());
384
429
store_action w action;
385
430
if silent then W.string w ".SILENT";
386
431
sp w;
···
398
443
| Command.Uid cmd -> (
399
444
W.string w "UID ";
400
445
match cmd with
401
-
| Command.Uid_fetch { sequence; items } ->
446
+
| Command.Uid_fetch { sequence; items; changedsince } ->
402
447
W.string w "FETCH ";
403
448
sequence_set w sequence;
404
449
sp w;
405
-
fetch_items w items
406
-
| Command.Uid_store { sequence; silent; action; flags } ->
450
+
fetch_items w items;
451
+
Option.iter (fun modseq ->
452
+
W.string w " (CHANGEDSINCE ";
453
+
number64 w modseq;
454
+
W.char w ')') changedsince
455
+
| Command.Uid_store { sequence; silent; action; flags; unchangedsince } ->
407
456
W.string w "STORE ";
408
457
sequence_set w sequence;
409
458
sp w;
459
+
(match unchangedsince with
460
+
| Some modseq ->
461
+
W.string w "(UNCHANGEDSINCE ";
462
+
number64 w modseq;
463
+
W.string w ") "
464
+
| None -> ());
410
465
store_action w action;
411
466
if silent then W.string w ".SILENT";
412
467
sp w;
···
423
478
astring w mailbox
424
479
| Command.Uid_search { charset; criteria } ->
425
480
write_search w charset criteria
481
+
| Command.Uid_sort { charset; criteria; search } ->
482
+
write_sort w charset criteria search
426
483
| Command.Uid_expunge set ->
427
484
W.string w "EXPUNGE ";
428
485
sequence_set w set)
+29
test/integration/dune
+29
test/integration/dune
···
1
+
; Integration test suite for ocaml-imap
2
+
; Tests against a real IMAP server
3
+
4
+
(library
5
+
(name imaptest_lib)
6
+
(modules imaptest_config imaptest_output imaptest_state imaptest_utils imaptest_scripted imaptest_stress)
7
+
(wrapped false)
8
+
(libraries imap eio eio_main cmdliner fmt))
9
+
10
+
(executable
11
+
(name imaptest_scripted_main)
12
+
(public_name imaptest-scripted)
13
+
(package imap)
14
+
(modules imaptest_scripted_main)
15
+
(libraries imaptest_lib imap eio eio_main tls-eio mirage-crypto-rng.unix))
16
+
17
+
(executable
18
+
(name imaptest_stress_main)
19
+
(public_name imaptest-stress)
20
+
(package imap)
21
+
(modules imaptest_stress_main)
22
+
(libraries imaptest_lib imap eio eio_main tls-eio mirage-crypto-rng.unix))
23
+
24
+
(executable
25
+
(name imaptest)
26
+
(public_name imaptest)
27
+
(package imap)
28
+
(modules imaptest)
29
+
(libraries imaptest_lib imap eio eio_main tls-eio mirage-crypto-rng.unix cmdliner))
+11
test/integration/imaptest.conf.example
+11
test/integration/imaptest.conf.example
···
1
+
# IMAP Integration Test Configuration
2
+
# Copy this file to ~/.imaptest.conf or .imaptest.conf and fill in your values
3
+
#
4
+
# Alternatively, use environment variables:
5
+
# IMAPTEST_HOST - IMAP server hostname
6
+
# IMAPTEST_USER - Username for authentication
7
+
# IMAP_PASSWORD - Password for authentication
8
+
9
+
host=imap.example.com
10
+
username=testuser
11
+
password=your_password_here
+97
test/integration/imaptest.ml
+97
test/integration/imaptest.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Combined IMAP integration test runner
7
+
8
+
Provides subcommands for running scripted tests, stress tests, or both. *)
9
+
10
+
open Cmdliner
11
+
12
+
(** Run scripted tests *)
13
+
let run_scripted config =
14
+
Imaptest_scripted.run_tests ~config
15
+
16
+
(** Run stress tests *)
17
+
let run_stress config =
18
+
Imaptest_stress.run_stress ~config
19
+
20
+
(** Run all tests *)
21
+
let run_all config =
22
+
Imaptest_output.set_color config.Imaptest_config.color;
23
+
Imaptest_output.print_header "IMAP Integration Test Suite";
24
+
25
+
let scripted_ok = run_scripted config in
26
+
let stress_ok = run_stress config in
27
+
28
+
Imaptest_output.print_header "Overall Summary";
29
+
Printf.printf "Scripted tests: %s\n"
30
+
(if scripted_ok then Imaptest_output.green "PASS" else Imaptest_output.red "FAIL");
31
+
Printf.printf "Stress tests: %s\n"
32
+
(if stress_ok then Imaptest_output.green "PASS" else Imaptest_output.red "FAIL");
33
+
34
+
scripted_ok && stress_ok
35
+
36
+
(** Subcommand: scripted *)
37
+
let scripted_cmd =
38
+
let doc = "Run scripted (deterministic) integration tests" in
39
+
let info = Cmd.info "scripted" ~doc in
40
+
Cmd.v info Term.(const run_scripted $ Imaptest_config.config_term)
41
+
42
+
(** Subcommand: stress *)
43
+
let stress_cmd =
44
+
let doc = "Run stress tests with random commands and state tracking" in
45
+
let info = Cmd.info "stress" ~doc in
46
+
Cmd.v info Term.(const run_stress $ Imaptest_config.config_term)
47
+
48
+
(** Subcommand: all *)
49
+
let all_cmd =
50
+
let doc = "Run all integration tests (scripted + stress)" in
51
+
let info = Cmd.info "all" ~doc in
52
+
Cmd.v info Term.(const run_all $ Imaptest_config.config_term)
53
+
54
+
(** Default action (when no subcommand given) *)
55
+
let default_action config =
56
+
run_all config
57
+
58
+
(** Main command group *)
59
+
let main_cmd =
60
+
let doc = "IMAP integration test suite" in
61
+
let man = [
62
+
`S Manpage.s_description;
63
+
`P "Comprehensive integration test suite for the ocaml-imap library.";
64
+
`P "Tests against a real IMAP server to verify protocol compliance and \
65
+
detect race conditions or state violations.";
66
+
`S Manpage.s_commands;
67
+
`P "$(b,scripted) - Run deterministic scripted tests";
68
+
`P "$(b,stress) - Run randomized stress tests with state tracking";
69
+
`P "$(b,all) - Run both scripted and stress tests";
70
+
`S Manpage.s_environment;
71
+
`P "$(b,IMAP_PASSWORD) - Password for authentication (optional, has default)";
72
+
`P "$(b,IMAPTEST_HOST) - Override default host";
73
+
`P "$(b,IMAPTEST_USER) - Override default username";
74
+
`S Manpage.s_examples;
75
+
`P "Run all tests with default settings:";
76
+
`Pre " imaptest all";
77
+
`P "Run only scripted tests:";
78
+
`Pre " imaptest scripted";
79
+
`P "Run stress tests for 120 seconds:";
80
+
`Pre " imaptest stress --duration 120";
81
+
`P "Run with a specific random seed for reproducibility:";
82
+
`Pre " imaptest stress --seed 12345";
83
+
`P "Run with custom server:";
84
+
`Pre " IMAP_PASSWORD=xxx imaptest all --host mail.example.com --user me@example.com";
85
+
] in
86
+
let info = Cmd.info "imaptest" ~version:"0.1.0" ~doc ~man in
87
+
Cmd.group ~default:Term.(const default_action $ Imaptest_config.config_term)
88
+
info [scripted_cmd; stress_cmd; all_cmd]
89
+
90
+
(** Main entry point *)
91
+
let () =
92
+
Mirage_crypto_rng_unix.use_default ();
93
+
let result = Cmd.eval_value main_cmd in
94
+
match result with
95
+
| Ok (`Ok success) -> exit (if success then 0 else 1)
96
+
| Ok `Version | Ok `Help -> exit 0
97
+
| Error _ -> exit 1
+174
test/integration/imaptest_config.ml
+174
test/integration/imaptest_config.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Configuration for IMAP integration tests *)
7
+
8
+
type t = {
9
+
host : string;
10
+
port : int;
11
+
username : string;
12
+
password : string;
13
+
mailbox_prefix : string;
14
+
num_connections : int;
15
+
duration : float;
16
+
seed : int option;
17
+
verbose : bool;
18
+
color : bool;
19
+
}
20
+
21
+
let default = {
22
+
host = "localhost";
23
+
port = 993;
24
+
username = "";
25
+
password = "";
26
+
mailbox_prefix = "imaptest-";
27
+
num_connections = 5;
28
+
duration = 60.0;
29
+
seed = None;
30
+
verbose = false;
31
+
color = true;
32
+
}
33
+
34
+
(** Read config from file (key=value format, one per line) *)
35
+
let read_config_file path =
36
+
if Sys.file_exists path then
37
+
let ic = open_in path in
38
+
let rec read_lines acc =
39
+
match input_line ic with
40
+
| line ->
41
+
let line = String.trim line in
42
+
if String.length line = 0 || line.[0] = '#' then
43
+
read_lines acc
44
+
else begin
45
+
match String.index_opt line '=' with
46
+
| Some i ->
47
+
let key = String.trim (String.sub line 0 i) in
48
+
let value = String.trim (String.sub line (i + 1) (String.length line - i - 1)) in
49
+
read_lines ((key, value) :: acc)
50
+
| None -> read_lines acc
51
+
end
52
+
| exception End_of_file ->
53
+
close_in ic;
54
+
acc
55
+
in
56
+
Some (read_lines [])
57
+
else
58
+
None
59
+
60
+
(** Default config file locations *)
61
+
let config_file_paths = [
62
+
".imaptest.conf";
63
+
Filename.concat (Sys.getenv_opt "HOME" |> Option.value ~default:".") ".imaptest.conf";
64
+
]
65
+
66
+
(** Find and read config from default locations *)
67
+
let read_default_config () =
68
+
List.find_map read_config_file config_file_paths
69
+
70
+
(** Get password from environment *)
71
+
let get_password () =
72
+
Sys.getenv_opt "IMAP_PASSWORD"
73
+
74
+
(** Get host from environment *)
75
+
let get_host () =
76
+
Sys.getenv_opt "IMAPTEST_HOST"
77
+
78
+
(** Get user from environment *)
79
+
let get_user () =
80
+
Sys.getenv_opt "IMAPTEST_USER"
81
+
82
+
(** Cmdliner terms *)
83
+
open Cmdliner
84
+
85
+
let host_term =
86
+
let doc = "IMAP server hostname" in
87
+
let env = Cmd.Env.info "IMAPTEST_HOST" ~doc:"IMAP server hostname" in
88
+
Arg.(value & opt string default.host & info ["host"; "H"] ~env ~docv:"HOST" ~doc)
89
+
90
+
let port_term =
91
+
let doc = "IMAP server port (default: 993 for IMAPS)" in
92
+
Arg.(value & opt int default.port & info ["port"; "p"] ~docv:"PORT" ~doc)
93
+
94
+
let username_term =
95
+
let doc = "Username for authentication" in
96
+
let env = Cmd.Env.info "IMAPTEST_USER" ~doc:"Username for authentication" in
97
+
Arg.(value & opt string default.username & info ["user"; "u"] ~env ~docv:"USER" ~doc)
98
+
99
+
let mailbox_prefix_term =
100
+
let doc = "Prefix for test mailboxes (default: imaptest-)" in
101
+
Arg.(value & opt string default.mailbox_prefix & info ["prefix"] ~docv:"PREFIX" ~doc)
102
+
103
+
let num_connections_term =
104
+
let doc = "Number of concurrent connections for stress tests" in
105
+
Arg.(value & opt int default.num_connections & info ["connections"; "c"] ~docv:"N" ~doc)
106
+
107
+
let duration_term =
108
+
let doc = "Duration of stress tests in seconds" in
109
+
Arg.(value & opt float default.duration & info ["duration"; "d"] ~docv:"SECONDS" ~doc)
110
+
111
+
let seed_term =
112
+
let doc = "Random seed for reproducibility" in
113
+
Arg.(value & opt (some int) None & info ["seed"; "s"] ~docv:"SEED" ~doc)
114
+
115
+
let verbose_term =
116
+
let doc = "Enable verbose output" in
117
+
Arg.(value & flag & info ["verbose"; "v"] ~doc)
118
+
119
+
let no_color_term =
120
+
let doc = "Disable colored output" in
121
+
Arg.(value & flag & info ["no-color"] ~doc)
122
+
123
+
let config_term : t Term.t =
124
+
let make host port username mailbox_prefix num_connections duration seed verbose no_color =
125
+
(* Try to read from config file first *)
126
+
let file_config = read_default_config () in
127
+
let get_file_value key = Option.bind file_config (fun kvs -> List.assoc_opt key kvs) in
128
+
(* Priority: CLI args > env vars > config file > defaults *)
129
+
let final_host =
130
+
if host <> default.host then host
131
+
else match get_host () with
132
+
| Some h -> h
133
+
| None -> get_file_value "host" |> Option.value ~default:host
134
+
in
135
+
let final_username =
136
+
if username <> default.username then username
137
+
else match get_user () with
138
+
| Some u -> u
139
+
| None -> get_file_value "username" |> Option.value ~default:username
140
+
in
141
+
let final_password =
142
+
match get_password () with
143
+
| Some p -> p
144
+
| None -> get_file_value "password" |> Option.value ~default:""
145
+
in
146
+
if final_password = "" then begin
147
+
Printf.eprintf "Error: No password provided.\n";
148
+
Printf.eprintf "Set IMAP_PASSWORD environment variable or create ~/.imaptest.conf with:\n";
149
+
Printf.eprintf " host=your.imap.server\n";
150
+
Printf.eprintf " username=your_username\n";
151
+
Printf.eprintf " password=your_password\n";
152
+
exit 1
153
+
end;
154
+
{
155
+
host = final_host;
156
+
port;
157
+
username = final_username;
158
+
password = final_password;
159
+
mailbox_prefix;
160
+
num_connections;
161
+
duration;
162
+
seed;
163
+
verbose;
164
+
color = not no_color;
165
+
}
166
+
in
167
+
Term.(const make $ host_term $ port_term $ username_term $ mailbox_prefix_term
168
+
$ num_connections_term $ duration_term $ seed_term $ verbose_term $ no_color_term)
169
+
170
+
let pp fmt t =
171
+
Format.fprintf fmt "@[<v>Host: %s:%d@,User: %s@,Prefix: %s@,Connections: %d@,Duration: %.1fs@,Seed: %s@,Verbose: %b@,Color: %b@]"
172
+
t.host t.port t.username t.mailbox_prefix t.num_connections t.duration
173
+
(match t.seed with Some s -> string_of_int s | None -> "random")
174
+
t.verbose t.color
+125
test/integration/imaptest_output.ml
+125
test/integration/imaptest_output.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Colored terminal output for test results *)
7
+
8
+
(** ANSI color codes *)
9
+
module Color = struct
10
+
let reset = "\027[0m"
11
+
let red = "\027[31m"
12
+
let green = "\027[32m"
13
+
let yellow = "\027[33m"
14
+
let cyan = "\027[36m"
15
+
let bold = "\027[1m"
16
+
let dim = "\027[2m"
17
+
end
18
+
19
+
let use_color = ref true
20
+
21
+
let set_color enabled = use_color := enabled
22
+
23
+
let color c s =
24
+
if !use_color then c ^ s ^ Color.reset else s
25
+
26
+
let red s = color Color.red s
27
+
let green s = color Color.green s
28
+
let yellow s = color Color.yellow s
29
+
let cyan s = color Color.cyan s
30
+
let bold s = color Color.bold s
31
+
let dim s = color Color.dim s
32
+
33
+
(** Print a section header *)
34
+
let print_header name =
35
+
Printf.printf "\n%s %s %s\n" (cyan "===") (bold name) (cyan "===");
36
+
flush stdout
37
+
38
+
(** Print a subsection header *)
39
+
let print_subheader name =
40
+
Printf.printf "\n%s %s\n" (cyan "---") name;
41
+
flush stdout
42
+
43
+
(** Print a test result *)
44
+
let print_test_result ~name ~passed ~duration =
45
+
let status = if passed then green "PASS" else red "FAIL" in
46
+
let time_str = if duration >= 0.001 then
47
+
Printf.sprintf "%s(%.3fs)%s" (if !use_color then Color.dim else "") duration (if !use_color then Color.reset else "")
48
+
else
49
+
""
50
+
in
51
+
Printf.printf " [%s] %s %s\n" status name time_str;
52
+
flush stdout
53
+
54
+
(** Print a skipped test *)
55
+
let print_test_skipped ~name ~reason =
56
+
Printf.printf " [%s] %s %s\n" (yellow "SKIP") name (dim reason);
57
+
flush stdout
58
+
59
+
(** Print test summary *)
60
+
let print_summary ~passed ~failed ~skipped =
61
+
Printf.printf "\n%s\n" (bold "Summary:");
62
+
Printf.printf " %s: %d\n" (green "Passed") passed;
63
+
Printf.printf " %s: %d\n" (red "Failed") failed;
64
+
if skipped > 0 then
65
+
Printf.printf " %s: %d\n" (yellow "Skipped") skipped;
66
+
let total = passed + failed + skipped in
67
+
Printf.printf " %s: %d\n" (bold "Total") total;
68
+
flush stdout
69
+
70
+
(** Print stress test statistics *)
71
+
let print_stress_stats ~commands ~errors ~violations ~duration =
72
+
Printf.printf "\n%s\n" (bold "Stress Test Statistics:");
73
+
Printf.printf " Commands executed: %d\n" commands;
74
+
Printf.printf " Errors: %s\n" (if errors > 0 then red (string_of_int errors) else green "0");
75
+
Printf.printf " State violations: %s\n" (if violations > 0 then red (string_of_int violations) else green "0");
76
+
Printf.printf " Duration: %.2fs\n" duration;
77
+
Printf.printf " Rate: %.1f cmd/s\n" (float_of_int commands /. duration);
78
+
flush stdout
79
+
80
+
(** Print an error message *)
81
+
let print_error msg =
82
+
Printf.eprintf "%s: %s\n" (red "Error") msg;
83
+
flush stderr
84
+
85
+
(** Print a warning message *)
86
+
let print_warning msg =
87
+
Printf.printf "%s: %s\n" (yellow "Warning") msg;
88
+
flush stdout
89
+
90
+
(** Print an info message (verbose only) *)
91
+
let print_verbose ~verbose msg =
92
+
if verbose then begin
93
+
Printf.printf "%s: %s\n" (dim "Info") msg;
94
+
flush stdout
95
+
end
96
+
97
+
(** Print progress indicator *)
98
+
let print_progress current total =
99
+
Printf.printf "\r Progress: %d/%d" current total;
100
+
flush stdout
101
+
102
+
(** Clear progress line *)
103
+
let clear_progress () =
104
+
Printf.printf "\r \r";
105
+
flush stdout
106
+
107
+
(** Print a violation *)
108
+
let print_violation msg =
109
+
Printf.printf " %s %s\n" (red "[VIOLATION]") msg;
110
+
flush stdout
111
+
112
+
(** Print configuration *)
113
+
let print_config (config : Imaptest_config.t) =
114
+
Printf.printf "%s\n" (bold "Configuration:");
115
+
Printf.printf " Host: %s:%d\n" config.host config.port;
116
+
Printf.printf " User: %s\n" config.username;
117
+
Printf.printf " Mailbox prefix: %s\n" config.mailbox_prefix;
118
+
if config.num_connections > 1 then
119
+
Printf.printf " Connections: %d\n" config.num_connections;
120
+
if config.duration > 0.0 then
121
+
Printf.printf " Duration: %.1fs\n" config.duration;
122
+
(match config.seed with
123
+
| Some s -> Printf.printf " Seed: %d\n" s
124
+
| None -> ());
125
+
flush stdout
+1600
test/integration/imaptest_scripted.ml
+1600
test/integration/imaptest_scripted.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Scripted integration tests for IMAP client
7
+
8
+
Deterministic tests that verify correct behavior of the IMAP client
9
+
against a real server. *)
10
+
11
+
open Imaptest_utils
12
+
13
+
(** Test definitions *)
14
+
15
+
(* ========== Connection Tests ========== *)
16
+
17
+
let test_connect_tls ~sw ~env ~config () =
18
+
let client = connect ~sw ~env ~config in
19
+
assert_true "client should be created" true;
20
+
Imap.Client.disconnect client
21
+
22
+
let test_login_valid ~sw ~env ~config () =
23
+
let client = connect ~sw ~env ~config in
24
+
Imap.Client.login client ~username:config.username ~password:config.password;
25
+
(match Imap.Client.state client with
26
+
| Imap.Client.Authenticated _ -> ()
27
+
| _ -> raise (Failure "Expected authenticated state"));
28
+
Imap.Client.logout client;
29
+
Imap.Client.disconnect client
30
+
31
+
let test_login_invalid ~sw ~env ~config () =
32
+
let client = connect ~sw ~env ~config in
33
+
let raised = ref false in
34
+
(try
35
+
Imap.Client.login client ~username:config.username ~password:"wrong_password"
36
+
with _ ->
37
+
raised := true);
38
+
assert_true "login with wrong password should fail" !raised;
39
+
Imap.Client.disconnect client
40
+
41
+
let test_capability ~sw ~env ~config () =
42
+
let client = connect_and_login ~sw ~env ~config in
43
+
let caps = Imap.Client.capability client in
44
+
assert_non_empty ~msg:"capabilities" caps;
45
+
assert_true "should have IMAP4rev1 or IMAP4rev2"
46
+
(List.exists (fun c -> c = "IMAP4rev1" || c = "IMAP4rev2") caps);
47
+
Imap.Client.logout client;
48
+
Imap.Client.disconnect client
49
+
50
+
let test_logout ~sw ~env ~config () =
51
+
let client = connect_and_login ~sw ~env ~config in
52
+
Imap.Client.logout client;
53
+
(match Imap.Client.state client with
54
+
| Imap.Client.Logout -> ()
55
+
| _ -> raise (Failure "Expected logout state"));
56
+
Imap.Client.disconnect client
57
+
58
+
(* ========== Mailbox Tests ========== *)
59
+
60
+
let test_create_delete_mailbox ~sw ~env ~config () =
61
+
with_test_setup ~sw ~env ~config (fun client ->
62
+
let name = make_test_mailbox_name ~config ~suffix:"create" in
63
+
Imap.Client.create client name;
64
+
(* Verify it exists *)
65
+
let mailboxes = Imap.Client.list client ~reference:"" ~pattern:name in
66
+
assert_true "mailbox should exist after create" (List.length mailboxes = 1);
67
+
(* Delete it *)
68
+
Imap.Client.delete client name;
69
+
(* Verify it's gone *)
70
+
let mailboxes = Imap.Client.list client ~reference:"" ~pattern:name in
71
+
assert_true "mailbox should not exist after delete" (List.length mailboxes = 0))
72
+
73
+
let test_select_inbox ~sw ~env ~config () =
74
+
with_test_setup ~sw ~env ~config (fun client ->
75
+
let info = Imap.Client.select client "INBOX" in
76
+
assert_true "exists >= 0" (info.exists >= 0);
77
+
assert_true "uidvalidity > 0" (info.uidvalidity > 0L);
78
+
assert_true "uidnext > 0" (info.uidnext > 0L);
79
+
assert_true "should not be readonly" (not info.readonly))
80
+
81
+
let test_examine_readonly ~sw ~env ~config () =
82
+
with_test_setup ~sw ~env ~config (fun client ->
83
+
let info = Imap.Client.examine client "INBOX" in
84
+
assert_true "should be readonly" info.readonly)
85
+
86
+
let test_list_mailboxes ~sw ~env ~config () =
87
+
with_test_setup ~sw ~env ~config (fun client ->
88
+
let mailboxes = Imap.Client.list client ~reference:"" ~pattern:"*" in
89
+
assert_non_empty ~msg:"mailbox list" mailboxes;
90
+
(* INBOX should always exist *)
91
+
let has_inbox = List.exists (fun (e : Imap.Client.list_entry) ->
92
+
String.uppercase_ascii e.name = "INBOX"
93
+
) mailboxes in
94
+
assert_true "INBOX should be in list" has_inbox)
95
+
96
+
let test_status_query ~sw ~env ~config () =
97
+
with_test_setup ~sw ~env ~config (fun client ->
98
+
let status = Imap.Client.status client "INBOX"
99
+
[Imap.Status.Messages; Imap.Status.Uidnext; Imap.Status.Uidvalidity; Imap.Status.Unseen] in
100
+
assert_true "messages should be Some" (Option.is_some status.messages);
101
+
assert_true "uidnext should be Some" (Option.is_some status.uidnext);
102
+
assert_true "uidvalidity should be Some" (Option.is_some status.uidvalidity))
103
+
104
+
let test_subscribe_unsubscribe ~sw ~env ~config () =
105
+
with_test_mailbox ~sw ~env ~config ~suffix:"sub" (fun client mailbox ->
106
+
Imap.Client.subscribe client mailbox;
107
+
Imap.Client.unsubscribe client mailbox)
108
+
109
+
let test_rename_mailbox ~sw ~env ~config () =
110
+
with_test_setup ~sw ~env ~config (fun client ->
111
+
let old_name = make_test_mailbox_name ~config ~suffix:"rename-old" in
112
+
let new_name = make_test_mailbox_name ~config ~suffix:"rename-new" in
113
+
Imap.Client.create client old_name;
114
+
Fun.protect
115
+
~finally:(fun () ->
116
+
delete_mailbox_safe client old_name;
117
+
delete_mailbox_safe client new_name)
118
+
(fun () ->
119
+
Imap.Client.rename client ~old_name ~new_name;
120
+
(* Verify old name is gone *)
121
+
let old_list = Imap.Client.list client ~reference:"" ~pattern:old_name in
122
+
assert_true "old name should not exist" (List.length old_list = 0);
123
+
(* Verify new name exists *)
124
+
let new_list = Imap.Client.list client ~reference:"" ~pattern:new_name in
125
+
assert_true "new name should exist" (List.length new_list = 1)))
126
+
127
+
(* ========== Message Tests ========== *)
128
+
129
+
let test_append_message ~sw ~env ~config () =
130
+
with_test_mailbox ~sw ~env ~config ~suffix:"append" (fun client mailbox ->
131
+
let _ = Imap.Client.select client mailbox in
132
+
let uid_opt = Imap.Client.append client ~mailbox ~message:test_message
133
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
134
+
(* APPENDUID might not be supported, so uid_opt may be None *)
135
+
ignore uid_opt;
136
+
(* Verify message exists *)
137
+
let info = Imap.Client.select client mailbox in
138
+
assert_true "mailbox should have 1 message" (info.exists = 1))
139
+
140
+
let test_fetch_envelope ~sw ~env ~config () =
141
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-env" (fun client mailbox ->
142
+
let _ = Imap.Client.select client mailbox in
143
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
144
+
let _ = Imap.Client.select client mailbox in
145
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Envelope] () in
146
+
assert_length ~msg:"fetch results" 1 msgs;
147
+
let msg = List.hd msgs in
148
+
assert_true "envelope should be present" (Option.is_some msg.envelope);
149
+
let env = Option.get msg.envelope in
150
+
assert_true "subject should be Some" (Option.is_some env.subject))
151
+
152
+
let test_fetch_flags ~sw ~env ~config () =
153
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-flags" (fun client mailbox ->
154
+
let _ = Imap.Client.select client mailbox in
155
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
156
+
~flags:[Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Flagged] () in
157
+
let _ = Imap.Client.select client mailbox in
158
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
159
+
assert_length ~msg:"fetch results" 1 msgs;
160
+
let msg = List.hd msgs in
161
+
assert_true "flags should be present" (Option.is_some msg.flags);
162
+
let flags = Option.get msg.flags in
163
+
assert_true "\\Seen should be present"
164
+
(List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Seen) flags))
165
+
166
+
let test_fetch_body ~sw ~env ~config () =
167
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-body" (fun client mailbox ->
168
+
let _ = Imap.Client.select client mailbox in
169
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
170
+
let _ = Imap.Client.select client mailbox in
171
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
172
+
~items:[Imap.Fetch.Body_peek ("", None)] () in
173
+
assert_length ~msg:"fetch results" 1 msgs;
174
+
let msg = List.hd msgs in
175
+
assert_true "body should be present" (Option.is_some msg.body_section))
176
+
177
+
let test_fetch_bodystructure ~sw ~env ~config () =
178
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-struct" (fun client mailbox ->
179
+
let _ = Imap.Client.select client mailbox in
180
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
181
+
let _ = Imap.Client.select client mailbox in
182
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
183
+
~items:[Imap.Fetch.Bodystructure] () in
184
+
assert_length ~msg:"fetch results" 1 msgs;
185
+
let msg = List.hd msgs in
186
+
assert_true "bodystructure should be present" (Option.is_some msg.body_structure))
187
+
188
+
let test_uid_fetch ~sw ~env ~config () =
189
+
with_test_mailbox ~sw ~env ~config ~suffix:"uid-fetch" (fun client mailbox ->
190
+
let _ = Imap.Client.select client mailbox in
191
+
let uid_opt = Imap.Client.append client ~mailbox ~message:test_message () in
192
+
let _ = Imap.Client.select client mailbox in
193
+
(* First get the UID using regular fetch *)
194
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Uid] () in
195
+
let uid = match msgs with
196
+
| [msg] -> (match msg.uid, uid_opt with
197
+
| Some u, _ -> u
198
+
| None, Some u -> u
199
+
| None, None -> raise (Failure "Could not determine UID"))
200
+
| _ -> raise (Failure "Expected exactly 1 message")
201
+
in
202
+
(* Now UID FETCH *)
203
+
let msgs = Imap.Client.uid_fetch client
204
+
~sequence:(Imap.Seq.single (Int64.to_int uid))
205
+
~items:[Imap.Fetch.Flags; Imap.Fetch.Envelope] () in
206
+
assert_length ~msg:"uid fetch results" 1 msgs)
207
+
208
+
let test_store_add_flag ~sw ~env ~config () =
209
+
with_test_mailbox ~sw ~env ~config ~suffix:"store-add" (fun client mailbox ->
210
+
let _ = Imap.Client.select client mailbox in
211
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
212
+
let _ = Imap.Client.select client mailbox in
213
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
214
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Flagged] () in
215
+
(* Verify flag was added *)
216
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
217
+
let msg = List.hd msgs in
218
+
let flags = Option.get msg.flags in
219
+
assert_true "\\Flagged should be present"
220
+
(List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Flagged) flags))
221
+
222
+
let test_store_remove_flag ~sw ~env ~config () =
223
+
with_test_mailbox ~sw ~env ~config ~suffix:"store-rm" (fun client mailbox ->
224
+
let _ = Imap.Client.select client mailbox in
225
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
226
+
~flags:[Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Flagged] () in
227
+
let _ = Imap.Client.select client mailbox in
228
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
229
+
~action:Imap.Store.Remove ~flags:[Imap.Flag.System Imap.Flag.Flagged] () in
230
+
(* Verify flag was removed *)
231
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
232
+
let msg = List.hd msgs in
233
+
let flags = Option.get msg.flags in
234
+
assert_true "\\Flagged should not be present"
235
+
(not (List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Flagged) flags)))
236
+
237
+
let test_store_set_flags ~sw ~env ~config () =
238
+
with_test_mailbox ~sw ~env ~config ~suffix:"store-set" (fun client mailbox ->
239
+
let _ = Imap.Client.select client mailbox in
240
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
241
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
242
+
let _ = Imap.Client.select client mailbox in
243
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
244
+
~action:Imap.Store.Set ~flags:[Imap.Flag.System Imap.Flag.Draft] () in
245
+
(* Verify flags were replaced *)
246
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
247
+
let msg = List.hd msgs in
248
+
let flags = Option.get msg.flags in
249
+
assert_true "\\Seen should not be present (replaced)"
250
+
(not (List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Seen) flags));
251
+
assert_true "\\Draft should be present"
252
+
(List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Draft) flags))
253
+
254
+
let test_uid_store ~sw ~env ~config () =
255
+
with_test_mailbox ~sw ~env ~config ~suffix:"uid-store" (fun client mailbox ->
256
+
let _ = Imap.Client.select client mailbox in
257
+
let uid_opt = Imap.Client.append client ~mailbox ~message:test_message () in
258
+
let _ = Imap.Client.select client mailbox in
259
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Uid] () in
260
+
let uid = match msgs with
261
+
| [msg] -> (match msg.uid, uid_opt with
262
+
| Some u, _ -> u
263
+
| None, Some u -> u
264
+
| None, None -> raise (Failure "Could not determine UID"))
265
+
| _ -> raise (Failure "Expected exactly 1 message")
266
+
in
267
+
let _ = Imap.Client.uid_store client ~sequence:(Imap.Seq.single (Int64.to_int uid))
268
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Answered] () in
269
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
270
+
let msg = List.hd msgs in
271
+
let flags = Option.get msg.flags in
272
+
assert_true "\\Answered should be present"
273
+
(List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Answered) flags))
274
+
275
+
let test_copy_message ~sw ~env ~config () =
276
+
with_test_setup ~sw ~env ~config (fun client ->
277
+
let src = create_test_mailbox client ~config ~suffix:"copy-src" in
278
+
let dst = create_test_mailbox client ~config ~suffix:"copy-dst" in
279
+
Fun.protect
280
+
~finally:(fun () ->
281
+
delete_mailbox_safe client src;
282
+
delete_mailbox_safe client dst)
283
+
(fun () ->
284
+
let _ = Imap.Client.select client src in
285
+
let _ = Imap.Client.append client ~mailbox:src ~message:test_message () in
286
+
let _ = Imap.Client.select client src in
287
+
Imap.Client.copy client ~sequence:(Imap.Seq.single 1) ~mailbox:dst;
288
+
(* Verify message exists in both *)
289
+
let src_info = Imap.Client.select client src in
290
+
let dst_info = Imap.Client.select client dst in
291
+
assert_true "source should still have message" (src_info.exists = 1);
292
+
assert_true "destination should have message" (dst_info.exists = 1)))
293
+
294
+
let test_move_message ~sw ~env ~config () =
295
+
with_test_setup ~sw ~env ~config (fun client ->
296
+
if not (has_capability client "MOVE") then
297
+
raise (Failure "SKIP: Server does not support MOVE");
298
+
let src = create_test_mailbox client ~config ~suffix:"move-src" in
299
+
let dst = create_test_mailbox client ~config ~suffix:"move-dst" in
300
+
Fun.protect
301
+
~finally:(fun () ->
302
+
delete_mailbox_safe client src;
303
+
delete_mailbox_safe client dst)
304
+
(fun () ->
305
+
let _ = Imap.Client.select client src in
306
+
let _ = Imap.Client.append client ~mailbox:src ~message:test_message () in
307
+
let _ = Imap.Client.select client src in
308
+
Imap.Client.move client ~sequence:(Imap.Seq.single 1) ~mailbox:dst;
309
+
(* Verify message moved *)
310
+
let src_info = Imap.Client.select client src in
311
+
let dst_info = Imap.Client.select client dst in
312
+
assert_true "source should be empty" (src_info.exists = 0);
313
+
assert_true "destination should have message" (dst_info.exists = 1)))
314
+
315
+
let test_expunge ~sw ~env ~config () =
316
+
with_test_mailbox ~sw ~env ~config ~suffix:"expunge" (fun client mailbox ->
317
+
let _ = Imap.Client.select client mailbox in
318
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
319
+
let _ = Imap.Client.select client mailbox in
320
+
(* Mark as deleted *)
321
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
322
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Deleted] () in
323
+
(* Expunge *)
324
+
let expunged = Imap.Client.expunge client in
325
+
assert_true "should expunge 1 message" (List.length expunged = 1);
326
+
(* Verify empty *)
327
+
let info = Imap.Client.select client mailbox in
328
+
assert_true "mailbox should be empty" (info.exists = 0))
329
+
330
+
let test_uid_expunge ~sw ~env ~config () =
331
+
with_test_mailbox ~sw ~env ~config ~suffix:"uid-expunge" (fun client mailbox ->
332
+
if not (has_capability client "UIDPLUS") then
333
+
raise (Failure "SKIP: Server does not support UIDPLUS");
334
+
let _ = Imap.Client.select client mailbox in
335
+
(* Append two messages *)
336
+
let uid1_opt = Imap.Client.append client ~mailbox ~message:test_message () in
337
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
338
+
let _ = Imap.Client.select client mailbox in
339
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Uid] () in
340
+
let uid1 = match msgs with
341
+
| [msg] -> (match msg.uid, uid1_opt with
342
+
| Some u, _ -> u
343
+
| None, Some u -> u
344
+
| None, None -> raise (Failure "Could not determine UID"))
345
+
| _ -> raise (Failure "Expected exactly 1 message")
346
+
in
347
+
(* Mark first as deleted *)
348
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
349
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Deleted] () in
350
+
(* UID EXPUNGE only the first *)
351
+
let _ = Imap.Client.uid_expunge client (Imap.Seq.single (Int64.to_int uid1)) in
352
+
(* Verify only one message remains *)
353
+
let info = Imap.Client.select client mailbox in
354
+
assert_true "should have 1 message remaining" (info.exists = 1))
355
+
356
+
let test_search_all ~sw ~env ~config () =
357
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-all" (fun client mailbox ->
358
+
let _ = Imap.Client.select client mailbox in
359
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
360
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
361
+
let _ = Imap.Client.select client mailbox in
362
+
let results = Imap.Client.search client Imap.Search.All in
363
+
assert_length ~msg:"search ALL results" 2 results)
364
+
365
+
let test_search_unseen ~sw ~env ~config () =
366
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-unseen" (fun client mailbox ->
367
+
let _ = Imap.Client.select client mailbox in
368
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
369
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
370
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
371
+
let _ = Imap.Client.select client mailbox in
372
+
let results = Imap.Client.search client Imap.Search.Unseen in
373
+
assert_length ~msg:"search UNSEEN results" 1 results)
374
+
375
+
let test_search_subject ~sw ~env ~config () =
376
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-subj" (fun client mailbox ->
377
+
let _ = Imap.Client.select client mailbox in
378
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
379
+
let msg2 = make_test_message ~id:"unique123" ~subject:"Unique Subject 123" in
380
+
let _ = Imap.Client.append client ~mailbox ~message:msg2 () in
381
+
let _ = Imap.Client.select client mailbox in
382
+
let results = Imap.Client.search client (Imap.Search.Subject "Unique Subject 123") in
383
+
assert_length ~msg:"search SUBJECT results" 1 results)
384
+
385
+
let test_uid_search ~sw ~env ~config () =
386
+
with_test_mailbox ~sw ~env ~config ~suffix:"uid-search" (fun client mailbox ->
387
+
let _ = Imap.Client.select client mailbox in
388
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
389
+
let _ = Imap.Client.select client mailbox in
390
+
let results = Imap.Client.uid_search client Imap.Search.All in
391
+
assert_length ~msg:"UID SEARCH results" 1 results;
392
+
assert_true "UID should be > 0" (List.hd results > 0L))
393
+
394
+
(* ========== IDLE Tests ========== *)
395
+
396
+
let test_idle_timeout ~sw ~env ~config () =
397
+
with_test_setup ~sw ~env ~config (fun client ->
398
+
if not (has_capability client "IDLE") then
399
+
raise (Failure "SKIP: Server does not support IDLE");
400
+
let _ = Imap.Client.select client "INBOX" in
401
+
let clock = Eio.Stdenv.clock env in
402
+
let events = Imap.Client.idle client ~clock ~timeout:1.0 in
403
+
(* Timeout with no events is OK *)
404
+
ignore events)
405
+
406
+
let test_idle_exists ~sw ~env ~config () =
407
+
with_test_setup ~sw ~env ~config (fun client ->
408
+
if not (has_capability client "IDLE") then
409
+
raise (Failure "SKIP: Server does not support IDLE");
410
+
let mailbox = create_test_mailbox client ~config ~suffix:"idle" in
411
+
Fun.protect
412
+
~finally:(fun () -> delete_mailbox_safe client mailbox)
413
+
(fun () ->
414
+
let _ = Imap.Client.select client mailbox in
415
+
let clock = Eio.Stdenv.clock env in
416
+
(* Start IDLE in one fiber, append in another *)
417
+
let got_exists = ref false in
418
+
Eio.Fiber.both
419
+
(fun () ->
420
+
let events = Imap.Client.idle client ~clock ~timeout:5.0 in
421
+
List.iter (function
422
+
| Imap.Client.Idle_exists _ -> got_exists := true
423
+
| _ -> ()
424
+
) events)
425
+
(fun () ->
426
+
(* Give IDLE time to start *)
427
+
Eio.Time.sleep clock 0.5;
428
+
(* Use a second connection to append *)
429
+
let client2 = connect_and_login ~sw ~env ~config in
430
+
let _ = Imap.Client.append client2 ~mailbox ~message:test_message () in
431
+
Imap.Client.logout client2;
432
+
Imap.Client.disconnect client2);
433
+
(* We might not always catch it due to timing *)
434
+
ignore !got_exists))
435
+
436
+
(* ========== Flag Tests (RFC 9051 Section 2.3.2) ========== *)
437
+
438
+
let test_all_system_flags ~sw ~env ~config () =
439
+
with_test_mailbox ~sw ~env ~config ~suffix:"flags" (fun client mailbox ->
440
+
let _ = Imap.Client.select client mailbox in
441
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
442
+
let _ = Imap.Client.select client mailbox in
443
+
(* Test all system flags *)
444
+
let all_flags = [
445
+
Imap.Flag.System Imap.Flag.Seen;
446
+
Imap.Flag.System Imap.Flag.Answered;
447
+
Imap.Flag.System Imap.Flag.Flagged;
448
+
Imap.Flag.System Imap.Flag.Deleted;
449
+
Imap.Flag.System Imap.Flag.Draft;
450
+
] in
451
+
(* Set all flags *)
452
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
453
+
~action:Imap.Store.Set ~flags:all_flags () in
454
+
(* Verify all flags are set *)
455
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
456
+
let msg = List.hd msgs in
457
+
let flags = Option.get msg.flags in
458
+
List.iter (fun expected ->
459
+
assert_true (Printf.sprintf "flag %s should be set" (Imap.Flag.to_string expected))
460
+
(List.mem expected flags)
461
+
) all_flags)
462
+
463
+
let test_keyword_flags ~sw ~env ~config () =
464
+
with_test_mailbox ~sw ~env ~config ~suffix:"kw-flags" (fun client mailbox ->
465
+
let info = Imap.Client.select client mailbox in
466
+
(* Check if server allows keyword flags via PERMANENTFLAGS *)
467
+
let allows_keywords = List.exists (function
468
+
| Imap.Flag.Keyword "\\*" -> true
469
+
| _ -> false
470
+
) info.permanent_flags in
471
+
if not allows_keywords then begin
472
+
(* Debug: print what permanent flags we actually have *)
473
+
let flag_strs = List.map (fun f -> Format.asprintf "%a" Imap.Flag.pp f) info.permanent_flags in
474
+
raise (Failure (Printf.sprintf "SKIP: Server does not allow keyword flags (permanent_flags: %s)"
475
+
(String.concat ", " flag_strs)))
476
+
end;
477
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
478
+
let _ = Imap.Client.select client mailbox in
479
+
(* Add custom keyword flag *)
480
+
(* Use the typesafe keyword constructor *)
481
+
let keyword = Imap.Flag.keyword "$MyCustomFlag" in
482
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
483
+
~action:Imap.Store.Add ~flags:[keyword] () in
484
+
(* Verify keyword is set *)
485
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
486
+
let msg = List.hd msgs in
487
+
let flags = Option.get msg.flags in
488
+
(* Debug: print what flags we got back *)
489
+
if not (List.mem keyword flags) then begin
490
+
let flag_strs = List.map (fun f -> Format.asprintf "%a" Imap.Flag.pp f) flags in
491
+
raise (Failure (Printf.sprintf "keyword flag not set (got: %s)" (String.concat ", " flag_strs)))
492
+
end)
493
+
494
+
let test_flag_persistence ~sw ~env ~config () =
495
+
(* Test that flags persist across sessions *)
496
+
let mailbox_name = make_test_mailbox_name ~config ~suffix:"persist" in
497
+
(* First session: create mailbox and set flags *)
498
+
with_test_setup ~sw ~env ~config (fun client ->
499
+
Imap.Client.create client mailbox_name;
500
+
let _ = Imap.Client.select client mailbox_name in
501
+
let _ = Imap.Client.append client ~mailbox:mailbox_name ~message:test_message
502
+
~flags:[Imap.Flag.System Imap.Flag.Flagged] () in
503
+
());
504
+
(* Second session: verify flags are still there *)
505
+
with_test_setup ~sw ~env ~config (fun client ->
506
+
Fun.protect
507
+
~finally:(fun () -> delete_mailbox_safe client mailbox_name)
508
+
(fun () ->
509
+
let _ = Imap.Client.select client mailbox_name in
510
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1) ~items:[Imap.Fetch.Flags] () in
511
+
let msg = List.hd msgs in
512
+
let flags = Option.get msg.flags in
513
+
assert_true "\\Flagged should persist across sessions"
514
+
(List.mem (Imap.Flag.System Imap.Flag.Flagged) flags)))
515
+
516
+
(* ========== Advanced Search Tests (RFC 9051 Section 6.4.4) ========== *)
517
+
518
+
let test_search_from ~sw ~env ~config () =
519
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-from" (fun client mailbox ->
520
+
let _ = Imap.Client.select client mailbox in
521
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
522
+
let _ = Imap.Client.select client mailbox in
523
+
let results = Imap.Client.search client (Imap.Search.From "test@example.com") in
524
+
assert_length ~msg:"search FROM results" 1 results)
525
+
526
+
let test_search_to ~sw ~env ~config () =
527
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-to" (fun client mailbox ->
528
+
let _ = Imap.Client.select client mailbox in
529
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
530
+
let _ = Imap.Client.select client mailbox in
531
+
let results = Imap.Client.search client (Imap.Search.To "recipient@example.com") in
532
+
assert_length ~msg:"search TO results" 1 results)
533
+
534
+
let test_search_flagged ~sw ~env ~config () =
535
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-flag" (fun client mailbox ->
536
+
let _ = Imap.Client.select client mailbox in
537
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
538
+
~flags:[Imap.Flag.System Imap.Flag.Flagged] () in
539
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
540
+
let _ = Imap.Client.select client mailbox in
541
+
let results = Imap.Client.search client Imap.Search.Flagged in
542
+
assert_length ~msg:"search FLAGGED results" 1 results)
543
+
544
+
let test_search_deleted ~sw ~env ~config () =
545
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-del" (fun client mailbox ->
546
+
let _ = Imap.Client.select client mailbox in
547
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
548
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
549
+
let _ = Imap.Client.select client mailbox in
550
+
(* Mark first message as deleted *)
551
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 1)
552
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Deleted] () in
553
+
let results = Imap.Client.search client Imap.Search.Deleted in
554
+
assert_length ~msg:"search DELETED results" 1 results;
555
+
let undeleted = Imap.Client.search client Imap.Search.Undeleted in
556
+
assert_length ~msg:"search UNDELETED results" 1 undeleted)
557
+
558
+
let test_search_not ~sw ~env ~config () =
559
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-not" (fun client mailbox ->
560
+
let _ = Imap.Client.select client mailbox in
561
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
562
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
563
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
564
+
let _ = Imap.Client.select client mailbox in
565
+
(* NOT SEEN should return the unseen message *)
566
+
let results = Imap.Client.search client (Imap.Search.Not Imap.Search.Seen) in
567
+
assert_length ~msg:"search NOT SEEN results" 1 results)
568
+
569
+
let test_search_or ~sw ~env ~config () =
570
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-or" (fun client mailbox ->
571
+
let _ = Imap.Client.select client mailbox in
572
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
573
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
574
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
575
+
~flags:[Imap.Flag.System Imap.Flag.Flagged] () in
576
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
577
+
let _ = Imap.Client.select client mailbox in
578
+
(* OR SEEN FLAGGED should return 2 messages *)
579
+
let results = Imap.Client.search client
580
+
(Imap.Search.Or (Imap.Search.Seen, Imap.Search.Flagged)) in
581
+
assert_length ~msg:"search OR results" 2 results)
582
+
583
+
let test_search_and ~sw ~env ~config () =
584
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-and" (fun client mailbox ->
585
+
let _ = Imap.Client.select client mailbox in
586
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
587
+
~flags:[Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Flagged] () in
588
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
589
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
590
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
591
+
let _ = Imap.Client.select client mailbox in
592
+
(* AND [SEEN; FLAGGED] should return 1 message *)
593
+
let results = Imap.Client.search client
594
+
(Imap.Search.And [Imap.Search.Seen; Imap.Search.Flagged]) in
595
+
assert_length ~msg:"search AND results" 1 results)
596
+
597
+
let test_search_larger ~sw ~env ~config () =
598
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-size" (fun client mailbox ->
599
+
let _ = Imap.Client.select client mailbox in
600
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
601
+
let _ = Imap.Client.select client mailbox in
602
+
(* Message should be larger than 10 bytes *)
603
+
let larger = Imap.Client.search client (Imap.Search.Larger 10L) in
604
+
assert_length ~msg:"search LARGER 10" 1 larger;
605
+
(* Message should be smaller than 1MB *)
606
+
let smaller = Imap.Client.search client (Imap.Search.Smaller 1000000L) in
607
+
assert_length ~msg:"search SMALLER 1000000" 1 smaller)
608
+
609
+
let test_search_header ~sw ~env ~config () =
610
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-hdr" (fun client mailbox ->
611
+
let _ = Imap.Client.select client mailbox in
612
+
let msg = make_test_message ~id:"hdrtest" ~subject:"Header Test Subject" in
613
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in
614
+
let _ = Imap.Client.select client mailbox in
615
+
(* Some servers don't support searching arbitrary headers *)
616
+
try
617
+
let results = Imap.Client.search client (Imap.Search.Header ("X-Test-ID", "hdrtest")) in
618
+
assert_length ~msg:"search HEADER results" 1 results
619
+
with
620
+
| Eio.Exn.Io _ as exn ->
621
+
(match Imap.Error.of_eio_exn exn with
622
+
| Some (Imap.Error.Protocol_error { text; _ }) when String.length text > 0 ->
623
+
raise (Failure ("SKIP: " ^ text))
624
+
| _ -> raise exn))
625
+
626
+
let test_search_text ~sw ~env ~config () =
627
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-text" (fun client mailbox ->
628
+
let _ = Imap.Client.select client mailbox in
629
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
630
+
let _ = Imap.Client.select client mailbox in
631
+
(* TEXT searches both headers and body *)
632
+
let results = Imap.Client.search client (Imap.Search.Text "integration testing") in
633
+
assert_length ~msg:"search TEXT results" 1 results)
634
+
635
+
let test_search_body ~sw ~env ~config () =
636
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-body" (fun client mailbox ->
637
+
let _ = Imap.Client.select client mailbox in
638
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
639
+
let _ = Imap.Client.select client mailbox in
640
+
(* BODY searches only body *)
641
+
let results = Imap.Client.search client (Imap.Search.Body "multiple lines") in
642
+
assert_length ~msg:"search BODY results" 1 results)
643
+
644
+
(* ========== Fetch Tests (RFC 9051 Section 6.4.5) ========== *)
645
+
646
+
let test_fetch_internaldate ~sw ~env ~config () =
647
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-date" (fun client mailbox ->
648
+
let _ = Imap.Client.select client mailbox in
649
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
650
+
let _ = Imap.Client.select client mailbox in
651
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
652
+
~items:[Imap.Fetch.Internaldate] () in
653
+
assert_length ~msg:"fetch results" 1 msgs;
654
+
let msg = List.hd msgs in
655
+
assert_true "internaldate should be present" (Option.is_some msg.internaldate))
656
+
657
+
let test_fetch_rfc822_size ~sw ~env ~config () =
658
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-size" (fun client mailbox ->
659
+
let _ = Imap.Client.select client mailbox in
660
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
661
+
let _ = Imap.Client.select client mailbox in
662
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
663
+
~items:[Imap.Fetch.Rfc822_size] () in
664
+
assert_length ~msg:"fetch results" 1 msgs;
665
+
let msg = List.hd msgs in
666
+
assert_true "size should be present" (Option.is_some msg.size);
667
+
let size = Option.get msg.size in
668
+
assert_true "size should be > 0" (size > 0L))
669
+
670
+
let test_fetch_multiple_items ~sw ~env ~config () =
671
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-multi" (fun client mailbox ->
672
+
let _ = Imap.Client.select client mailbox in
673
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
674
+
let _ = Imap.Client.select client mailbox in
675
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
676
+
~items:[Imap.Fetch.Uid; Imap.Fetch.Flags; Imap.Fetch.Envelope; Imap.Fetch.Rfc822_size] () in
677
+
assert_length ~msg:"fetch results" 1 msgs;
678
+
let msg = List.hd msgs in
679
+
assert_true "uid should be present" (Option.is_some msg.uid);
680
+
assert_true "flags should be present" (Option.is_some msg.flags);
681
+
assert_true "envelope should be present" (Option.is_some msg.envelope);
682
+
assert_true "size should be present" (Option.is_some msg.size))
683
+
684
+
let test_fetch_sequence_range ~sw ~env ~config () =
685
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-range" (fun client mailbox ->
686
+
let _ = Imap.Client.select client mailbox in
687
+
(* Append 5 messages *)
688
+
for _ = 1 to 5 do
689
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in ()
690
+
done;
691
+
let _ = Imap.Client.select client mailbox in
692
+
(* Fetch range 2:4 *)
693
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.range 2 4)
694
+
~items:[Imap.Fetch.Uid] () in
695
+
assert_length ~msg:"fetch range 2:4" 3 msgs)
696
+
697
+
(* ========== Mailbox Info Tests (RFC 9051 Section 6.3.1) ========== *)
698
+
699
+
let test_mailbox_info_fields ~sw ~env ~config () =
700
+
with_test_mailbox ~sw ~env ~config ~suffix:"mbox-info" (fun client mailbox ->
701
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
702
+
let info = Imap.Client.select client mailbox in
703
+
assert_true "exists should be 1" (info.exists = 1);
704
+
assert_true "uidvalidity should be > 0" (info.uidvalidity > 0L);
705
+
assert_true "uidnext should be > 0" (info.uidnext > 0L);
706
+
assert_true "flags list should not be empty" (info.flags <> []);
707
+
assert_true "should not be readonly" (not info.readonly))
708
+
709
+
let test_examine_vs_select ~sw ~env ~config () =
710
+
with_test_mailbox ~sw ~env ~config ~suffix:"exam-sel" (fun client mailbox ->
711
+
let select_info = Imap.Client.select client mailbox in
712
+
let examine_info = Imap.Client.examine client mailbox in
713
+
(* UIDVALIDITY should be the same *)
714
+
assert_true "uidvalidity should match"
715
+
(select_info.uidvalidity = examine_info.uidvalidity);
716
+
(* EXAMINE should be readonly *)
717
+
assert_true "examine should be readonly" examine_info.readonly;
718
+
assert_true "select should not be readonly" (not select_info.readonly))
719
+
720
+
(* ========== Extension Tests ========== *)
721
+
722
+
let test_id_extension ~sw ~env ~config () =
723
+
with_test_setup ~sw ~env ~config (fun client ->
724
+
if not (has_capability client "ID") then
725
+
raise (Failure "SKIP: Server does not support ID");
726
+
(* Send client ID *)
727
+
let server_id = Imap.Client.id client
728
+
(Some [("name", "imaptest"); ("version", "1.0")]) in
729
+
(* Server should respond with its ID or NIL *)
730
+
ignore server_id)
731
+
732
+
let test_namespace_extension ~sw ~env ~config () =
733
+
with_test_setup ~sw ~env ~config (fun client ->
734
+
if not (has_capability client "NAMESPACE") then
735
+
raise (Failure "SKIP: Server does not support NAMESPACE");
736
+
let ns = Imap.Client.namespace client in
737
+
(* Personal namespace should exist for most servers *)
738
+
ignore ns)
739
+
740
+
let test_enable_extension ~sw ~env ~config () =
741
+
with_test_setup ~sw ~env ~config (fun client ->
742
+
(* Try to enable a common extension if available *)
743
+
let caps = Imap.Client.capabilities client in
744
+
if List.mem "CONDSTORE" caps then begin
745
+
let enabled = Imap.Client.enable client ["CONDSTORE"] in
746
+
assert_true "CONDSTORE should be enabled" (List.mem "CONDSTORE" enabled)
747
+
end else if List.mem "UTF8=ACCEPT" caps then begin
748
+
let enabled = Imap.Client.enable client ["UTF8=ACCEPT"] in
749
+
ignore enabled
750
+
end else
751
+
(* No common extensions to test, skip *)
752
+
raise (Failure "SKIP: No testable extensions available"))
753
+
754
+
(* ========== List Tests (RFC 9051 Section 6.3.9) ========== *)
755
+
756
+
let test_list_with_pattern ~sw ~env ~config () =
757
+
with_test_setup ~sw ~env ~config (fun client ->
758
+
(* List with wildcard pattern *)
759
+
let all = Imap.Client.list client ~reference:"" ~pattern:"*" in
760
+
assert_true "should have at least INBOX" (List.length all >= 1);
761
+
(* List with specific pattern for our test mailboxes *)
762
+
let pattern = config.mailbox_prefix ^ "*" in
763
+
let test_boxes = Imap.Client.list client ~reference:"" ~pattern in
764
+
(* Result depends on existing test mailboxes *)
765
+
ignore test_boxes)
766
+
767
+
let test_list_hierarchy ~sw ~env ~config () =
768
+
with_test_setup ~sw ~env ~config (fun client ->
769
+
(* Create hierarchical mailbox if server supports it *)
770
+
let parent = make_test_mailbox_name ~config ~suffix:"parent" in
771
+
let child = parent ^ "/child" in
772
+
Imap.Client.create client parent;
773
+
(try Imap.Client.create client child with _ -> ());
774
+
Fun.protect
775
+
~finally:(fun () ->
776
+
(try Imap.Client.delete client child with _ -> ());
777
+
delete_mailbox_safe client parent)
778
+
(fun () ->
779
+
let entries = Imap.Client.list client ~reference:"" ~pattern:(parent ^ "*") in
780
+
(* Should have at least the parent *)
781
+
assert_true "should list parent mailbox" (List.length entries >= 1)))
782
+
783
+
(* ========== Noop and State Tests ========== *)
784
+
785
+
let test_noop ~sw ~env ~config () =
786
+
with_test_setup ~sw ~env ~config (fun client ->
787
+
(* NOOP should succeed in authenticated state *)
788
+
Imap.Client.noop client;
789
+
let _ = Imap.Client.select client "INBOX" in
790
+
(* NOOP should also succeed in selected state *)
791
+
Imap.Client.noop client)
792
+
793
+
let test_close_mailbox ~sw ~env ~config () =
794
+
with_test_mailbox ~sw ~env ~config ~suffix:"close" (fun client mailbox ->
795
+
let _ = Imap.Client.select client mailbox in
796
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
797
+
~flags:[Imap.Flag.System Imap.Flag.Deleted] () in
798
+
let _ = Imap.Client.select client mailbox in
799
+
(* CLOSE should expunge deleted messages and return to authenticated state *)
800
+
Imap.Client.close client;
801
+
(* After close, we should be in authenticated state (not selected) *)
802
+
match Imap.Client.state client with
803
+
| Imap.Client.Authenticated _ -> ()
804
+
| _ -> raise (Failure "should be in authenticated state after CLOSE"))
805
+
806
+
let test_unselect ~sw ~env ~config () =
807
+
with_test_setup ~sw ~env ~config (fun client ->
808
+
if not (has_capability client "UNSELECT") then
809
+
raise (Failure "SKIP: Server does not support UNSELECT");
810
+
let mailbox = create_test_mailbox client ~config ~suffix:"unsel" in
811
+
Fun.protect
812
+
~finally:(fun () -> delete_mailbox_safe client mailbox)
813
+
(fun () ->
814
+
let _ = Imap.Client.select client mailbox in
815
+
(* UNSELECT should not expunge, just deselect *)
816
+
Imap.Client.unselect client;
817
+
match Imap.Client.state client with
818
+
| Imap.Client.Authenticated _ -> ()
819
+
| _ -> raise (Failure "should be in authenticated state after UNSELECT")))
820
+
821
+
(* ========== Append Tests ========== *)
822
+
823
+
let test_append_with_date ~sw ~env ~config () =
824
+
with_test_mailbox ~sw ~env ~config ~suffix:"append-date" (fun client mailbox ->
825
+
let _ = Imap.Client.select client mailbox in
826
+
(* Append with specific internal date *)
827
+
let date = "01-Jan-2020 12:00:00 +0000" in
828
+
let _ = Imap.Client.append client ~mailbox ~message:test_message ~date () in
829
+
let _ = Imap.Client.select client mailbox in
830
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
831
+
~items:[Imap.Fetch.Internaldate] () in
832
+
let msg = List.hd msgs in
833
+
(* Date should be set (format may vary by server) *)
834
+
assert_true "internaldate should be present" (Option.is_some msg.internaldate))
835
+
836
+
(* ========== Pool Tests ========== *)
837
+
838
+
let test_pool_acquire_release ~sw ~env ~(config : Imaptest_config.t) () =
839
+
let pool = Imap.Pool.create ~sw ~env
840
+
~host:config.host ~port:config.port
841
+
~username:config.username ~password:config.password
842
+
() in
843
+
Fun.protect
844
+
~finally:(fun () -> Imap.Pool.close pool)
845
+
(fun () ->
846
+
let client = Imap.Pool.acquire pool in
847
+
(* Check we can use it *)
848
+
let _ = Imap.Client.noop client in
849
+
Imap.Pool.release pool client;
850
+
(* Verify pool stats *)
851
+
let stats = Imap.Pool.stats pool in
852
+
assert_true "should have created at least 1" (stats.created >= 1))
853
+
854
+
let test_pool_with_client ~sw ~env ~(config : Imaptest_config.t) () =
855
+
let pool = Imap.Pool.create ~sw ~env
856
+
~host:config.host ~port:config.port
857
+
~username:config.username ~password:config.password
858
+
() in
859
+
Fun.protect
860
+
~finally:(fun () -> Imap.Pool.close pool)
861
+
(fun () ->
862
+
let result = Imap.Pool.with_client pool (fun client ->
863
+
let _ = Imap.Client.select client "INBOX" in
864
+
42
865
+
) in
866
+
assert_true "with_client should return value" (result = 42))
867
+
868
+
(* ========== Error Tests ========== *)
869
+
870
+
(* ========== Additional FETCH Tests (RFC 9051 Section 6.4.5) ========== *)
871
+
872
+
let test_fetch_rfc822_full ~sw ~env ~config () =
873
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-rfc822" (fun client mailbox ->
874
+
let _ = Imap.Client.select client mailbox in
875
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
876
+
let _ = Imap.Client.select client mailbox in
877
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
878
+
~items:[Imap.Fetch.Rfc822] () in
879
+
assert_length ~msg:"fetch results" 1 msgs;
880
+
let msg = List.hd msgs in
881
+
(* RFC822 should populate body_section *)
882
+
assert_true "rfc822 should return message content" (Option.is_some msg.body_section))
883
+
884
+
let test_fetch_rfc822_header ~sw ~env ~config () =
885
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-hdr" (fun client mailbox ->
886
+
let _ = Imap.Client.select client mailbox in
887
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
888
+
let _ = Imap.Client.select client mailbox in
889
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
890
+
~items:[Imap.Fetch.Rfc822_header] () in
891
+
assert_length ~msg:"fetch results" 1 msgs;
892
+
let msg = List.hd msgs in
893
+
match msg.body_section with
894
+
| Some headers ->
895
+
assert_true "headers should contain From" (String.length headers > 0)
896
+
| None -> raise (Failure "expected headers"))
897
+
898
+
let test_fetch_rfc822_text ~sw ~env ~config () =
899
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-text" (fun client mailbox ->
900
+
let _ = Imap.Client.select client mailbox in
901
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
902
+
let _ = Imap.Client.select client mailbox in
903
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
904
+
~items:[Imap.Fetch.Rfc822_text] () in
905
+
assert_length ~msg:"fetch results" 1 msgs;
906
+
let msg = List.hd msgs in
907
+
match msg.body_section with
908
+
| Some body ->
909
+
assert_true "body should contain test content" (String.length body > 0)
910
+
| None -> raise (Failure "expected body text"))
911
+
912
+
let test_fetch_body_header ~sw ~env ~config () =
913
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-bhdr" (fun client mailbox ->
914
+
let _ = Imap.Client.select client mailbox in
915
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
916
+
let _ = Imap.Client.select client mailbox in
917
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
918
+
~items:[Imap.Fetch.Body_peek ("HEADER", None)] () in
919
+
assert_length ~msg:"fetch results" 1 msgs;
920
+
let msg = List.hd msgs in
921
+
match msg.body_section with
922
+
| Some headers ->
923
+
(* Simple substring check for "subject" *)
924
+
let contains_subject =
925
+
let lower = String.lowercase_ascii headers in
926
+
let rec check i =
927
+
if i + 7 > String.length lower then false
928
+
else if String.sub lower i 7 = "subject" then true
929
+
else check (i + 1)
930
+
in check 0
931
+
in
932
+
assert_true "should contain Subject header" contains_subject
933
+
| None -> raise (Failure "expected header section"))
934
+
935
+
let test_fetch_body_text ~sw ~env ~config () =
936
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-btxt" (fun client mailbox ->
937
+
let _ = Imap.Client.select client mailbox in
938
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
939
+
let _ = Imap.Client.select client mailbox in
940
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
941
+
~items:[Imap.Fetch.Body_peek ("TEXT", None)] () in
942
+
assert_length ~msg:"fetch results" 1 msgs;
943
+
let msg = List.hd msgs in
944
+
match msg.body_section with
945
+
| Some body ->
946
+
assert_true "should contain message body" (String.length body > 0)
947
+
| None -> raise (Failure "expected text section"))
948
+
949
+
let test_fetch_partial ~sw ~env ~config () =
950
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-partial" (fun client mailbox ->
951
+
let _ = Imap.Client.select client mailbox in
952
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
953
+
let _ = Imap.Client.select client mailbox in
954
+
(* Fetch first 10 bytes *)
955
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
956
+
~items:[Imap.Fetch.Body_peek ("", Some (0, 10))] () in
957
+
assert_length ~msg:"fetch results" 1 msgs;
958
+
let msg = List.hd msgs in
959
+
match msg.body_section with
960
+
| Some partial ->
961
+
assert_true "partial should be <= 10 bytes" (String.length partial <= 10)
962
+
| None -> raise (Failure "expected partial content"))
963
+
964
+
(* ========== Additional SEARCH Tests (RFC 9051 Section 6.4.4) ========== *)
965
+
966
+
let test_search_before ~sw ~env ~config () =
967
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-before" (fun client mailbox ->
968
+
let _ = Imap.Client.select client mailbox in
969
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
970
+
let _ = Imap.Client.select client mailbox in
971
+
(* Search for messages before a future date - should find our message *)
972
+
let results = Imap.Client.search client (Imap.Search.Before "31-Dec-2099") in
973
+
assert_true "should find message before future date" (List.length results >= 1))
974
+
975
+
let test_search_since ~sw ~env ~config () =
976
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-since" (fun client mailbox ->
977
+
let _ = Imap.Client.select client mailbox in
978
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
979
+
let _ = Imap.Client.select client mailbox in
980
+
(* Search for messages since a past date - should find our message *)
981
+
let results = Imap.Client.search client (Imap.Search.Since "01-Jan-2000") in
982
+
assert_true "should find message since past date" (List.length results >= 1))
983
+
984
+
let test_search_on ~sw ~env ~config () =
985
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-on" (fun client mailbox ->
986
+
let _ = Imap.Client.select client mailbox in
987
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
988
+
let _ = Imap.Client.select client mailbox in
989
+
(* Get today's date in IMAP format *)
990
+
let tm = Unix.localtime (Unix.time ()) in
991
+
let months = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|] in
992
+
let date = Printf.sprintf "%02d-%s-%04d" tm.Unix.tm_mday months.(tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) in
993
+
let results = Imap.Client.search client (Imap.Search.On date) in
994
+
(* May or may not find messages depending on when test runs *)
995
+
ignore results)
996
+
997
+
let test_search_smaller ~sw ~env ~config () =
998
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-smaller" (fun client mailbox ->
999
+
let _ = Imap.Client.select client mailbox in
1000
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1001
+
let _ = Imap.Client.select client mailbox in
1002
+
(* Test message is small, search for smaller than 1MB *)
1003
+
let results = Imap.Client.search client (Imap.Search.Smaller 1000000L) in
1004
+
assert_true "should find message smaller than 1MB" (List.length results >= 1))
1005
+
1006
+
let test_search_new ~sw ~env ~config () =
1007
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-new" (fun client mailbox ->
1008
+
let _ = Imap.Client.select client mailbox in
1009
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1010
+
let _ = Imap.Client.select client mailbox in
1011
+
(* New = Recent AND Unseen *)
1012
+
let results = Imap.Client.search client Imap.Search.New in
1013
+
(* Newly appended message should be new *)
1014
+
ignore results)
1015
+
1016
+
let test_search_old ~sw ~env ~config () =
1017
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-old" (fun client mailbox ->
1018
+
let _ = Imap.Client.select client mailbox in
1019
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1020
+
let _ = Imap.Client.select client mailbox in
1021
+
(* Old = NOT Recent *)
1022
+
let results = Imap.Client.search client Imap.Search.Old in
1023
+
ignore results)
1024
+
1025
+
let test_search_draft ~sw ~env ~config () =
1026
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-draft" (fun client mailbox ->
1027
+
let _ = Imap.Client.select client mailbox in
1028
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
1029
+
~flags:[Imap.Flag.System Imap.Flag.Draft] () in
1030
+
let _ = Imap.Client.select client mailbox in
1031
+
let results = Imap.Client.search client Imap.Search.Draft in
1032
+
assert_true "should find draft message" (List.length results >= 1))
1033
+
1034
+
let test_search_undraft ~sw ~env ~config () =
1035
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-undraft" (fun client mailbox ->
1036
+
let _ = Imap.Client.select client mailbox in
1037
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1038
+
let _ = Imap.Client.select client mailbox in
1039
+
let results = Imap.Client.search client Imap.Search.Undraft in
1040
+
assert_true "should find non-draft message" (List.length results >= 1))
1041
+
1042
+
let test_search_unanswered ~sw ~env ~config () =
1043
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-unans" (fun client mailbox ->
1044
+
let _ = Imap.Client.select client mailbox in
1045
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1046
+
let _ = Imap.Client.select client mailbox in
1047
+
let results = Imap.Client.search client Imap.Search.Unanswered in
1048
+
assert_true "should find unanswered message" (List.length results >= 1))
1049
+
1050
+
let test_search_unflagged ~sw ~env ~config () =
1051
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-unflg" (fun client mailbox ->
1052
+
let _ = Imap.Client.select client mailbox in
1053
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1054
+
let _ = Imap.Client.select client mailbox in
1055
+
let results = Imap.Client.search client Imap.Search.Unflagged in
1056
+
assert_true "should find unflagged message" (List.length results >= 1))
1057
+
1058
+
let test_search_undeleted ~sw ~env ~config () =
1059
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-undel" (fun client mailbox ->
1060
+
let _ = Imap.Client.select client mailbox in
1061
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1062
+
let _ = Imap.Client.select client mailbox in
1063
+
let results = Imap.Client.search client Imap.Search.Undeleted in
1064
+
assert_true "should find undeleted message" (List.length results >= 1))
1065
+
1066
+
let test_search_sequence_set ~sw ~env ~config () =
1067
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-seq" (fun client mailbox ->
1068
+
let _ = Imap.Client.select client mailbox in
1069
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1070
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1071
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1072
+
let _ = Imap.Client.select client mailbox in
1073
+
(* Search for messages 1 and 3 *)
1074
+
let results = Imap.Client.search client
1075
+
(Imap.Search.Sequence_set [Imap.Seq.Single 1; Imap.Seq.Single 3]) in
1076
+
assert_true "should find 2 messages" (List.length results = 2))
1077
+
1078
+
let test_search_uid_set ~sw ~env ~config () =
1079
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-uid" (fun client mailbox ->
1080
+
let _ = Imap.Client.select client mailbox in
1081
+
let uid1 = Imap.Client.append client ~mailbox ~message:test_message () in
1082
+
let _ = Imap.Client.select client mailbox in
1083
+
match uid1 with
1084
+
| Some uid ->
1085
+
let results = Imap.Client.search client
1086
+
(Imap.Search.Uid [Imap.Seq.Single (Int64.to_int uid)]) in
1087
+
assert_true "should find message by UID" (List.length results = 1)
1088
+
| None -> ())
1089
+
1090
+
let test_search_complex_and ~sw ~env ~config () =
1091
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-cplx" (fun client mailbox ->
1092
+
let _ = Imap.Client.select client mailbox in
1093
+
let _ = Imap.Client.append client ~mailbox ~message:test_message
1094
+
~flags:[Imap.Flag.System Imap.Flag.Seen] () in
1095
+
let _ = Imap.Client.select client mailbox in
1096
+
(* Complex AND: Seen AND Subject contains "Test" AND Smaller than 1MB *)
1097
+
let results = Imap.Client.search client
1098
+
(Imap.Search.And [
1099
+
Imap.Search.Seen;
1100
+
Imap.Search.Subject "Test";
1101
+
Imap.Search.Smaller 1000000L;
1102
+
]) in
1103
+
assert_true "should find message matching all criteria" (List.length results >= 1))
1104
+
1105
+
let test_search_cc ~sw ~env ~config () =
1106
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-cc" (fun client mailbox ->
1107
+
let _ = Imap.Client.select client mailbox in
1108
+
(* Create message with CC header *)
1109
+
let msg_with_cc = String.concat "\r\n" [
1110
+
"From: sender@example.com";
1111
+
"To: recipient@example.com";
1112
+
"Cc: ccuser@example.com";
1113
+
"Subject: Test CC";
1114
+
"Date: Mon, 1 Jan 2024 12:00:00 +0000";
1115
+
"Message-ID: <cc-test@example.com>";
1116
+
"";
1117
+
"Test body"
1118
+
] in
1119
+
let _ = Imap.Client.append client ~mailbox ~message:msg_with_cc () in
1120
+
let _ = Imap.Client.select client mailbox in
1121
+
let results = Imap.Client.search client (Imap.Search.Cc "ccuser") in
1122
+
assert_true "should find message with CC" (List.length results >= 1))
1123
+
1124
+
let test_search_bcc ~sw ~env ~config () =
1125
+
with_test_mailbox ~sw ~env ~config ~suffix:"search-bcc" (fun client mailbox ->
1126
+
let _ = Imap.Client.select client mailbox in
1127
+
(* Note: BCC headers are typically stripped, but we can try *)
1128
+
let msg_with_bcc = String.concat "\r\n" [
1129
+
"From: sender@example.com";
1130
+
"To: recipient@example.com";
1131
+
"Bcc: bccuser@example.com";
1132
+
"Subject: Test BCC";
1133
+
"Date: Mon, 1 Jan 2024 12:00:00 +0000";
1134
+
"Message-ID: <bcc-test@example.com>";
1135
+
"";
1136
+
"Test body"
1137
+
] in
1138
+
let _ = Imap.Client.append client ~mailbox ~message:msg_with_bcc () in
1139
+
let _ = Imap.Client.select client mailbox in
1140
+
let results = Imap.Client.search client (Imap.Search.Bcc "bccuser") in
1141
+
(* BCC search may or may not work depending on server *)
1142
+
ignore results)
1143
+
1144
+
(* ========== Envelope Tests (RFC 9051 Section 7.4.1) ========== *)
1145
+
1146
+
let test_envelope_multiple_addresses ~sw ~env ~config () =
1147
+
with_test_mailbox ~sw ~env ~config ~suffix:"env-multi" (fun client mailbox ->
1148
+
let _ = Imap.Client.select client mailbox in
1149
+
let multi_addr_msg = String.concat "\r\n" [
1150
+
"From: Alice <alice@example.com>";
1151
+
"To: Bob <bob@example.com>, Carol <carol@example.com>";
1152
+
"Cc: Dave <dave@example.com>";
1153
+
"Reply-To: reply@example.com";
1154
+
"Subject: Multi-address Test";
1155
+
"Date: Mon, 1 Jan 2024 12:00:00 +0000";
1156
+
"Message-ID: <multi@example.com>";
1157
+
"In-Reply-To: <original@example.com>";
1158
+
"";
1159
+
"Test body"
1160
+
] in
1161
+
let _ = Imap.Client.append client ~mailbox ~message:multi_addr_msg () in
1162
+
let _ = Imap.Client.select client mailbox in
1163
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
1164
+
~items:[Imap.Fetch.Envelope] () in
1165
+
let msg = List.hd msgs in
1166
+
match msg.envelope with
1167
+
| Some env ->
1168
+
assert_true "should have 2 To addresses" (List.length env.to_ = 2);
1169
+
assert_true "should have 1 Cc address" (List.length env.cc = 1);
1170
+
assert_true "should have In-Reply-To" (Option.is_some env.in_reply_to)
1171
+
| None -> raise (Failure "expected envelope"))
1172
+
1173
+
let test_envelope_special_chars ~sw ~env ~config () =
1174
+
with_test_mailbox ~sw ~env ~config ~suffix:"env-special" (fun client mailbox ->
1175
+
let _ = Imap.Client.select client mailbox in
1176
+
let special_msg = String.concat "\r\n" [
1177
+
"From: \"John Doe (Sales)\" <john@example.com>";
1178
+
"To: recipient@example.com";
1179
+
"Subject: =?UTF-8?B?VGVzdCDwn46J?="; (* Test 🎉 in base64 *)
1180
+
"Date: Mon, 1 Jan 2024 12:00:00 +0000";
1181
+
"Message-ID: <special@example.com>";
1182
+
"";
1183
+
"Test body"
1184
+
] in
1185
+
let _ = Imap.Client.append client ~mailbox ~message:special_msg () in
1186
+
let _ = Imap.Client.select client mailbox in
1187
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
1188
+
~items:[Imap.Fetch.Envelope] () in
1189
+
let msg = List.hd msgs in
1190
+
assert_true "should have envelope" (Option.is_some msg.envelope))
1191
+
1192
+
(* ========== APPEND Tests (RFC 9051 Section 6.3.11) ========== *)
1193
+
1194
+
let test_append_with_flags ~sw ~env ~config () =
1195
+
with_test_mailbox ~sw ~env ~config ~suffix:"append-flags" (fun client mailbox ->
1196
+
let _ = Imap.Client.select client mailbox in
1197
+
let flags = [
1198
+
Imap.Flag.System Imap.Flag.Seen;
1199
+
Imap.Flag.System Imap.Flag.Flagged;
1200
+
] in
1201
+
let _ = Imap.Client.append client ~mailbox ~message:test_message ~flags () in
1202
+
let _ = Imap.Client.select client mailbox in
1203
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.single 1)
1204
+
~items:[Imap.Fetch.Flags] () in
1205
+
let msg = List.hd msgs in
1206
+
let msg_flags = Option.get msg.flags in
1207
+
assert_true "should have Seen flag"
1208
+
(List.mem (Imap.Flag.System Imap.Flag.Seen) msg_flags);
1209
+
assert_true "should have Flagged flag"
1210
+
(List.mem (Imap.Flag.System Imap.Flag.Flagged) msg_flags))
1211
+
1212
+
let test_append_multiple ~sw ~env ~config () =
1213
+
with_test_mailbox ~sw ~env ~config ~suffix:"append-multi" (fun client mailbox ->
1214
+
let _ = Imap.Client.select client mailbox in
1215
+
(* Append 5 messages *)
1216
+
for i = 1 to 5 do
1217
+
let msg = make_test_message ~id:(string_of_int i) ~subject:(Printf.sprintf "Message %d" i) in
1218
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in
1219
+
()
1220
+
done;
1221
+
let info = Imap.Client.select client mailbox in
1222
+
assert_true "should have 5 messages" (info.exists = 5))
1223
+
1224
+
(* ========== SPECIAL-USE Tests (RFC 6154) ========== *)
1225
+
1226
+
let test_special_use_list ~sw ~env ~config () =
1227
+
with_test_setup ~sw ~env ~config (fun client ->
1228
+
if not (has_capability client "SPECIAL-USE") then
1229
+
raise (Failure "SKIP: Server does not support SPECIAL-USE");
1230
+
let mailboxes = Imap.Client.list client ~reference:"" ~pattern:"*" in
1231
+
(* Check if any mailboxes have special-use attributes *)
1232
+
let has_special = List.exists (fun (entry : Imap.Client.list_entry) ->
1233
+
List.exists (function
1234
+
| Imap.List_attr.Sent | Imap.List_attr.Drafts | Imap.List_attr.Trash
1235
+
| Imap.List_attr.Junk | Imap.List_attr.Archive -> true
1236
+
| _ -> false
1237
+
) entry.flags
1238
+
) mailboxes in
1239
+
(* Server may or may not have special-use mailboxes configured *)
1240
+
ignore has_special)
1241
+
1242
+
(* ========== SORT Extension Tests (RFC 5256) ========== *)
1243
+
1244
+
let test_sort_by_date ~sw ~env ~config () =
1245
+
with_test_mailbox ~sw ~env ~config ~suffix:"sort" (fun client mailbox ->
1246
+
if not (has_capability client "SORT") then
1247
+
raise (Failure "SKIP: Server does not support SORT");
1248
+
let _ = Imap.Client.select client mailbox in
1249
+
(* Append messages with different dates (servers use internal date for ARRIVAL) *)
1250
+
for i = 1 to 3 do
1251
+
let msg = make_test_message ~id:(string_of_int i) ~subject:(Printf.sprintf "Message %d" i) in
1252
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in ()
1253
+
done;
1254
+
let _ = Imap.Client.select client mailbox in
1255
+
(* SORT by ARRIVAL (internal date) ascending *)
1256
+
let sorted = Imap.Client.sort client
1257
+
~charset:"UTF-8"
1258
+
[Imap.Sort.key Imap.Sort.Arrival]
1259
+
Imap.Search.All in
1260
+
assert_length ~msg:"sorted results" 3 sorted;
1261
+
(* SORT with REVERSE *)
1262
+
let sorted_rev = Imap.Client.sort client
1263
+
~charset:"UTF-8"
1264
+
[Imap.Sort.reverse Imap.Sort.Arrival]
1265
+
Imap.Search.All in
1266
+
assert_length ~msg:"reverse sorted results" 3 sorted_rev;
1267
+
(* Check that reverse order is different (or same if all same timestamp) *)
1268
+
let _ = sorted_rev in ())
1269
+
1270
+
(* ========== CONDSTORE Tests (RFC 7162) ========== *)
1271
+
1272
+
let test_condstore ~sw ~env ~config () =
1273
+
with_test_mailbox ~sw ~env ~config ~suffix:"condstore" (fun client mailbox ->
1274
+
if not (has_capability client "CONDSTORE") then
1275
+
raise (Failure "SKIP: Server does not support CONDSTORE");
1276
+
let _ = Imap.Client.select client mailbox in
1277
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
1278
+
let _ = Imap.Client.select client mailbox in
1279
+
(* Fetch to get MODSEQ if server provides it *)
1280
+
let _ = Imap.Client.fetch client
1281
+
~sequence:(Imap.Seq.single 1)
1282
+
~items:[Imap.Fetch.Flags; Imap.Fetch.Uid] () in
1283
+
(* CONDSTORE: Store with UNCHANGEDSINCE (may fail if modseq changed) *)
1284
+
(* Use a very high modseq that should always succeed *)
1285
+
let _ = Imap.Client.store client
1286
+
~sequence:(Imap.Seq.single 1)
1287
+
~action:Imap.Store.Add
1288
+
~flags:[Imap.Flag.System Imap.Flag.Seen]
1289
+
~unchangedsince:Int64.max_int () in
1290
+
(* Verify flag was set *)
1291
+
let msgs = Imap.Client.fetch client
1292
+
~sequence:(Imap.Seq.single 1)
1293
+
~items:[Imap.Fetch.Flags] () in
1294
+
let msg = List.hd msgs in
1295
+
let flags = Option.get msg.flags in
1296
+
assert_true "should have Seen flag"
1297
+
(List.mem (Imap.Flag.System Imap.Flag.Seen) flags))
1298
+
1299
+
(* ========== Multi-Message Operations ========== *)
1300
+
1301
+
let test_fetch_multiple_messages ~sw ~env ~config () =
1302
+
with_test_mailbox ~sw ~env ~config ~suffix:"fetch-multi" (fun client mailbox ->
1303
+
let _ = Imap.Client.select client mailbox in
1304
+
for i = 1 to 3 do
1305
+
let msg = make_test_message ~id:(string_of_int i) ~subject:(Printf.sprintf "Message %d" i) in
1306
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in
1307
+
()
1308
+
done;
1309
+
let _ = Imap.Client.select client mailbox in
1310
+
(* Fetch all messages at once *)
1311
+
let msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.range 1 3)
1312
+
~items:[Imap.Fetch.Envelope; Imap.Fetch.Flags; Imap.Fetch.Uid] () in
1313
+
assert_length ~msg:"should fetch 3 messages" 3 msgs)
1314
+
1315
+
let test_store_multiple_messages ~sw ~env ~config () =
1316
+
with_test_mailbox ~sw ~env ~config ~suffix:"store-multi" (fun client mailbox ->
1317
+
let _ = Imap.Client.select client mailbox in
1318
+
for i = 1 to 3 do
1319
+
let test_msg = make_test_message ~id:(string_of_int i) ~subject:(Printf.sprintf "Message %d" i) in
1320
+
let _ = Imap.Client.append client ~mailbox ~message:test_msg () in
1321
+
()
1322
+
done;
1323
+
let _ = Imap.Client.select client mailbox in
1324
+
(* Set flags on all messages *)
1325
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.range 1 3)
1326
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Seen] () in
1327
+
(* Verify all are seen *)
1328
+
let fetched_msgs = Imap.Client.fetch client ~sequence:(Imap.Seq.range 1 3)
1329
+
~items:[Imap.Fetch.Flags] () in
1330
+
List.iter (fun (m : Imap.Client.message_info) ->
1331
+
let flags = Option.get m.flags in
1332
+
assert_true "should be seen" (List.mem (Imap.Flag.System Imap.Flag.Seen) flags)
1333
+
) fetched_msgs)
1334
+
1335
+
let test_copy_multiple_messages ~sw ~env ~config () =
1336
+
with_test_mailbox ~sw ~env ~config ~suffix:"copy-src" (fun client src_mailbox ->
1337
+
let dest_mailbox = create_test_mailbox client ~config ~suffix:"copy-dst" in
1338
+
Fun.protect
1339
+
~finally:(fun () -> delete_mailbox_safe client dest_mailbox)
1340
+
(fun () ->
1341
+
let _ = Imap.Client.select client src_mailbox in
1342
+
for i = 1 to 3 do
1343
+
let msg = make_test_message ~id:(string_of_int i) ~subject:(Printf.sprintf "Message %d" i) in
1344
+
let _ = Imap.Client.append client ~mailbox:src_mailbox ~message:msg () in
1345
+
()
1346
+
done;
1347
+
let _ = Imap.Client.select client src_mailbox in
1348
+
(* Copy all messages *)
1349
+
Imap.Client.copy client ~sequence:(Imap.Seq.range 1 3) ~mailbox:dest_mailbox;
1350
+
(* Verify destination has 3 messages *)
1351
+
let dest_info = Imap.Client.select client dest_mailbox in
1352
+
assert_true "destination should have 3 messages" (dest_info.exists = 3)))
1353
+
1354
+
let test_expunge_multiple ~sw ~env ~config () =
1355
+
with_test_mailbox ~sw ~env ~config ~suffix:"expunge-multi" (fun client mailbox ->
1356
+
let _ = Imap.Client.select client mailbox in
1357
+
for i = 1 to 5 do
1358
+
let msg = make_test_message ~id:(string_of_int i) ~subject:(Printf.sprintf "Message %d" i) in
1359
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in
1360
+
()
1361
+
done;
1362
+
let _ = Imap.Client.select client mailbox in
1363
+
(* Mark messages 2 and 4 for deletion *)
1364
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 2)
1365
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Deleted] () in
1366
+
let _ = Imap.Client.store client ~sequence:(Imap.Seq.single 4)
1367
+
~action:Imap.Store.Add ~flags:[Imap.Flag.System Imap.Flag.Deleted] () in
1368
+
let _ = Imap.Client.expunge client in
1369
+
let info = Imap.Client.select client mailbox in
1370
+
assert_true "should have 3 messages after expunge" (info.exists = 3))
1371
+
1372
+
(* ========== Error Handling Tests ========== *)
1373
+
1374
+
let test_select_nonexistent ~sw ~env ~config () =
1375
+
with_test_setup ~sw ~env ~config (fun client ->
1376
+
let raised = ref false in
1377
+
(try
1378
+
let _ = Imap.Client.select client "nonexistent-mailbox-12345" in
1379
+
()
1380
+
with _ ->
1381
+
raised := true);
1382
+
assert_true "selecting nonexistent mailbox should fail" !raised)
1383
+
1384
+
let test_wrong_state ~sw ~env ~config () =
1385
+
let client = connect ~sw ~env ~config in
1386
+
let raised = ref false in
1387
+
(try
1388
+
(* Try to SELECT without logging in first *)
1389
+
let _ = Imap.Client.select client "INBOX" in
1390
+
()
1391
+
with
1392
+
| Eio.Exn.Io _ as exn ->
1393
+
(match Imap.Error.of_eio_exn exn with
1394
+
| Some (Imap.Error.State_error _) -> raised := true
1395
+
| _ -> ())
1396
+
| _ -> ());
1397
+
Imap.Client.disconnect client;
1398
+
assert_true "command in wrong state should fail" !raised
1399
+
1400
+
(* ========== Test Runner ========== *)
1401
+
1402
+
type 'a test = {
1403
+
name : string;
1404
+
category : string;
1405
+
run : sw:Eio.Switch.t -> env:'a -> config:Imaptest_config.t -> unit -> unit;
1406
+
}
1407
+
1408
+
let all_tests = [
1409
+
(* Connection Tests *)
1410
+
{ name = "connect_tls"; category = "Connection"; run = test_connect_tls };
1411
+
{ name = "login_valid"; category = "Connection"; run = test_login_valid };
1412
+
{ name = "login_invalid"; category = "Connection"; run = test_login_invalid };
1413
+
{ name = "capability"; category = "Connection"; run = test_capability };
1414
+
{ name = "logout"; category = "Connection"; run = test_logout };
1415
+
{ name = "noop"; category = "Connection"; run = test_noop };
1416
+
1417
+
(* Mailbox Tests *)
1418
+
{ name = "create_delete_mailbox"; category = "Mailbox"; run = test_create_delete_mailbox };
1419
+
{ name = "select_inbox"; category = "Mailbox"; run = test_select_inbox };
1420
+
{ name = "examine_readonly"; category = "Mailbox"; run = test_examine_readonly };
1421
+
{ name = "list_mailboxes"; category = "Mailbox"; run = test_list_mailboxes };
1422
+
{ name = "list_with_pattern"; category = "Mailbox"; run = test_list_with_pattern };
1423
+
{ name = "list_hierarchy"; category = "Mailbox"; run = test_list_hierarchy };
1424
+
{ name = "status_query"; category = "Mailbox"; run = test_status_query };
1425
+
{ name = "subscribe_unsubscribe"; category = "Mailbox"; run = test_subscribe_unsubscribe };
1426
+
{ name = "rename_mailbox"; category = "Mailbox"; run = test_rename_mailbox };
1427
+
{ name = "mailbox_info_fields"; category = "Mailbox"; run = test_mailbox_info_fields };
1428
+
{ name = "examine_vs_select"; category = "Mailbox"; run = test_examine_vs_select };
1429
+
{ name = "close_mailbox"; category = "Mailbox"; run = test_close_mailbox };
1430
+
{ name = "unselect"; category = "Mailbox"; run = test_unselect };
1431
+
1432
+
(* Flag Tests (RFC 9051 Section 2.3.2) *)
1433
+
{ name = "all_system_flags"; category = "Flags"; run = test_all_system_flags };
1434
+
{ name = "keyword_flags"; category = "Flags"; run = test_keyword_flags };
1435
+
{ name = "flag_persistence"; category = "Flags"; run = test_flag_persistence };
1436
+
1437
+
(* Message Tests *)
1438
+
{ name = "append_message"; category = "Message"; run = test_append_message };
1439
+
{ name = "append_with_date"; category = "Message"; run = test_append_with_date };
1440
+
{ name = "fetch_envelope"; category = "Fetch"; run = test_fetch_envelope };
1441
+
{ name = "fetch_flags"; category = "Fetch"; run = test_fetch_flags };
1442
+
{ name = "fetch_body"; category = "Fetch"; run = test_fetch_body };
1443
+
{ name = "fetch_bodystructure"; category = "Fetch"; run = test_fetch_bodystructure };
1444
+
{ name = "fetch_internaldate"; category = "Fetch"; run = test_fetch_internaldate };
1445
+
{ name = "fetch_rfc822_size"; category = "Fetch"; run = test_fetch_rfc822_size };
1446
+
{ name = "fetch_multiple_items"; category = "Fetch"; run = test_fetch_multiple_items };
1447
+
{ name = "fetch_sequence_range"; category = "Fetch"; run = test_fetch_sequence_range };
1448
+
{ name = "uid_fetch"; category = "Fetch"; run = test_uid_fetch };
1449
+
{ name = "fetch_rfc822_full"; category = "Fetch"; run = test_fetch_rfc822_full };
1450
+
{ name = "fetch_rfc822_header"; category = "Fetch"; run = test_fetch_rfc822_header };
1451
+
{ name = "fetch_rfc822_text"; category = "Fetch"; run = test_fetch_rfc822_text };
1452
+
{ name = "fetch_body_header"; category = "Fetch"; run = test_fetch_body_header };
1453
+
{ name = "fetch_body_text"; category = "Fetch"; run = test_fetch_body_text };
1454
+
{ name = "fetch_partial"; category = "Fetch"; run = test_fetch_partial };
1455
+
{ name = "fetch_multiple_messages"; category = "Fetch"; run = test_fetch_multiple_messages };
1456
+
1457
+
(* Store Tests *)
1458
+
{ name = "store_add_flag"; category = "Store"; run = test_store_add_flag };
1459
+
{ name = "store_remove_flag"; category = "Store"; run = test_store_remove_flag };
1460
+
{ name = "store_set_flags"; category = "Store"; run = test_store_set_flags };
1461
+
{ name = "uid_store"; category = "Store"; run = test_uid_store };
1462
+
{ name = "store_multiple_messages"; category = "Store"; run = test_store_multiple_messages };
1463
+
1464
+
(* Copy/Move Tests *)
1465
+
{ name = "copy_message"; category = "Copy"; run = test_copy_message };
1466
+
{ name = "move_message"; category = "Copy"; run = test_move_message };
1467
+
{ name = "expunge"; category = "Copy"; run = test_expunge };
1468
+
{ name = "uid_expunge"; category = "Copy"; run = test_uid_expunge };
1469
+
{ name = "copy_multiple_messages"; category = "Copy"; run = test_copy_multiple_messages };
1470
+
{ name = "expunge_multiple"; category = "Copy"; run = test_expunge_multiple };
1471
+
1472
+
(* Search Tests (RFC 9051 Section 6.4.4) *)
1473
+
{ name = "search_all"; category = "Search"; run = test_search_all };
1474
+
{ name = "search_unseen"; category = "Search"; run = test_search_unseen };
1475
+
{ name = "search_subject"; category = "Search"; run = test_search_subject };
1476
+
{ name = "search_from"; category = "Search"; run = test_search_from };
1477
+
{ name = "search_to"; category = "Search"; run = test_search_to };
1478
+
{ name = "search_flagged"; category = "Search"; run = test_search_flagged };
1479
+
{ name = "search_deleted"; category = "Search"; run = test_search_deleted };
1480
+
{ name = "search_not"; category = "Search"; run = test_search_not };
1481
+
{ name = "search_or"; category = "Search"; run = test_search_or };
1482
+
{ name = "search_and"; category = "Search"; run = test_search_and };
1483
+
{ name = "search_larger"; category = "Search"; run = test_search_larger };
1484
+
{ name = "search_header"; category = "Search"; run = test_search_header };
1485
+
{ name = "search_text"; category = "Search"; run = test_search_text };
1486
+
{ name = "search_body"; category = "Search"; run = test_search_body };
1487
+
{ name = "uid_search"; category = "Search"; run = test_uid_search };
1488
+
{ name = "search_before"; category = "Search"; run = test_search_before };
1489
+
{ name = "search_since"; category = "Search"; run = test_search_since };
1490
+
{ name = "search_on"; category = "Search"; run = test_search_on };
1491
+
{ name = "search_smaller"; category = "Search"; run = test_search_smaller };
1492
+
{ name = "search_new"; category = "Search"; run = test_search_new };
1493
+
{ name = "search_old"; category = "Search"; run = test_search_old };
1494
+
{ name = "search_draft"; category = "Search"; run = test_search_draft };
1495
+
{ name = "search_undraft"; category = "Search"; run = test_search_undraft };
1496
+
{ name = "search_unanswered"; category = "Search"; run = test_search_unanswered };
1497
+
{ name = "search_unflagged"; category = "Search"; run = test_search_unflagged };
1498
+
{ name = "search_undeleted"; category = "Search"; run = test_search_undeleted };
1499
+
{ name = "search_sequence_set"; category = "Search"; run = test_search_sequence_set };
1500
+
{ name = "search_uid_set"; category = "Search"; run = test_search_uid_set };
1501
+
{ name = "search_complex_and"; category = "Search"; run = test_search_complex_and };
1502
+
{ name = "search_cc"; category = "Search"; run = test_search_cc };
1503
+
{ name = "search_bcc"; category = "Search"; run = test_search_bcc };
1504
+
1505
+
(* IDLE Tests *)
1506
+
{ name = "idle_timeout"; category = "IDLE"; run = test_idle_timeout };
1507
+
{ name = "idle_exists"; category = "IDLE"; run = test_idle_exists };
1508
+
1509
+
(* Extension Tests *)
1510
+
{ name = "id_extension"; category = "Extension"; run = test_id_extension };
1511
+
{ name = "namespace_extension"; category = "Extension"; run = test_namespace_extension };
1512
+
{ name = "enable_extension"; category = "Extension"; run = test_enable_extension };
1513
+
{ name = "special_use_list"; category = "Extension"; run = test_special_use_list };
1514
+
{ name = "sort_by_date"; category = "Extension"; run = test_sort_by_date };
1515
+
{ name = "condstore"; category = "Extension"; run = test_condstore };
1516
+
1517
+
(* Envelope Tests *)
1518
+
{ name = "envelope_multiple_addresses"; category = "Envelope"; run = test_envelope_multiple_addresses };
1519
+
{ name = "envelope_special_chars"; category = "Envelope"; run = test_envelope_special_chars };
1520
+
1521
+
(* Append Tests *)
1522
+
{ name = "append_with_flags"; category = "Append"; run = test_append_with_flags };
1523
+
{ name = "append_multiple"; category = "Append"; run = test_append_multiple };
1524
+
1525
+
(* Pool Tests *)
1526
+
{ name = "pool_acquire_release"; category = "Pool"; run = test_pool_acquire_release };
1527
+
{ name = "pool_with_client"; category = "Pool"; run = test_pool_with_client };
1528
+
1529
+
(* Error Tests *)
1530
+
{ name = "select_nonexistent"; category = "Error"; run = test_select_nonexistent };
1531
+
{ name = "wrong_state"; category = "Error"; run = test_wrong_state };
1532
+
]
1533
+
1534
+
let run_tests ~(config : Imaptest_config.t) =
1535
+
Imaptest_output.set_color config.color;
1536
+
Imaptest_output.print_config config;
1537
+
1538
+
(* Initialize random seed *)
1539
+
(match config.seed with
1540
+
| Some s -> Random.init s
1541
+
| None -> Random.self_init ());
1542
+
1543
+
(* Clean up any leftover test mailboxes first *)
1544
+
Eio_main.run @@ fun env ->
1545
+
Eio.Switch.run @@ fun sw ->
1546
+
(try
1547
+
let client = connect_and_login ~sw ~env ~config in
1548
+
cleanup_test_mailboxes client ~config;
1549
+
Imap.Client.logout client;
1550
+
Imap.Client.disconnect client
1551
+
with _ -> ());
1552
+
1553
+
let passed = ref 0 in
1554
+
let failed = ref 0 in
1555
+
let skipped = ref 0 in
1556
+
1557
+
(* Group tests by category *)
1558
+
let categories = List.sort_uniq compare (List.map (fun t -> t.category) all_tests) in
1559
+
1560
+
List.iter (fun category ->
1561
+
Imaptest_output.print_header (Printf.sprintf "%s Tests" category);
1562
+
let tests = List.filter (fun t -> t.category = category) all_tests in
1563
+
List.iter (fun test ->
1564
+
Eio_main.run @@ fun env ->
1565
+
Eio.Switch.run @@ fun sw ->
1566
+
let result, duration = timed (fun () ->
1567
+
run_test (fun () -> test.run ~sw ~env ~config ())
1568
+
) in
1569
+
match result with
1570
+
| Pass ->
1571
+
incr passed;
1572
+
Imaptest_output.print_test_result ~name:test.name ~passed:true ~duration
1573
+
| Skip reason ->
1574
+
incr skipped;
1575
+
Imaptest_output.print_test_skipped ~name:test.name ~reason
1576
+
| Fail msg when String.length msg > 5 && String.sub msg 0 5 = "SKIP:" ->
1577
+
incr skipped;
1578
+
Imaptest_output.print_test_skipped ~name:test.name ~reason:(String.sub msg 5 (String.length msg - 5))
1579
+
| Fail msg ->
1580
+
incr failed;
1581
+
Imaptest_output.print_test_result ~name:test.name ~passed:false ~duration;
1582
+
if config.verbose then
1583
+
Imaptest_output.print_error msg
1584
+
) tests
1585
+
) categories;
1586
+
1587
+
Imaptest_output.print_summary ~passed:!passed ~failed:!failed ~skipped:!skipped;
1588
+
1589
+
(* Final cleanup *)
1590
+
Eio_main.run @@ fun env ->
1591
+
Eio.Switch.run @@ fun sw ->
1592
+
(try
1593
+
let client = connect_and_login ~sw ~env ~config in
1594
+
cleanup_test_mailboxes client ~config;
1595
+
Imap.Client.logout client;
1596
+
Imap.Client.disconnect client
1597
+
with _ -> ());
1598
+
1599
+
!failed = 0
1600
+
+19
test/integration/imaptest_scripted_main.ml
+19
test/integration/imaptest_scripted_main.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Main entry point for standalone scripted test runner *)
7
+
8
+
let () =
9
+
Mirage_crypto_rng_unix.use_default ();
10
+
let open Cmdliner in
11
+
let doc = "Run IMAP integration tests (scripted)" in
12
+
let info = Cmd.info "imaptest-scripted" ~version:"0.1.0" ~doc in
13
+
let run config = Imaptest_scripted.run_tests ~config in
14
+
let cmd = Cmd.v info Term.(const run $ Imaptest_config.config_term) in
15
+
let result = Cmd.eval_value cmd in
16
+
match result with
17
+
| Ok (`Ok success) -> exit (if success then 0 else 1)
18
+
| Ok `Version | Ok `Help -> exit 0
19
+
| Error _ -> exit 1
+215
test/integration/imaptest_state.ml
+215
test/integration/imaptest_state.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** State tracking for IMAP integration tests
7
+
8
+
Tracks server state to detect violations such as:
9
+
- Sequence-to-UID mapping changes
10
+
- Flag atomicity violations
11
+
- Metadata immutability violations
12
+
- UIDVALIDITY changes
13
+
- Message count mismatches *)
14
+
15
+
(** State of a single message *)
16
+
type message_state = {
17
+
seq : int;
18
+
uid : int64;
19
+
flags : Imap.Flag.t list;
20
+
envelope_hash : string option; (** SHA256 hash for immutability checking *)
21
+
}
22
+
23
+
(** State violation types *)
24
+
type violation =
25
+
| Sequence_mismatch of { expected : int; got : int; uid : int64 }
26
+
| Flag_atomicity_violation of { uid : int64; expected : Imap.Flag.t list; got : Imap.Flag.t list }
27
+
| Metadata_changed of { uid : int64; field : string }
28
+
| Uidvalidity_changed of { mailbox : string; old_value : int64; new_value : int64 }
29
+
| Message_disappeared of { uid : int64 }
30
+
| Unexpected_message of { uid : int64 }
31
+
| Count_mismatch of { expected : int; got : int }
32
+
33
+
let pp_violation fmt = function
34
+
| Sequence_mismatch { expected; got; uid } ->
35
+
Format.fprintf fmt "Sequence mismatch for UID %Ld: expected %d, got %d" uid expected got
36
+
| Flag_atomicity_violation { uid; expected; got } ->
37
+
let pp_flags = Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") Imap.Flag.pp in
38
+
Format.fprintf fmt "Flag atomicity violation for UID %Ld: expected [%a], got [%a]"
39
+
uid pp_flags expected pp_flags got
40
+
| Metadata_changed { uid; field } ->
41
+
Format.fprintf fmt "Metadata changed for UID %Ld: %s" uid field
42
+
| Uidvalidity_changed { mailbox; old_value; new_value } ->
43
+
Format.fprintf fmt "UIDVALIDITY changed for mailbox %s: %Ld -> %Ld" mailbox old_value new_value
44
+
| Message_disappeared { uid } ->
45
+
Format.fprintf fmt "Message disappeared: UID %Ld" uid
46
+
| Unexpected_message { uid } ->
47
+
Format.fprintf fmt "Unexpected message appeared: UID %Ld" uid
48
+
| Count_mismatch { expected; got } ->
49
+
Format.fprintf fmt "Message count mismatch: expected %d, got %d" expected got
50
+
51
+
let violation_to_string v =
52
+
Format.asprintf "%a" pp_violation v
53
+
54
+
(** Mailbox state *)
55
+
type mailbox_state = {
56
+
name : string;
57
+
uidvalidity : int64;
58
+
messages : (int64, message_state) Hashtbl.t; (** UID -> message_state *)
59
+
mutable exists : int;
60
+
}
61
+
62
+
(** Overall tracker state *)
63
+
type t = {
64
+
mailboxes : (string, mailbox_state) Hashtbl.t;
65
+
mutable violations : violation list;
66
+
verbose : bool;
67
+
}
68
+
69
+
(** Create a new state tracker *)
70
+
let create ?(verbose=false) () = {
71
+
mailboxes = Hashtbl.create 16;
72
+
violations = [];
73
+
verbose;
74
+
}
75
+
76
+
(** Hash an envelope for immutability checking *)
77
+
let hash_envelope (env : Imap.Envelope.t) : string =
78
+
(* Use a simple string representation as a hash *)
79
+
Format.asprintf "%a" Imap.Envelope.pp env
80
+
81
+
(** Record a violation *)
82
+
let record_violation t v =
83
+
t.violations <- v :: t.violations;
84
+
if t.verbose then
85
+
Printf.eprintf "State violation: %s\n%!" (violation_to_string v)
86
+
87
+
(** Initialize or update mailbox state after SELECT/EXAMINE *)
88
+
let update_mailbox t (info : Imap.Client.mailbox_info) =
89
+
match Hashtbl.find_opt t.mailboxes info.name with
90
+
| Some existing ->
91
+
if existing.uidvalidity <> info.uidvalidity then begin
92
+
record_violation t (Uidvalidity_changed {
93
+
mailbox = info.name;
94
+
old_value = existing.uidvalidity;
95
+
new_value = info.uidvalidity;
96
+
});
97
+
(* Reset state since UIDVALIDITY changed *)
98
+
Hashtbl.clear existing.messages;
99
+
existing.exists <- info.exists
100
+
end else
101
+
existing.exists <- info.exists
102
+
| None ->
103
+
let state = {
104
+
name = info.name;
105
+
uidvalidity = info.uidvalidity;
106
+
messages = Hashtbl.create 128;
107
+
exists = info.exists;
108
+
} in
109
+
Hashtbl.replace t.mailboxes info.name state
110
+
111
+
(** Update message state from FETCH response *)
112
+
let update_message t ~mailbox (msg : Imap.Client.message_info) =
113
+
match Hashtbl.find_opt t.mailboxes mailbox with
114
+
| None -> () (* Mailbox not tracked *)
115
+
| Some mbox_state ->
116
+
match msg.uid with
117
+
| None -> () (* No UID, can't track *)
118
+
| Some uid ->
119
+
let envelope_hash = Option.map hash_envelope msg.envelope in
120
+
let new_state = {
121
+
seq = msg.seq;
122
+
uid;
123
+
flags = Option.value ~default:[] msg.flags;
124
+
envelope_hash;
125
+
} in
126
+
(* Check for violations if we already have state for this message *)
127
+
(match Hashtbl.find_opt mbox_state.messages uid with
128
+
| Some old_state ->
129
+
(* Check envelope immutability *)
130
+
(match old_state.envelope_hash, envelope_hash with
131
+
| Some old_hash, Some new_hash when old_hash <> new_hash ->
132
+
record_violation t (Metadata_changed { uid; field = "envelope" })
133
+
| _ -> ())
134
+
| None -> ());
135
+
Hashtbl.replace mbox_state.messages uid new_state
136
+
137
+
(** Update multiple messages from FETCH response *)
138
+
let update_messages t ~mailbox (msgs : Imap.Client.message_info list) =
139
+
List.iter (update_message t ~mailbox) msgs
140
+
141
+
(** Check that expected flags are present (for atomicity testing) *)
142
+
let check_flags t ~mailbox ~uid ~expected_flags =
143
+
match Hashtbl.find_opt t.mailboxes mailbox with
144
+
| None -> true (* Mailbox not tracked *)
145
+
| Some mbox_state ->
146
+
match Hashtbl.find_opt mbox_state.messages uid with
147
+
| None -> true (* Message not tracked *)
148
+
| Some msg_state ->
149
+
let missing = List.filter (fun f -> not (List.mem f msg_state.flags)) expected_flags in
150
+
if missing <> [] then begin
151
+
record_violation t (Flag_atomicity_violation {
152
+
uid;
153
+
expected = expected_flags;
154
+
got = msg_state.flags;
155
+
});
156
+
false
157
+
end else
158
+
true
159
+
160
+
(** Get all recorded violations *)
161
+
let get_violations t = List.rev t.violations
162
+
163
+
(** Clear all violations *)
164
+
let clear_violations t = t.violations <- []
165
+
166
+
(** Get violation count *)
167
+
let violation_count t = List.length t.violations
168
+
169
+
(** Check message count against expectation *)
170
+
let check_count t ~mailbox ~expected =
171
+
match Hashtbl.find_opt t.mailboxes mailbox with
172
+
| None -> true
173
+
| Some mbox_state ->
174
+
if mbox_state.exists <> expected then begin
175
+
record_violation t (Count_mismatch { expected; got = mbox_state.exists });
176
+
false
177
+
end else
178
+
true
179
+
180
+
(** Verify that all tracked messages still exist *)
181
+
let verify_messages_exist t ~mailbox ~current_uids =
182
+
match Hashtbl.find_opt t.mailboxes mailbox with
183
+
| None -> true
184
+
| Some mbox_state ->
185
+
let all_ok = ref true in
186
+
Hashtbl.iter (fun uid _ ->
187
+
if not (List.mem uid current_uids) then begin
188
+
record_violation t (Message_disappeared { uid });
189
+
all_ok := false
190
+
end
191
+
) mbox_state.messages;
192
+
(* Check for unexpected messages *)
193
+
List.iter (fun uid ->
194
+
if not (Hashtbl.mem mbox_state.messages uid) then begin
195
+
record_violation t (Unexpected_message { uid });
196
+
all_ok := false
197
+
end
198
+
) current_uids;
199
+
!all_ok
200
+
201
+
(** Get tracked message count for a mailbox *)
202
+
let message_count t ~mailbox =
203
+
match Hashtbl.find_opt t.mailboxes mailbox with
204
+
| None -> 0
205
+
| Some mbox_state -> Hashtbl.length mbox_state.messages
206
+
207
+
(** Clear tracked state for a mailbox *)
208
+
let clear_mailbox t ~mailbox =
209
+
match Hashtbl.find_opt t.mailboxes mailbox with
210
+
| None -> ()
211
+
| Some mbox_state -> Hashtbl.clear mbox_state.messages
212
+
213
+
(** Remove a mailbox from tracking *)
214
+
let remove_mailbox t ~mailbox =
215
+
Hashtbl.remove t.mailboxes mailbox
+425
test/integration/imaptest_stress.ml
+425
test/integration/imaptest_stress.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Stress tests for IMAP client
7
+
8
+
Randomized tests that exercise the IMAP client under load,
9
+
with state tracking to detect protocol violations. *)
10
+
11
+
open Imaptest_utils
12
+
13
+
(** Command types for stress testing *)
14
+
type stress_command =
15
+
| Cmd_fetch_flags
16
+
| Cmd_fetch_envelope
17
+
| Cmd_store_add
18
+
| Cmd_store_remove
19
+
| Cmd_search_all
20
+
| Cmd_search_unseen
21
+
| Cmd_noop
22
+
| Cmd_status
23
+
24
+
let command_name = function
25
+
| Cmd_fetch_flags -> "FETCH FLAGS"
26
+
| Cmd_fetch_envelope -> "FETCH ENVELOPE"
27
+
| Cmd_store_add -> "STORE +FLAGS"
28
+
| Cmd_store_remove -> "STORE -FLAGS"
29
+
| Cmd_search_all -> "SEARCH ALL"
30
+
| Cmd_search_unseen -> "SEARCH UNSEEN"
31
+
| Cmd_noop -> "NOOP"
32
+
| Cmd_status -> "STATUS"
33
+
34
+
let random_command () =
35
+
match Random.int 8 with
36
+
| 0 -> Cmd_fetch_flags
37
+
| 1 -> Cmd_fetch_envelope
38
+
| 2 -> Cmd_store_add
39
+
| 3 -> Cmd_store_remove
40
+
| 4 -> Cmd_search_all
41
+
| 5 -> Cmd_search_unseen
42
+
| 6 -> Cmd_noop
43
+
| _ -> Cmd_status
44
+
45
+
(** Execute a single stress command *)
46
+
let execute_command client ~mailbox ~exists cmd =
47
+
if exists = 0 then begin
48
+
(* No messages, only do safe commands *)
49
+
match cmd with
50
+
| Cmd_search_all | Cmd_search_unseen ->
51
+
let _ = Imap.Client.search client Imap.Search.All in ()
52
+
| Cmd_noop ->
53
+
Imap.Client.noop client
54
+
| Cmd_status ->
55
+
let _ = Imap.Client.status client mailbox [Imap.Status.Messages] in ()
56
+
| _ ->
57
+
Imap.Client.noop client
58
+
end else begin
59
+
let seq_num = 1 + Random.int exists in
60
+
match cmd with
61
+
| Cmd_fetch_flags ->
62
+
let _ = Imap.Client.fetch client
63
+
~sequence:(Imap.Seq.single seq_num)
64
+
~items:[Imap.Fetch.Flags] () in ()
65
+
| Cmd_fetch_envelope ->
66
+
let _ = Imap.Client.fetch client
67
+
~sequence:(Imap.Seq.single seq_num)
68
+
~items:[Imap.Fetch.Envelope] () in ()
69
+
| Cmd_store_add ->
70
+
let _ = Imap.Client.store client
71
+
~sequence:(Imap.Seq.single seq_num)
72
+
~action:Imap.Store.Add
73
+
~flags:[Random_helpers.random_flag ()]
74
+
~silent:true () in ()
75
+
| Cmd_store_remove ->
76
+
let _ = Imap.Client.store client
77
+
~sequence:(Imap.Seq.single seq_num)
78
+
~action:Imap.Store.Remove
79
+
~flags:[Random_helpers.random_flag ()]
80
+
~silent:true () in ()
81
+
| Cmd_search_all ->
82
+
let _ = Imap.Client.search client Imap.Search.All in ()
83
+
| Cmd_search_unseen ->
84
+
let _ = Imap.Client.search client Imap.Search.Unseen in ()
85
+
| Cmd_noop ->
86
+
Imap.Client.noop client
87
+
| Cmd_status ->
88
+
let _ = Imap.Client.status client mailbox [Imap.Status.Messages] in ()
89
+
end
90
+
91
+
(** Statistics for stress testing *)
92
+
type stress_stats = {
93
+
mutable commands : int;
94
+
mutable errors : int;
95
+
mutable by_command : (stress_command * int) list;
96
+
}
97
+
98
+
let make_stats () = {
99
+
commands = 0;
100
+
errors = 0;
101
+
by_command = [];
102
+
}
103
+
104
+
let incr_command stats cmd =
105
+
stats.commands <- stats.commands + 1;
106
+
let current = try List.assoc cmd stats.by_command with Not_found -> 0 in
107
+
stats.by_command <- (cmd, current + 1) :: List.remove_assoc cmd stats.by_command
108
+
109
+
(** Single connection stress test *)
110
+
let run_single_stress ~sw ~env ~(config : Imaptest_config.t) =
111
+
Imaptest_output.set_color config.color;
112
+
Imaptest_output.print_config config;
113
+
Imaptest_output.print_header "Single Connection Stress Test";
114
+
115
+
(* Initialize random seed *)
116
+
(match config.seed with
117
+
| Some s -> Random.init s
118
+
| None -> Random.self_init ());
119
+
120
+
let state = Imaptest_state.create ~verbose:config.verbose () in
121
+
let stats = make_stats () in
122
+
123
+
(* Create test mailbox with some messages *)
124
+
let client = connect_and_login ~sw ~env ~config in
125
+
let mailbox = create_test_mailbox client ~config ~suffix:"stress" in
126
+
127
+
Fun.protect
128
+
~finally:(fun () ->
129
+
delete_mailbox_safe client mailbox;
130
+
(try Imap.Client.logout client with _ -> ());
131
+
try Imap.Client.disconnect client with _ -> ())
132
+
(fun () ->
133
+
(* Append some test messages *)
134
+
let num_messages = 10 in
135
+
Imaptest_output.print_verbose ~verbose:config.verbose
136
+
(Printf.sprintf "Creating %d test messages..." num_messages);
137
+
for i = 1 to num_messages do
138
+
let msg = make_test_message ~id:(Printf.sprintf "stress-%d" i)
139
+
~subject:(Printf.sprintf "Stress test message %d" i) in
140
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in
141
+
()
142
+
done;
143
+
144
+
(* Select and track state *)
145
+
let info = Imap.Client.select client mailbox in
146
+
Imaptest_state.update_mailbox state info;
147
+
148
+
let start_time = Unix.gettimeofday () in
149
+
let exists = ref info.exists in
150
+
151
+
Imaptest_output.print_verbose ~verbose:config.verbose
152
+
(Printf.sprintf "Running stress test for %.0f seconds..." config.duration);
153
+
154
+
while Unix.gettimeofday () -. start_time < config.duration do
155
+
let cmd = random_command () in
156
+
(try
157
+
execute_command client ~mailbox ~exists:!exists cmd;
158
+
incr_command stats cmd
159
+
with exn ->
160
+
stats.errors <- stats.errors + 1;
161
+
if config.verbose then
162
+
Imaptest_output.print_error
163
+
(Printf.sprintf "%s: %s" (command_name cmd) (Printexc.to_string exn)));
164
+
165
+
(* Periodically refresh state *)
166
+
if stats.commands mod 100 = 0 then begin
167
+
let info = Imap.Client.select client mailbox in
168
+
exists := info.exists;
169
+
Imaptest_state.update_mailbox state info;
170
+
Imaptest_output.print_progress stats.commands
171
+
(int_of_float config.duration * 10) (* approximate *)
172
+
end
173
+
done;
174
+
175
+
Imaptest_output.clear_progress ();
176
+
let duration = Unix.gettimeofday () -. start_time in
177
+
178
+
Imaptest_output.print_stress_stats
179
+
~commands:stats.commands
180
+
~errors:stats.errors
181
+
~violations:(Imaptest_state.violation_count state)
182
+
~duration;
183
+
184
+
(* Print violations if any *)
185
+
let violations = Imaptest_state.get_violations state in
186
+
if violations <> [] then begin
187
+
Imaptest_output.print_header "State Violations";
188
+
List.iter (fun v ->
189
+
Imaptest_output.print_violation (Imaptest_state.violation_to_string v)
190
+
) violations
191
+
end;
192
+
193
+
stats.errors = 0 && Imaptest_state.violation_count state = 0)
194
+
195
+
(** Multi-connection concurrent stress test *)
196
+
let run_concurrent_stress ~sw ~env ~(config : Imaptest_config.t) =
197
+
Imaptest_output.set_color config.color;
198
+
Imaptest_output.print_config config;
199
+
Imaptest_output.print_header "Concurrent Connection Stress Test";
200
+
201
+
(* Initialize random seed *)
202
+
(match config.seed with
203
+
| Some s -> Random.init s
204
+
| None -> Random.self_init ());
205
+
206
+
let state = Imaptest_state.create ~verbose:config.verbose () in
207
+
let total_commands = ref 0 in
208
+
let total_errors = ref 0 in
209
+
210
+
(* Create shared test mailbox *)
211
+
let client = connect_and_login ~sw ~env ~config in
212
+
let mailbox = create_test_mailbox client ~config ~suffix:"concurrent" in
213
+
214
+
(* Append some messages *)
215
+
let num_messages = 20 in
216
+
for i = 1 to num_messages do
217
+
let msg = make_test_message ~id:(Printf.sprintf "conc-%d" i)
218
+
~subject:(Printf.sprintf "Concurrent test message %d" i) in
219
+
let _ = Imap.Client.append client ~mailbox ~message:msg () in
220
+
()
221
+
done;
222
+
Imap.Client.logout client;
223
+
Imap.Client.disconnect client;
224
+
225
+
Fun.protect
226
+
~finally:(fun () ->
227
+
(* Cleanup *)
228
+
Eio.Switch.run @@ fun cleanup_sw ->
229
+
try
230
+
let cleanup_client = connect_and_login ~sw:cleanup_sw ~env ~config in
231
+
delete_mailbox_safe cleanup_client mailbox;
232
+
Imap.Client.logout cleanup_client;
233
+
Imap.Client.disconnect cleanup_client
234
+
with _ -> ())
235
+
(fun () ->
236
+
let start_time = Unix.gettimeofday () in
237
+
238
+
(* Spawn concurrent workers *)
239
+
let workers = Array.init config.num_connections (fun worker_id ->
240
+
let stats = make_stats () in
241
+
(worker_id, stats)
242
+
) in
243
+
244
+
let run_worker (worker_id, stats) =
245
+
Eio.Switch.run @@ fun worker_sw ->
246
+
let worker_client = connect_and_login ~sw:worker_sw ~env ~config in
247
+
Fun.protect
248
+
~finally:(fun () ->
249
+
(try Imap.Client.logout worker_client with _ -> ());
250
+
try Imap.Client.disconnect worker_client with _ -> ())
251
+
(fun () ->
252
+
let info = Imap.Client.select worker_client mailbox in
253
+
let exists = ref info.exists in
254
+
255
+
while Unix.gettimeofday () -. start_time < config.duration do
256
+
let cmd = random_command () in
257
+
(try
258
+
execute_command worker_client ~mailbox ~exists:!exists cmd;
259
+
incr_command stats cmd
260
+
with _ ->
261
+
stats.errors <- stats.errors + 1);
262
+
263
+
(* Occasionally re-select to refresh state *)
264
+
if stats.commands mod 50 = 0 then begin
265
+
let info = Imap.Client.select worker_client mailbox in
266
+
exists := info.exists
267
+
end
268
+
done;
269
+
270
+
if config.verbose then
271
+
Printf.printf "Worker %d: %d commands, %d errors\n%!"
272
+
worker_id stats.commands stats.errors)
273
+
in
274
+
275
+
(* Run all workers concurrently *)
276
+
Eio.Fiber.all (Array.to_list (Array.map (fun w () -> run_worker w) workers));
277
+
278
+
(* Aggregate stats *)
279
+
Array.iter (fun (_, stats) ->
280
+
total_commands := !total_commands + stats.commands;
281
+
total_errors := !total_errors + stats.errors
282
+
) workers;
283
+
284
+
let duration = Unix.gettimeofday () -. start_time in
285
+
286
+
Imaptest_output.print_stress_stats
287
+
~commands:!total_commands
288
+
~errors:!total_errors
289
+
~violations:(Imaptest_state.violation_count state)
290
+
~duration;
291
+
292
+
!total_errors = 0 && Imaptest_state.violation_count state = 0)
293
+
294
+
(** Flag atomicity test - concurrent flag modifications *)
295
+
let run_atomicity_test ~sw ~env ~(config : Imaptest_config.t) =
296
+
Imaptest_output.set_color config.color;
297
+
Imaptest_output.print_header "Flag Atomicity Test";
298
+
299
+
let state = Imaptest_state.create ~verbose:config.verbose () in
300
+
301
+
(* Create test mailbox with one message *)
302
+
let client = connect_and_login ~sw ~env ~config in
303
+
let mailbox = create_test_mailbox client ~config ~suffix:"atomicity" in
304
+
305
+
Fun.protect
306
+
~finally:(fun () ->
307
+
delete_mailbox_safe client mailbox;
308
+
(try Imap.Client.logout client with _ -> ());
309
+
try Imap.Client.disconnect client with _ -> ())
310
+
(fun () ->
311
+
let _ = Imap.Client.append client ~mailbox ~message:test_message () in
312
+
Imap.Client.logout client;
313
+
Imap.Client.disconnect client;
314
+
315
+
(* Two connections modifying flags concurrently *)
316
+
let errors = ref 0 in
317
+
318
+
Eio.Fiber.both
319
+
(fun () ->
320
+
Eio.Switch.run @@ fun s1 ->
321
+
let c1 = connect_and_login ~sw:s1 ~env ~config in
322
+
Fun.protect
323
+
~finally:(fun () ->
324
+
(try Imap.Client.logout c1 with _ -> ());
325
+
try Imap.Client.disconnect c1 with _ -> ())
326
+
(fun () ->
327
+
let _ = Imap.Client.select c1 mailbox in
328
+
for _ = 1 to 50 do
329
+
(try
330
+
let _ = Imap.Client.store c1 ~sequence:(Imap.Seq.single 1)
331
+
~action:Imap.Store.Add
332
+
~flags:[Imap.Flag.System Imap.Flag.Seen]
333
+
~silent:true () in ()
334
+
with _ -> incr errors)
335
+
done))
336
+
(fun () ->
337
+
Eio.Switch.run @@ fun s2 ->
338
+
let c2 = connect_and_login ~sw:s2 ~env ~config in
339
+
Fun.protect
340
+
~finally:(fun () ->
341
+
(try Imap.Client.logout c2 with _ -> ());
342
+
try Imap.Client.disconnect c2 with _ -> ())
343
+
(fun () ->
344
+
let _ = Imap.Client.select c2 mailbox in
345
+
for _ = 1 to 50 do
346
+
(try
347
+
let _ = Imap.Client.store c2 ~sequence:(Imap.Seq.single 1)
348
+
~action:Imap.Store.Add
349
+
~flags:[Imap.Flag.System Imap.Flag.Flagged]
350
+
~silent:true () in ()
351
+
with _ -> incr errors)
352
+
done));
353
+
354
+
(* Verify final state *)
355
+
Eio.Switch.run @@ fun verify_sw ->
356
+
let verify_client = connect_and_login ~sw:verify_sw ~env ~config in
357
+
let _ = Imap.Client.select verify_client mailbox in
358
+
let msgs = Imap.Client.fetch verify_client
359
+
~sequence:(Imap.Seq.single 1)
360
+
~items:[Imap.Fetch.Flags] () in
361
+
Imap.Client.logout verify_client;
362
+
Imap.Client.disconnect verify_client;
363
+
364
+
match msgs with
365
+
| [msg] ->
366
+
let flags = Option.value ~default:[] msg.flags in
367
+
let has_seen = List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Seen) flags in
368
+
let has_flagged = List.exists (fun f -> f = Imap.Flag.System Imap.Flag.Flagged) flags in
369
+
if not has_seen || not has_flagged then begin
370
+
Imaptest_state.record_violation state
371
+
(Imaptest_state.Flag_atomicity_violation {
372
+
uid = 0L;
373
+
expected = [Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Flagged];
374
+
got = flags;
375
+
})
376
+
end;
377
+
Imaptest_output.print_test_result ~name:"flag atomicity"
378
+
~passed:(!errors = 0 && has_seen && has_flagged) ~duration:0.0;
379
+
!errors = 0 && Imaptest_state.violation_count state = 0
380
+
| _ ->
381
+
Imaptest_output.print_test_result ~name:"flag atomicity" ~passed:false ~duration:0.0;
382
+
false)
383
+
384
+
(** Run all stress tests *)
385
+
let run_stress ~(config : Imaptest_config.t) =
386
+
Imaptest_output.set_color config.color;
387
+
388
+
let results = ref [] in
389
+
390
+
(* Single connection stress *)
391
+
Eio_main.run @@ fun env ->
392
+
Eio.Switch.run @@ fun sw ->
393
+
let r1 = run_single_stress ~sw ~env ~config in
394
+
results := ("Single connection stress", r1) :: !results;
395
+
396
+
(* Concurrent stress *)
397
+
Eio_main.run @@ fun env ->
398
+
Eio.Switch.run @@ fun sw ->
399
+
let r2 = run_concurrent_stress ~sw ~env ~config in
400
+
results := ("Concurrent stress", r2) :: !results;
401
+
402
+
(* Atomicity test *)
403
+
Eio_main.run @@ fun env ->
404
+
Eio.Switch.run @@ fun sw ->
405
+
let r3 = run_atomicity_test ~sw ~env ~config in
406
+
results := ("Flag atomicity", r3) :: !results;
407
+
408
+
(* Summary *)
409
+
Imaptest_output.print_header "Stress Test Summary";
410
+
let passed = List.filter (fun (_, r) -> r) !results in
411
+
let failed = List.filter (fun (_, r) -> not r) !results in
412
+
List.iter (fun (name, _) ->
413
+
Imaptest_output.print_test_result ~name ~passed:true ~duration:0.0
414
+
) passed;
415
+
List.iter (fun (name, _) ->
416
+
Imaptest_output.print_test_result ~name ~passed:false ~duration:0.0
417
+
) failed;
418
+
419
+
Imaptest_output.print_summary
420
+
~passed:(List.length passed)
421
+
~failed:(List.length failed)
422
+
~skipped:0;
423
+
424
+
List.length failed = 0
425
+
+19
test/integration/imaptest_stress_main.ml
+19
test/integration/imaptest_stress_main.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Main entry point for standalone stress test runner *)
7
+
8
+
let () =
9
+
Mirage_crypto_rng_unix.use_default ();
10
+
let open Cmdliner in
11
+
let doc = "Run IMAP stress tests" in
12
+
let info = Cmd.info "imaptest-stress" ~version:"0.1.0" ~doc in
13
+
let run config = Imaptest_stress.run_stress ~config in
14
+
let cmd = Cmd.v info Term.(const run $ Imaptest_config.config_term) in
15
+
let result = Cmd.eval_value cmd in
16
+
match result with
17
+
| Ok (`Ok success) -> exit (if success then 0 else 1)
18
+
| Ok `Version | Ok `Help -> exit 0
19
+
| Error _ -> exit 1
+217
test/integration/imaptest_utils.ml
+217
test/integration/imaptest_utils.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test utilities for IMAP integration tests *)
7
+
8
+
(** RFC 5322 compliant test email *)
9
+
let test_message =
10
+
String.concat "\r\n" [
11
+
"From: Test Sender <test@example.com>";
12
+
"To: Test Recipient <recipient@example.com>";
13
+
"Subject: Test Message";
14
+
"Date: Mon, 1 Jan 2024 12:00:00 +0000";
15
+
"Message-ID: <test@example.com>";
16
+
"MIME-Version: 1.0";
17
+
"Content-Type: text/plain; charset=UTF-8";
18
+
"";
19
+
"This is a test message for IMAP integration testing.";
20
+
"";
21
+
"It contains multiple lines to test body handling.";
22
+
""
23
+
]
24
+
25
+
(** Generate a test message with a unique identifier *)
26
+
let make_test_message ~id ~subject =
27
+
String.concat "\r\n" [
28
+
"From: Test Sender <test@example.com>";
29
+
"To: Test Recipient <recipient@example.com>";
30
+
Printf.sprintf "Subject: %s" subject;
31
+
"Date: Mon, 1 Jan 2024 12:00:00 +0000";
32
+
Printf.sprintf "Message-ID: <%s@imaptest.example.com>" id;
33
+
"MIME-Version: 1.0";
34
+
"Content-Type: text/plain; charset=UTF-8";
35
+
Printf.sprintf "X-Test-ID: %s" id;
36
+
"";
37
+
Printf.sprintf "This is test message %s." id;
38
+
"Generated by imaptest integration test suite.";
39
+
""
40
+
]
41
+
42
+
(** Generate a unique test mailbox name *)
43
+
let make_test_mailbox_name ~(config : Imaptest_config.t) ~suffix =
44
+
Printf.sprintf "%s%s-%d" config.mailbox_prefix suffix (Random.bits () land 0xFFFF)
45
+
46
+
(** Create a test mailbox and return its name *)
47
+
let create_test_mailbox client ~(config : Imaptest_config.t) ~suffix =
48
+
let name = make_test_mailbox_name ~config ~suffix in
49
+
Imap.Client.create client name;
50
+
name
51
+
52
+
(** Delete a mailbox if it exists, ignoring errors *)
53
+
let delete_mailbox_safe client name =
54
+
try
55
+
Imap.Client.delete client name
56
+
with _ -> ()
57
+
58
+
(** Clean up all test mailboxes matching the prefix *)
59
+
let cleanup_test_mailboxes client ~(config : Imaptest_config.t) =
60
+
try
61
+
let pattern = config.mailbox_prefix ^ "*" in
62
+
let mailboxes = Imap.Client.list client ~reference:"" ~pattern in
63
+
List.iter (fun (entry : Imap.Client.list_entry) ->
64
+
delete_mailbox_safe client entry.name
65
+
) mailboxes
66
+
with _ -> ()
67
+
68
+
(** Connect to the IMAP server *)
69
+
let connect ~sw ~env ~(config : Imaptest_config.t) =
70
+
Imap.Client.connect ~sw ~env ~host:config.host ~port:config.port ()
71
+
72
+
(** Connect and authenticate *)
73
+
let connect_and_login ~sw ~env ~(config : Imaptest_config.t) =
74
+
let client = connect ~sw ~env ~config in
75
+
Imap.Client.login client ~username:config.username ~password:config.password;
76
+
(* Ensure capabilities are populated for has_capability checks *)
77
+
ignore (Imap.Client.capability client);
78
+
client
79
+
80
+
(** Run a test with setup and teardown *)
81
+
let with_test_setup ~sw ~env ~(config : Imaptest_config.t) f =
82
+
let client = connect_and_login ~sw ~env ~config in
83
+
Fun.protect
84
+
~finally:(fun () ->
85
+
(try Imap.Client.logout client with _ -> ());
86
+
try Imap.Client.disconnect client with _ -> ())
87
+
(fun () -> f client)
88
+
89
+
(** Run a test with a fresh test mailbox *)
90
+
let with_test_mailbox ~sw ~env ~(config : Imaptest_config.t) ~suffix f =
91
+
with_test_setup ~sw ~env ~config (fun client ->
92
+
let mailbox = create_test_mailbox client ~config ~suffix in
93
+
Fun.protect
94
+
~finally:(fun () -> delete_mailbox_safe client mailbox)
95
+
(fun () -> f client mailbox))
96
+
97
+
(** Run a test with multiple connections *)
98
+
let with_connections ~sw ~env ~(config : Imaptest_config.t) ~count f =
99
+
let clients = Array.init count (fun _ ->
100
+
connect_and_login ~sw ~env ~config
101
+
) in
102
+
Fun.protect
103
+
~finally:(fun () ->
104
+
Array.iter (fun client ->
105
+
(try Imap.Client.logout client with _ -> ());
106
+
try Imap.Client.disconnect client with _ -> ()
107
+
) clients)
108
+
(fun () -> f clients)
109
+
110
+
(** Time a function and return its result and duration *)
111
+
let timed f =
112
+
let start = Unix.gettimeofday () in
113
+
let result = f () in
114
+
let duration = Unix.gettimeofday () -. start in
115
+
(result, duration)
116
+
117
+
(** Run a function with a timeout, returning None if it times out *)
118
+
let with_timeout ~env ~timeout_sec f =
119
+
match Eio.Time.with_timeout (Eio.Stdenv.clock env) timeout_sec (fun () -> Ok (f ())) with
120
+
| Ok result -> Some result
121
+
| Error `Timeout -> None
122
+
123
+
(** Test result type *)
124
+
type test_result =
125
+
| Pass
126
+
| Fail of string
127
+
| Skip of string
128
+
129
+
(** Run a test and catch exceptions *)
130
+
let run_test f =
131
+
try
132
+
f ();
133
+
Pass
134
+
with
135
+
| Failure msg when String.length msg > 5 && String.sub msg 0 5 = "SKIP:" ->
136
+
Skip (String.sub msg 6 (String.length msg - 6))
137
+
| Eio.Exn.Io _ as exn ->
138
+
(match Imap.Error.of_eio_exn exn with
139
+
| Some err -> Fail (Imap.Error.to_string err)
140
+
| None -> Fail (Printexc.to_string exn))
141
+
| Failure msg -> Fail msg
142
+
| exn ->
143
+
Fail (Printexc.to_string exn)
144
+
145
+
(** Check if a capability is present *)
146
+
let has_capability client cap =
147
+
Imap.Client.has_capability client cap
148
+
149
+
(** Skip if capability is missing *)
150
+
let require_capability client cap =
151
+
if not (has_capability client cap) then
152
+
raise (Failure (Printf.sprintf "Missing required capability: %s" cap))
153
+
154
+
(** Compare flag lists (order-independent) *)
155
+
let flags_equal f1 f2 =
156
+
let sort_flags = List.sort compare in
157
+
sort_flags f1 = sort_flags f2
158
+
159
+
(** Assert a condition *)
160
+
let assert_true msg cond =
161
+
if not cond then raise (Failure msg)
162
+
163
+
(** Assert equality *)
164
+
let assert_equal ~pp ~msg expected actual =
165
+
if expected <> actual then
166
+
raise (Failure (Printf.sprintf "%s: expected %s, got %s" msg (pp expected) (pp actual)))
167
+
168
+
(** Assert list length *)
169
+
let assert_length ~msg expected lst =
170
+
let actual = List.length lst in
171
+
if actual <> expected then
172
+
raise (Failure (Printf.sprintf "%s: expected length %d, got %d" msg expected actual))
173
+
174
+
(** Assert non-empty list *)
175
+
let assert_non_empty ~msg lst =
176
+
if lst = [] then
177
+
raise (Failure (Printf.sprintf "%s: expected non-empty list" msg))
178
+
179
+
(** Assert int64 option is Some *)
180
+
let assert_some_int64 ~msg = function
181
+
| Some v -> v
182
+
| None -> raise (Failure (Printf.sprintf "%s: expected Some, got None" msg))
183
+
184
+
(** Random helpers for stress testing *)
185
+
module Random_helpers = struct
186
+
(** Pick a random element from a list *)
187
+
let pick_random lst =
188
+
if lst = [] then None
189
+
else Some (List.nth lst (Random.int (List.length lst)))
190
+
191
+
(** Pick a random element, raising if empty *)
192
+
let pick_random_exn lst =
193
+
match pick_random lst with
194
+
| Some x -> x
195
+
| None -> raise (Failure "pick_random_exn: empty list")
196
+
197
+
(** Generate a random sequence range *)
198
+
let random_seq ~max_val =
199
+
let n = 1 + Random.int (min max_val 10) in
200
+
Imap.Seq.single n
201
+
202
+
(** Generate a random flag *)
203
+
let random_flag () =
204
+
match Random.int 5 with
205
+
| 0 -> Imap.Flag.System Imap.Flag.Seen
206
+
| 1 -> Imap.Flag.System Imap.Flag.Answered
207
+
| 2 -> Imap.Flag.System Imap.Flag.Flagged
208
+
| 3 -> Imap.Flag.System Imap.Flag.Draft
209
+
| _ -> Imap.Flag.Keyword "$TestFlag"
210
+
211
+
(** Generate a random store action *)
212
+
let random_store_action () =
213
+
match Random.int 3 with
214
+
| 0 -> Imap.Store.Set
215
+
| 1 -> Imap.Store.Add
216
+
| _ -> Imap.Store.Remove
217
+
end
+1
test/test_client.ml
+1
test/test_client.ml
+1
-1
test/test_read.ml
+1
-1
test/test_read.ml
···
55
55
56
56
let test_flag_keyword () =
57
57
let result = with_reader "$Forwarded " (fun r -> Imap.Read.flag r) in
58
-
Alcotest.(check flag_testable) "keyword" (Imap.Flag.Keyword "$Forwarded") result
58
+
Alcotest.(check flag_testable) "keyword" (Imap.Flag.Keyword "Forwarded") result
59
59
60
60
let test_flag_list () =
61
61
let result = with_reader "(\\Seen \\Answered) " (fun r -> Imap.Read.flag_list r) in
+5
-3
test/test_write.ml
+5
-3
test/test_write.ml
···
140
140
let result =
141
141
serialize (fun w ->
142
142
Imap.Write.command w ~tag:"A009"
143
-
(Imap.Command.Fetch { sequence = [ Imap.Seq.Range (1, 10) ]; items = [ Imap.Fetch.Uid; Imap.Fetch.Flags ] }))
143
+
(Imap.Command.Fetch { sequence = [ Imap.Seq.Range (1, 10) ]; items = [ Imap.Fetch.Uid; Imap.Fetch.Flags ]; changedsince = None }))
144
144
in
145
145
Alcotest.(check string) "fetch" "A009 FETCH 1:10 (UID FLAGS)\r\n" result
146
146
···
148
148
let result =
149
149
serialize (fun w ->
150
150
Imap.Write.command w ~tag:"A010"
151
-
(Imap.Command.Fetch { sequence = [ Imap.Seq.All ]; items = [ Imap.Fetch.Envelope ] }))
151
+
(Imap.Command.Fetch { sequence = [ Imap.Seq.All ]; items = [ Imap.Fetch.Envelope ]; changedsince = None }))
152
152
in
153
153
Alcotest.(check string) "fetch single" "A010 FETCH * ENVELOPE\r\n" result
154
154
···
162
162
silent = false;
163
163
action = Imap.Store.Add;
164
164
flags = [ Imap.Flag.System Imap.Flag.Seen ];
165
+
unchangedsince = None;
165
166
}))
166
167
in
167
168
Alcotest.(check string) "store" "A011 STORE 1:5 +FLAGS (\\Seen)\r\n" result
···
176
177
silent = true;
177
178
action = Imap.Store.Remove;
178
179
flags = [ Imap.Flag.System Imap.Flag.Deleted ];
180
+
unchangedsince = None;
179
181
}))
180
182
in
181
183
Alcotest.(check string) "store silent"
···
216
218
let result =
217
219
serialize (fun w ->
218
220
Imap.Write.command w ~tag:"A016"
219
-
(Imap.Command.Uid (Uid_fetch { sequence = [ Imap.Seq.Range (100, 200) ]; items = [ Imap.Fetch.Flags ] })))
221
+
(Imap.Command.Uid (Uid_fetch { sequence = [ Imap.Seq.Range (100, 200) ]; items = [ Imap.Fetch.Flags ]; changedsince = None })))
220
222
in
221
223
Alcotest.(check string) "uid fetch" "A016 UID FETCH 100:200 FLAGS\r\n" result
222
224