blob: 0cfd06304a3baed6b7408ef99ddcca48acbc68bb (
plain) (
blame)
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
|
module type MIME_TYPE =
sig
type t
exception ParseError of string
val from_string : string -> t
val to_type : t -> string
val to_subtype : t -> string
val to_parameter : t -> (string * string) option
end
module MimeType : MIME_TYPE =
struct
type t =
{ mime_type : string;
mime_subtype : string;
mime_param : (string * string) option;
}
exception ParseError of string
let create_mimetype mime_type mime_subtype mime_param =
{ mime_type; mime_subtype; mime_param; }
let from_string (s : string) =
(* RFC 2045 § 5.1 *)
(* RFC 6838 § 4.2 *)
(* FIXME: parameter does not handle quoted strings and
does not try to ensure that everything is well-formed *)
let open Angstrom in
let open ParseCommon.ParseCommon in
let is_symbol = function
| '!' | '#' | '$' | '&' | '-' | '^' | '_' | '.' | '+' -> true
| _ -> false in
let take_all = take_while (fun _ -> true) in
let maybe p =
option None (lift (fun s -> Some s) p) in
let restricted_name =
lift2 (fun c -> fun s -> (Char.escaped c) ^ s)
(satisfy (lift_or is_letter is_digit))
(take_while (lift_or is_letter (lift_or is_digit is_symbol))) in
let parameter = lift2 (fun p -> fun v -> (p, v))
(take_till (fun c -> c = '='))
(char '=' *> take_all) <?> "parameter" in
let parse = lift3 create_mimetype
(restricted_name <?> "type")
((char '/' *> restricted_name) <?> "subtype")
(maybe (char ';' *> skip_while is_whitespace *> parameter))
<?> "mimetype"
in match Angstrom.parse_string ~consume:All parse s with
| Ok x -> x
| Error msg -> raise (ParseError msg)
let to_type m = m.mime_type
let to_subtype m = m.mime_subtype
let to_parameter m = m.mime_param
end
|
