1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Test
exception Dummy_error
let suite = suite "lwt_pool" [
test "basic create-use" begin fun () ->
let gen = fun () -> Lwt.return_unit in
let p = Lwt_pool.create 1 gen in
Lwt.return (Lwt.state (Lwt_pool.use p Lwt.return) = Lwt.Return ())
end;
test "creator exception" begin fun () ->
let gen = fun () -> raise Dummy_error in
let p = Lwt_pool.create 1 gen in
let u = Lwt_pool.use p (fun _ -> Lwt.return 0) in
Lwt.return (Lwt.state u = Lwt.Fail Dummy_error)
end;
test "pool elements are reused" begin fun () ->
let gen = (fun () -> let n = ref 0 in Lwt.return n) in
let p = Lwt_pool.create 1 gen in
let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.return !n) in
let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in
Lwt.return (Lwt.state u2 = Lwt.Return 1)
end;
test "pool elements are validated when returned" begin fun () ->
let gen = (fun () -> let n = ref 0 in Lwt.return n) in
let v l = Lwt.return (!l = 0) in
let p = Lwt_pool.create 1 ~validate:v gen in
let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.return !n) in
let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in
Lwt.return (Lwt.state u2 = Lwt.Return 0)
end;
test "validation exceptions are propagated to users" begin fun () ->
let c = Lwt_condition.create () in
let gen = (fun () -> let l = ref 0 in Lwt.return l) in
let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in
let p = Lwt_pool.create 1 ~validate:v gen in
let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in
let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let () = Lwt_condition.signal c "done" in
Lwt.bind u1 (fun v1 ->
Lwt.try_bind
(fun () -> u2)
(fun _ -> Lwt.return_false)
(fun exn2 ->
Lwt.return (v1 = "done" && exn2 = Dummy_error)))
end;
test "multiple creation" begin fun () ->
let gen = (fun () -> let n = ref 0 in Lwt.return n) in
let p = Lwt_pool.create 2 gen in
let _ = Lwt_pool.use p (fun n -> n := 1; Lwt.pause ()) in
let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in
Lwt.return (Lwt.state u2 = Lwt.Return 0)
end;
test "users of an empty pool will wait" begin fun () ->
let gen = (fun () -> Lwt.return 0) in
let p = Lwt_pool.create 1 gen in
let _ = Lwt_pool.use p (fun _ -> Lwt.pause ()) in
let u2 = Lwt_pool.use p Lwt.return in
Lwt.return (Lwt.state u2 = Lwt.Sleep)
end;
test "on check, good elements are retained" begin fun () ->
let gen = (fun () -> let n = ref 1 in Lwt.return n) in
let c = (fun x f -> f (!x > 0)) in
let p = Lwt_pool.create 1 ~check: c gen in
let _ = Lwt_pool.use p (fun n -> n := 2; Lwt.fail Dummy_error) in
let u2 = Lwt_pool.use p (fun n -> Lwt.return !n) in
Lwt.return (Lwt.state u2 = Lwt.Return 2)
end;
test "on check, bad elements are disposed of and replaced" begin fun () ->
let gen = (fun () -> let n = ref 1 in Lwt.return n) in
let check = (fun n f -> f (!n > 0)) in
let disposed = ref false in
let dispose _ = disposed := true; Lwt.return_unit in
let p = Lwt_pool.create 1 ~check ~dispose gen in
let task = (fun n -> incr n; Lwt.return !n) in
let _ = Lwt_pool.use p (fun n -> n := 0; Lwt.fail Dummy_error) in
let u2 = Lwt_pool.use p task in
Lwt.return (Lwt.state u2 = Lwt.Return 2 && !disposed)
end;
test "clear disposes of all elements" begin fun () ->
let gen = (fun () -> let n = ref 1 in Lwt.return n) in
let count = ref 0 in
let dispose _ = incr count; Lwt.return_unit in
let p = Lwt_pool.create 2 ~dispose gen in
let u = Lwt_pool.use p (fun _ -> Lwt.pause ()) in
let _ = Lwt_pool.use p (fun _ -> Lwt.return_unit) in
let _ = Lwt_pool.clear p in
Lwt.bind u (fun () -> Lwt.return (!count = 2))
end;
test "waiter are notified on replacement" begin fun () ->
let c = Lwt_condition.create () in
let gen = (fun () -> let l = ref 0 in Lwt.return l) in
let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in
let p = Lwt_pool.create 1 ~validate:v gen in
let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in
let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let () = Lwt_condition.signal c "done" in
Lwt.bind u1 (fun v1 ->
Lwt.bind u3 (fun v3 ->
Lwt.try_bind
(fun () -> u2)
(fun _ -> Lwt.return_false)
(fun exn2 ->
Lwt.return (v1 = "done" && exn2 = Dummy_error && v3 = 0))))
end;
test "waiter are notified on replacement exception" begin fun () ->
let c = Lwt_condition.create () in
let k = ref true in
let gen = fun () ->
if !k then
let l = ref 0 in Lwt.return l
else
raise Dummy_error
in
let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in
let p = Lwt_pool.create 1 ~validate:v gen in
let u1 = Lwt_pool.use p (fun l -> l := 1; k:= false; Lwt_condition.wait c) in
let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let () = Lwt_condition.signal c "done" in
Lwt.bind u1 (fun v1 ->
Lwt.try_bind
(fun () -> u2)
(fun _ -> Lwt.return_false)
(fun exn2 ->
Lwt.try_bind
(fun () -> u3)
(fun _ -> Lwt.return_false)
(fun exn3 ->
Lwt.return
(v1 = "done" && exn2 = Dummy_error && exn3 = Dummy_error))))
end;
test "check and validate can be used together" begin fun () ->
let gen = (fun () -> let l = ref 0 in Lwt.return l) in
let v l = Lwt.return (!l > 0) in
let c l f = f (!l > 1) in
let cond = Lwt_condition.create() in
let p = Lwt_pool.create 1 ~validate:v ~check:c gen in
let _ = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait cond) in
let _ = Lwt_pool.use p (fun l -> l := 2; raise Dummy_error) in
let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let () = Lwt_condition.signal cond "done" in
Lwt.bind u3 (fun v ->
Lwt.return (v = 2))
end;
test "verify default check behavior" begin fun () ->
let gen = (fun () -> let l = ref 0 in Lwt.return l) in
let cond = Lwt_condition.create() in
let p = Lwt_pool.create 1 gen in
let _ = Lwt_pool.use p (fun l ->
Lwt.bind (Lwt_condition.wait cond)
(fun _ -> l:= 1; raise Dummy_error)) in
let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in
let () = Lwt_condition.signal cond "done" in
Lwt.bind u2 (fun v ->
Lwt.return (v = 1))
end;
]
|
