summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Kavanagh <rak@rak.ac>2020-06-01 12:55:43 -0400
committerRyan Kavanagh <rak@rak.ac>2020-06-07 11:39:58 -0400
commitcb85c5d92d80edc60ce1dcfbf7abc249c7312edc (patch)
treef5f4f1a05abeb05221866e7daab3367177722162
parentRevise with better understanding of lwt library (diff)
Mime type parsing
Diffstat (limited to '')
-rw-r--r--gemini/mimeType.ml43
1 files changed, 40 insertions, 3 deletions
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