JSON parsing; more posted-message parsing

httpd.ml

@@ -26,7 +26,8 @@ type body = {
     content: content
   }
 
-let empty_body = {headers = []; content = Fixed ""}
+let empty_content = Fixed ""
+let empty_body = {headers = []; content = empty_content}
 
 type req = {
     verb: string;
@@ -116,28 +117,12 @@ let escape_url_char c =
   | _ -> None
 let url_escape s = Util.strsub escape_url_char s
 
-let unhex_char c =
-  match c with
-  | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' -> Char.code c - Char.code '0'
-  | 'a' | 'b' | 'c' | 'd' | 'e' | 'f' -> Char.code c - Char.code 'a' + 10
-  | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' -> Char.code c - Char.code 'A' + 10
-  | _ -> -1
-
-let unhex s =
-  let len = String.length s in
-  let rec loop index acc =
-    if index = len
-    then acc
-    else loop (index + 1) (acc * 16 + unhex_char (String.get s index))
-  in
-  loop 0 0
-
 let unescape_url_hex_code (s, pos) =
   let len = String.length s in
   if len - pos >= 3
   then
-    let v1 = unhex_char (String.get s (pos + 1)) in
-    let v2 = unhex_char (String.get s (pos + 2)) in
+    let v1 = Util.unhex_char (String.get s (pos + 1)) in
+    let v2 = Util.unhex_char (String.get s (pos + 2)) in
     if v1 = -1 || v2 = -1
     then http_error_html 400 ("Bad percent escaping: '"^String.sub s pos 3^"'") []
     else (String.make 1 (Char.chr (v1 * 16 + v2)), pos + 3)
@@ -270,7 +255,7 @@ let rec parse_headers cin =
 let parse_chunks cin =
   fun () ->
     let hexlen_str = input_crlf cin in
-    let chunk_len = unhex hexlen_str in
+    let chunk_len = Util.unhex hexlen_str in
     let buffer = String.make chunk_len '\000' in
     really_input cin buffer 0 chunk_len;
     (if input_crlf cin <> "" then http_error_html 400 "Invalid chunk boundary" [] else ());
@@ -283,7 +268,7 @@ let parse_body cin =
       (match find_header' "Content-Length" headers with
       | None ->
 	  (* http_error_html 411 "Length required" [] *)
-	  {headers = headers; content = Fixed ""}
+	  {headers = headers; content = empty_content}
       | Some length_str ->
 	  let length = int_of_string length_str in
 	  let buffer = String.make length '\000' in

ibuffer.ml

@@ -40,6 +40,23 @@ let sub b ofs len =
 
 let remaining b = b.limit - b.pos
 
+let skip_byte b =
+  if b.pos < b.limit
+  then b.pos <- b.pos + 1
+  else raise End_of_file
+
+let skip_ws b =
+  while b.pos < b.limit && String.get b.buf b.pos <= ' ' do
+    b.pos <- b.pos + 1
+  done
+
+let peek_char b =
+  if b.pos < b.limit
+  then String.get b.buf b.pos
+  else raise End_of_file
+
+let peek_byte b = int_of_char (peek_char b)
+
 let next_char b =
   if b.pos < b.limit
   then

json.ml

@@ -23,6 +23,8 @@ type t =
   | Flg of bool
   | Nil
 
+exception Syntax_error
+
 let escape_char c =
   match c with
   | '\"' -> Some (fun (s, pos) -> ("\\\"", pos + 1))
@@ -52,6 +54,111 @@ let rec to_string j =
 and kv_to_string (k, v) =
   str_to_string k ^ ":" ^ to_string v
 
+let accumulate_utf8 codepoint (acc, len) =
+  (* Of course, at the moment, the codepoint is limited to 16 bits... *)
+  if codepoint < 0x80 then
+    (Char.chr codepoint :: acc, len + 1)
+  else if codepoint < 0x800 then
+    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
+     Char.chr (0xC0 lor ((codepoint lsr 6) land 0x1f)) ::
+     acc, len + 2)
+  else if codepoint < 0x10000 then
+    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
+     Char.chr (0xE0 lor ((codepoint lsr 12) land 0xf)) ::
+     acc, len + 3)
+  else if codepoint < 0x200000 then
+    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f)) ::
+     Char.chr (0xF0 lor ((codepoint lsr 18) land 0x7)) ::
+     acc, len + 4)
+  else if codepoint < 0x4000000 then
+    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 18) land 0x3f)) ::
+     Char.chr (0xF8 lor ((codepoint lsr 24) land 0x3)) ::
+     acc, len + 5)
+  else
+    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 18) land 0x3f)) ::
+     Char.chr (0x80 lor ((codepoint lsr 24) land 0x3f)) ::
+     Char.chr (0xFC lor ((codepoint lsr 30) land 0x1)) ::
+     acc, len + 6)
+
+let string_of_revlist acc len =
+  let buf = String.make len ' ' in
+  let rec fill cs i =
+    match cs with
+    | [] -> ()
+    | c :: cs' -> (String.set buf i c; fill cs' (i - 1))
+  in
+  fill acc (len - 1);
+  buf
+
+let rec parse_num b (acc, len) =
+  match Ibuffer.peek_char b with
+  | '+' | '-' | 'e' | 'E' | '.'
+  | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
+      as c ->
+	Ibuffer.skip_byte b;
+	parse_num b (c :: acc, len + 1)
+  | _ ->
+      Num (float_of_string (string_of_revlist acc len))
+
+let rec parse_str b (acc, len) =
+  match Ibuffer.next_char b with
+  | '\"' -> Str (string_of_revlist acc len)
+  | '\\' ->
+      (match Ibuffer.next_char b with
+      | 'b' -> parse_str b (Char.chr 8 :: acc, len + 1)
+      | 'f' -> parse_str b (Char.chr 12 :: acc, len + 1)
+      | 'n' -> parse_str b (Char.chr 10 :: acc, len + 1)
+      | 'r' -> parse_str b (Char.chr 13 :: acc, len + 1)
+      | 't' -> parse_str b (Char.chr 9 :: acc, len + 1)
+      | 'u' -> parse_str b (accumulate_utf8 (Util.unhex (Ibuffer.next_chars b 4)) (acc, len))
+      | c -> parse_str b (c :: acc, len + 1))
+  | c -> parse_str b (c :: acc, len + 1)
+
+let rec parse_arr b acc =
+  Ibuffer.skip_ws b;
+  match Ibuffer.peek_char b with
+  | ']' -> Ibuffer.skip_byte b; Arr (List.rev acc)
+  | ',' -> Ibuffer.skip_byte b; parse_arr b acc
+  | _ -> parse_arr b (parse b :: acc)
+
+and parse_rec b acc =
+  Ibuffer.skip_ws b;
+  match Ibuffer.peek_char b with
+  | '}' -> Ibuffer.skip_byte b; Rec (List.rev acc)
+  | ',' -> Ibuffer.skip_byte b; parse_rec b acc
+  | _ ->
+      (match parse b with
+      | Str k ->
+	  Ibuffer.skip_ws b;
+	  (match Ibuffer.next_char b with
+	  | ':' -> parse_rec b ((k, parse b) :: acc)
+	  | _ -> raise Syntax_error)
+      | _ -> raise Syntax_error)
+
+and parse b =
+  Ibuffer.skip_ws b;
+  match Ibuffer.next_char b with
+  | '+' | '-' | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
+      as c -> parse_num b ([c], 1)
+  | '\"' -> parse_str b ([], 0)
+  | '[' -> parse_arr b []
+  | '{' -> parse_rec b []
+  | 't' -> if Ibuffer.next_chars b 3 = "rue" then Flg true else raise Syntax_error
+  | 'f' -> if Ibuffer.next_chars b 4 = "alse" then Flg false else raise Syntax_error
+  | 'n' -> if Ibuffer.next_chars b 3 = "ull" then Nil else raise Syntax_error
+  | _ -> raise Syntax_error
+
+let of_string s = parse (Ibuffer.of_string s)
+
 let resp code reason extra_headers j =
   Httpd.resp_generic code reason
     ((Httpd.content_type_header_name, "application/json") :: extra_headers)

