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 lift_or p q b = p b || q b in
    let is_letter = function
      | 'a' .. 'z' | 'A' .. 'Z' -> true
      | _ -> false in
    let is_digit = function
      | '0' .. '9' -> true
      | _ -> false in
    let is_symbol = function
      | '!' | '#' | '$' | '&' | '-' | '^' | '_' | '.' | '+' -> true
      | _ -> false in
    let is_space = function
      | ' ' | '\t' -> 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_space *> 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