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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
type 'a ty = string -> ('a, string) result
type 'a t = (string, string) Hashtbl.t -> ('a, (string * string) list) result
let error_expected_bool = "error.expected.bool"
let error_expected_char = "error.expected.char"
let error_expected_single = "error.expected.single"
let error_expected_int = "error.expected.int"
let error_expected_int32 = "error.expected.int32"
let error_expected_int64 = "error.expected.int64"
let error_expected_number = "error.expected.number"
let error_expected_time = "error.expected.time"
let error_length = "error.length"
let error_range = "error.range"
let error_required = "error.required"
let error name msg = Error [name, msg]
let ensure message condition field ty name values =
match field ty name values with
| Ok v as ok -> if condition v then ok else error name message
| Error _ as error -> error
let rec all ~min_length ~max_length ~len ty result = function
| [] ->
if len < min_length then
Error error_length
else
result
| x :: xs -> (
let new_len = succ len in
if new_len > max_length then
Error error_length
else
match ty x, result with
| Ok t, Ok r ->
all ~min_length ~max_length ~len:new_len ty (Ok (t :: r)) xs
| (Error _ as e), _ -> e
| _, (Error _ as e) -> e)
let all ~min_length ~max_length ty =
all ~min_length ~max_length ~len:0 ty (Ok [])
let list ?(min_length = 0) ?(max_length = Int.max_int) ty name values =
match all ~min_length ~max_length ty (Hashtbl.find_all values name) with
| Ok _ as ok -> ok
| Error msg -> error name msg
let optional ty name values =
match Hashtbl.find_opt values name with
| None -> Ok None
| Some s -> (
match ty s with
| Ok v -> Ok (Some v)
| Error msg -> error name msg)
let required ?default ty name values =
match Hashtbl.find_opt values name, default with
| None, None -> error name error_required
| None, Some v -> Ok v
| Some s, _ -> (
match ty s with
| Ok v -> Ok v
| Error msg -> error name msg)
let ok value _ = Ok value
let error name message _ = error name message
let ( let* ) form f values =
match form values with
| Ok v -> f v values
| Error _ as e -> e
let ( let+ ) form f = ( let* ) form (fun v _ -> Ok (f v))
let ( and+ ) form1 form2 values =
match form1 values, form2 values with
| Ok v1, Ok v2 -> Ok (v1, v2)
| Ok _, Error e2 -> Error e2
| Error e1, Ok _ -> Error e1
| Error e1, Error e2 -> Error (e2 @ e1)
let rec multiple n form =
match n with
| 0 -> ok []
| _ ->
let+ v = form (n - 1)
and+ vs = multiple (n - 1) form in
v :: vs
let string ?(min_length = 0) ?(max_length = Sys.max_string_length) s =
let len = String.length s in
if min_length <= len && len <= max_length then Ok s else Error error_length
let int ?(min = Int.min_int) ?(max = Int.max_int) s =
match int_of_string s with
| i when min <= i && i <= max -> Ok i
| _ -> Error error_range
| exception Failure _ -> Error error_expected_int
let int32 ?(min = Int32.min_int) ?(max = Int32.max_int) s =
match Int32.of_string s with
| i32 when Int32.compare min i32 <= 0 && Int32.compare i32 max <= 0 -> Ok i32
| _ -> Error error_range
| exception Failure _ -> Error error_expected_int
let int64 ?(min = Int64.min_int) ?(max = Int64.max_int) s =
match Int64.of_string s with
| i64 when Int64.compare min i64 <= 0 && Int64.compare i64 max <= 0 -> Ok i64
| _ -> Error error_range
| exception Failure _ -> Error error_expected_int
let min_char = Char.chr 0
let max_char = Char.chr 255
let char ?(min = min_char) ?(max = max_char) s =
if String.length s = 1 then
let c = s.[0] in
if min <= c && c <= max then Ok c else Error error_range
else
Error error_expected_char
let float ?(min = Float.min_float) ?(max = Float.max_float) s =
match float_of_string s with
| i when min <= i && i <= max -> Ok i
| _ -> Error error_range
| exception Failure _ -> Error error_expected_int
let bool = function
| "true" -> Ok true
| "false" -> Ok false
| _ -> Error error_expected_bool
let make_tm ?min ?max ?(hour = 0) ?(minute = 0) ?(second = 0) year month day =
let tm =
{ Unix.tm_year = year - 1900;
tm_mon = month - 1;
tm_mday = day;
tm_hour = hour;
tm_min = minute;
tm_sec = second;
tm_wday = 0;
tm_yday = 0;
tm_isdst = false
}
in
let f, tm = Unix.mktime tm in
match min, max with
| Some min, Some max ->
let fmin, _ = Unix.mktime min
and fmax, _ = Unix.mktime max in
if fmin <= f && f <= fmax then Ok tm else Error error_range
| Some min, None ->
let fmin, _ = Unix.mktime min in
if fmin <= f then Ok tm else Error error_range
| None, Some max ->
let fmax, _ = Unix.mktime max in
if f <= fmax then Ok tm else Error error_range
| None, None -> Ok tm
let unix_tm ?min ?max s =
try
Scanf.sscanf s "%4d-%2d-%d" (fun year month day ->
make_tm ?min ?max year month day)
with End_of_file -> (
try
Scanf.sscanf s "%4d-%d-%dT%2d:%2d:%2d"
(fun year month day hour minute second ->
make_tm ?min ?max ~hour ~minute ~second year month day)
with End_of_file -> Error error_expected_time)
let ( or ) form1 form2 values =
match form1 values with
| Ok _ as ok -> ok
| Error _ -> form2 values
let validate form values =
let htbl = Hashtbl.create 10 in
List.iter (fun (name, value) -> Hashtbl.add htbl name value) values;
form htbl
let pp_error = Fmt.(brackets (list ~sep:semi (pair ~sep:comma string string)))