package conformist

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file conformist.ml

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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
type 'a decoder = string -> ('a, string) result
type 'a encoder = 'a -> string
type 'a validator = 'a -> string option

let always_valid _ = None

module Field = struct
  type ('meta, 'a) t =
    { name : string
    ; meta : 'meta option
    ; default : 'a option
    ; decoder : 'a decoder
    ; encoder : 'a encoder
    ; type_ : string
    ; validator : 'a validator
    ; optional : bool
    }

  type (_, _, _) list =
    | [] : ('meta, 'ty, 'ty) list
    | ( :: ) :
        ('meta, 'a) t * ('meta, 'b, 'ty) list
        -> ('meta, 'a -> 'b, 'ty) list

  type _ any_field = AnyField : ('meta, 'a) t -> 'meta any_field

  let meta (AnyField field) = field.meta
  let name (AnyField field) = field.name

  let validate (AnyField field) input =
    match field.decoder input with
    | Ok value -> field.validator value
    | Error msg -> Some msg
  ;;

  let optional (AnyField field) = field.optional
  let type_ (AnyField field) = field.type_
  let encode_default (AnyField field) = Option.map field.encoder field.default

  let make name meta decoder encoder default type_ validator optional =
    { name; meta; default; decoder; encoder; type_; validator; optional }
  ;;

  let make_custom
      decoder
      encoder
      ?default
      ?type_
      ?meta
      ?(validator = always_valid)
      name
    =
    let type_ = Option.value type_ ~default:name in
    make name meta decoder encoder default type_ validator false
  ;;

  let make_optional ?meta field =
    let decoder string =
      match field.decoder string with
      | Ok result -> Ok (Some result)
      | Error msg -> Error msg
    in
    let validator a =
      match a with
      | Some a -> field.validator a
      | None -> None
    in
    let encoder a =
      match a with
      | Some a -> field.encoder a
      | None -> "None"
    in
    make
      field.name
      meta
      decoder
      encoder
      (Some field.default)
      field.type_
      validator
      true
  ;;

  let make_bool ?default ?meta ?(msg = "Invalid value provided") name =
    let decoder string =
      try Ok (bool_of_string string) with
      | _ -> Error msg
    in
    make name meta decoder string_of_bool default "bool" always_valid false
  ;;

  let make_float
      ?default
      ?meta
      ?(msg = "Invalid number provided")
      ?(validator = always_valid)
      name
    =
    let decoder string =
      try Ok (float_of_string string) with
      | _ -> Error msg
    in
    make name meta decoder string_of_float default "float" validator false
  ;;

  let make_int
      ?default
      ?meta
      ?(msg = "Invalid number provided")
      ?(validator = always_valid)
      name
    =
    let decoder string =
      try Ok (int_of_string string) with
      | _ -> Error msg
    in
    make name meta decoder string_of_int default "int" validator false
  ;;

  let make_string ?default ?meta ?(validator = always_valid) name =
    let decoder string = Ok string in
    make name meta decoder (fun id -> id) default "string" validator false
  ;;

  let make_date
      ?default
      ?meta
      ?(msg = "Invalid date provided")
      ?(validator = always_valid)
      name
    =
    let decoder string =
      match String.split_on_char '-' string with
      | [ y; m; d ] ->
        (match
           int_of_string_opt y, int_of_string_opt m, int_of_string_opt d
         with
        | Some y, Some m, Some d -> Ok (y, m, d)
        | _ -> Error msg)
      | _ -> Error msg
    in
    let encoder (y, m, d) = Format.sprintf "%d-%d-%d" y m d in
    make name meta decoder encoder default "date" validator false
  ;;

  let make_datetime
      ?default
      ?meta
      ?(msg = "Invalid datetime provided")
      ?(validator = always_valid)
      name
    =
    let decoder string =
      match Ptime.of_rfc3339 string with
      | Ok (timestamp, _, _) -> Ok timestamp
      | Error (`RFC3339 (_, _)) -> Error msg
    in
    let encoder ptime = Ptime.to_rfc3339 ptime in
    make name meta decoder encoder default "time" validator false
  ;;
end

let custom = Field.make_custom
let optional = Field.make_optional
let bool = Field.make_bool
let float = Field.make_float
let int = Field.make_int
let string = Field.make_string
let date = Field.make_date
let datetime = Field.make_datetime

type ('meta, 'ctor, 'ty) t =
  { fields : ('meta, 'ctor, 'ty) Field.list
  ; ctor : 'ctor
  }

let empty = { fields = Field.[]; ctor = () }
let make fields ctor = { fields; ctor }

let rec fold_left'
    : type ty args.
      f:('res -> 'meta Field.any_field -> 'res)
      -> init:'res
      -> ('meta, args, ty) Field.list
      -> 'res
  =
 fun ~f ~init fields ->
  match fields with
  | [] -> init
  | field :: fields -> fold_left' ~f ~init:(f init (AnyField field)) fields
;;

let fold_left ~f ~init schema = fold_left' ~f ~init schema.fields

type error = string * string option * string
type input = (string * string list) list

let validate schema input =
  let f errors field =
    let name = Field.name field in
    match List.assoc name input with
    | [ value_string ] ->
      (match Field.validate field value_string with
      | Some msg -> List.cons (name, Some value_string, msg) errors
      | None -> errors)
    | values ->
      let value = Format.sprintf "[%s]" (String.concat ", " values) in
      List.cons (name, Some value, "Multiple values provided") errors
    | exception Not_found ->
      (match Field.optional field, Field.encode_default field with
      | _, Some default ->
        (match Field.validate field default with
        | Some msg -> List.cons (name, None, msg) errors
        | None -> errors)
      | true, None -> errors
      | false, None -> List.cons (name, None, "No value provided") errors)
  in
  fold_left ~f ~init:[] schema |> List.rev
;;

let rec decode
    : type meta ctor ty.
      (meta, ctor, ty) t
      -> (string * string list) list
      -> (ty, string * string option * string) Result.t
  =
 fun { fields; ctor } fields_assoc ->
  let open! Field in
  match fields with
  | [] -> Ok ctor
  | field :: fields ->
    (match List.assoc field.name fields_assoc with
    | [ value_string ] ->
      (match field.decoder value_string with
      | Ok value ->
        (match ctor value with
        | ctor -> decode { fields; ctor } fields_assoc
        | exception exn ->
          let msg = Printexc.to_string exn in
          Error (field.name, Some value_string, msg))
      | Error msg -> Error (field.name, Some value_string, msg))
    | [] ->
      (match field.default with
      | Some value ->
        (match ctor value with
        | ctor -> decode { fields; ctor } fields_assoc
        | exception exn ->
          let msg = Printexc.to_string exn in
          Error (field.name, None, msg))
      | None ->
        (match field.decoder "" with
        | Ok value ->
          (match ctor value with
          | ctor -> decode { fields; ctor } fields_assoc
          | exception exn ->
            let msg = Printexc.to_string exn in
            Error (field.name, None, msg))
        | Error msg -> Error (field.name, Some "", msg)))
    | values ->
      let value = Format.sprintf "[%s]" (String.concat ", " values) in
      Error (field.name, Some value, "Multiple values provided")
    | exception Not_found ->
      (match field.default with
      | Some value ->
        (match ctor value with
        | ctor -> decode { fields; ctor } fields_assoc
        | exception exn ->
          let msg = Printexc.to_string exn in
          let value_string = Option.map field.encoder field.default in
          Error (field.name, value_string, msg))
      | None -> Error (field.name, None, "No value provided")))
;;

let decode_and_validate schema input =
  let validation_errors = validate schema input in
  match decode schema input, validation_errors with
  | Ok value, [] -> Ok value
  | Ok _, validation_errors -> Error validation_errors
  | Error (field_name, value, msg), validation_errors ->
    validation_errors
    |> List.filter (fun (name, _, _) -> not (String.equal name field_name))
    |> List.cons (field_name, value, msg)
    |> Result.error
;;
OCaml

Innovation. Community. Security.