From cb85c5d92d80edc60ce1dcfbf7abc249c7312edc Mon Sep 17 00:00:00 2001 From: Ryan Kavanagh Date: Mon, 1 Jun 2020 12:55:43 -0400 Subject: Mime type parsing --- gemini/mimeType.ml | 43 ++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 40 insertions(+), 3 deletions(-) (limited to 'gemini') diff --git a/gemini/mimeType.ml b/gemini/mimeType.ml index 0559168..1682416 100644 --- a/gemini/mimeType.ml +++ b/gemini/mimeType.ml @@ -24,9 +24,46 @@ struct exception ParseError of string - let from_string _ = { mime_type = "text"; - mime_subtype = "plain"; - mime_param = None } + 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 -- cgit v1.2.3