ui_main.ml

@@ -76,11 +76,20 @@ let api_tap_source r =
 	  (Stringstream.seq id_block_and_padding (Stringstream.make message_stream))
 	  Stringstream.empty))
 
+let counter = ref 0
 let api_tap_sink r =
-  List.iter
-    (fun (k, v) -> Printf.printf "%s = %s\n%!" k (match v with Some x -> x | None -> "..."))
-    (Httpd.parse_urlencoded (Httpd.string_of_content r.Httpd.req_body.Httpd.content));
-  Httpd.resp_generic 202 "Accepted" [] (Httpd.Fixed "")
+  let params = Httpd.parse_urlencoded (Httpd.string_of_content r.Httpd.req_body.Httpd.content) in
+  (* let stream_id = List.assoc "metadata.id" params in *)
+  match List.assoc "metadata.type" params with
+  | Some "send" ->
+      (match List.assoc "data" params with
+      | Some data_str ->
+	  let data = Json.of_string data_str in
+	  counter := 1 + !counter;
+	  Printf.printf "Data: %d %s\n%!" !counter (Json.to_string data);
+	  Httpd.resp_generic 202 "Accepted" [] (Httpd.empty_content)
+      | _ -> Httpd.http_error_html 406 "Bad data parameter" [])
+  | _ -> Httpd.http_error_html 406 "Unsupported metadata.type" []
 
 let api_tap r =
   match r.Httpd.verb with

util.ml

@@ -77,3 +77,19 @@ let strsub replacement_fn s =
 	    inner_loop (high + 1)
     in inner_loop low
   in outer_loop [] 0
+
+let unhex_char c =
+  match c with
+  | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' -> Char.code c - Char.code '0'
+  | 'a' | 'b' | 'c' | 'd' | 'e' | 'f' -> Char.code c - Char.code 'a' + 10
+  | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' -> Char.code c - Char.code 'A' + 10
+  | _ -> -1
+
+let unhex s =
+  let len = String.length s in
+  let rec loop index acc =
+    if index = len
+    then acc
+    else loop (index + 1) (acc * 16 + unhex_char (String.get s index))
+  in
+  loop 0 0