Commit 469ed7d8 authored by Josh Kunz's avatar Josh Kunz

Revamps Json parsing/unparsing.

    Finally got tired of my ad-hoc parser and wrote a bit of code
    to serialize the JSON into something actually usable. Massively
    reduce the size of JSON -> OCaml code.
parent 27a03fb8
open Jsonm
open Printf
exception Json_decode_error
exception Json_encode_error
type cannonical_json =
| Object of (string * cannonical_json) list
| Array of cannonical_json list
| String of string
| Bool of bool
| Float of float
| Null;;
let string_for_lexeme = function
| `Os -> "`Os"
| `Oe -> "`Oe"
| `As -> "`As"
| `Ae -> "`Ae"
| `Name s -> sprintf "`Name('%s')" s
| `String s -> sprintf "`String('%s')" s
| `Bool b -> sprintf "`Bool(%s)" (if b then "true" else "false")
| `Float f -> sprintf "`Float(%f)" f
| `Null -> "`Null"
| _ -> raise (Failure "Unknown Lexeme");;
(* Shorter, composable form of json encode *)
let (|@) e l =
match Jsonm.encode e (`Lexeme l) with
| `Ok -> e
| _ -> Failure("Internal JSON Encoder error.") |> raise;;
let cvalue_for_value = function
| `String s -> String s
| `Bool b -> Bool b
| `Float f -> Float f
| `Null -> Null
| _ -> raise Json_decode_error;;
let value_for_cvalue = function
| String s -> `String s
| Bool b -> `Bool b
| Float f -> `Float f
| Null -> `Null
(* Warning, this may be caused by a faulty rule in decannonize that's
* sending valid cvalues that aren't terminals. *)
| _ -> raise Json_encode_error;;
let cannonize d =
let rec pobj_v d l k = match decode d with
| `Lexeme `As -> (k, (parr d [])) :: l |> pobj d
| `Lexeme `Os -> (k, (pobj d [])) :: l |> pobj d
| `Lexeme le -> (k, (cvalue_for_value le)) :: l |> pobj d
| _ -> raise Json_decode_error
and pobj d l = match decode d with
| `Lexeme `Oe -> Object l
| `Lexeme (`Name k) -> pobj_v d l k
| _ -> raise Json_decode_error
and parr d l = match decode d with
| `Lexeme `Os -> (pobj d []) :: l |> parr d
| `Lexeme `As -> (parr d []) :: l |> parr d
| `Lexeme `Ae -> Array l
| `Lexeme le -> (cvalue_for_value le) :: l |> parr d
| _ -> raise Json_decode_error
and _end d f = match decode d with
| `End -> f
| _ -> raise Json_decode_error
and start d = match decode d with
| `Lexeme `As -> parr d [] |> _end d
| `Lexeme `Os -> pobj d [] |> _end d
| _ -> raise Json_decode_error in
start d;;
let decannonize enc j =
let rec serialize enc = function
| Object o -> enc
|@ `Os
|> fun e -> List.fold_left serialize_keys e o
|@ `Oe;
| Array a -> enc
|@ `As
|> fun x -> List.fold_left serialize x a
|@ `Ae;
| l -> enc |@ value_for_cvalue l;
and serialize_keys e (k, v) = serialize (e |@ `Name k) v
in
Jsonm.encode (serialize enc j) `End;;
...@@ -6,7 +6,7 @@ OCAMLFLAGS = -thread -I ../include/ ...@@ -6,7 +6,7 @@ OCAMLFLAGS = -thread -I ../include/
bin = nagad bin = nagad
sources = KG.ml Query.ml Nagad.ml sources = KG.ml Query.ml JsonExt.ml Nagad.ml
interfaces = $(patsubst %.mli,%.cmi,$(filter %.mli,$(sources))) interfaces = $(patsubst %.mli,%.cmi,$(filter %.mli,$(sources)))
interfaces += $(patsubst %.ml,%.cmi,$(filter %.ml,$(sources))) interfaces += $(patsubst %.ml,%.cmi,$(filter %.ml,$(sources)))
objects = $(patsubst %.ml,%.cmo,$(filter %.ml,$(sources))) objects = $(patsubst %.ml,%.cmo,$(filter %.ml,$(sources)))
......
...@@ -8,99 +8,60 @@ open HTTP ...@@ -8,99 +8,60 @@ open HTTP
open Thread open Thread
open Mutex open Mutex
open Jsonm open Jsonm
open JsonExt
open Buffer open Buffer
let graph = ref (KG.empty ());; let graph = ref (KG.empty ());;
let g = Mutex.create ();; let g = Mutex.create ();;
(* Shorter, composable form of json encode *)
let (|@) e l =
match Jsonm.encode e (`Lexeme l) with
| `Ok -> e
| _ -> Failure("Internal JSON Encoder error.") |> raise;;
type decoded = [
| `String of string
| `Name of string
| `Os | `Oe | `As | `Ae | `End ];;
let (!*) d : decoded =
match Jsonm.decode d with
| `Lexeme `Os -> `Os
| `Lexeme `Oe -> `Oe
| `Lexeme `As -> `As
| `Lexeme `Ae -> `Ae
| `Lexeme (`String s) -> `String s
| `Lexeme (`Name n) -> `Name n
| `End -> `End
| _ -> raise (Failure "Unhandled json decoded case.");;
let json_for_graph g = let json_for_graph g =
let rec json_for_edge enc e = let rec json_for_edge e =
enc Object [
|@ `Os ("label", String e.label)
|@ `Name "label" |@ `String e.label ;("to", String e.out)] in
|@ `Name "to" |@ `String e.out let json_for_adj_list k v l =
|@ `Oe (k, Array (List.map json_for_edge v)) :: l in
in
let json_for_adj_list k v enc =
enc
|@ `Name k
|@ `As
|> fun x -> List.fold_left json_for_edge x v
|@ `Ae
in
let buf = Buffer.create 100 in let buf = Buffer.create 100 in
Jsonm.encoder (`Buffer buf) |@ `Os let enc = Jsonm.encoder (`Buffer buf) in
|> KG.Graph.fold json_for_adj_list g |@ `Oe Object (KG.Graph.fold json_for_adj_list g [])
|> fun x -> Jsonm.encode x `End |> ignore; |> JsonExt.decannonize enc |> ignore;
Buffer.contents buf;; Buffer.contents buf;;
exception Json_not_graph
let graph_for_json j = let graph_for_json j =
let open KG in let parse_edge g k = function
let rec p10 d g h r t = p4 d (KG.add_fact g {head=h; rel=r; tail=t}) h | Object [
and p8 d g h r = match !* d with ("label", String l)
| `String t -> p10 d g h r t ;("to", String t) ] ->
| _ -> raise Json_not_graph {KG.head = k; KG.rel = l; KG.tail = t} |> KG.madd_fact g
and p8_1 d g h t = match !* d with | _ -> raise JsonExt.Json_decode_error in
| `String r -> p10 d g h r t let parse_adj g = function
| _ -> raise Json_not_graph | (k, Array adj) -> List.iter (parse_edge g k) adj
and p7 d g h r = match !* d with | _ -> raise JsonExt.Json_decode_error in
| `Name "to" -> p8 d g h r let parse_graph g = function
| _ -> raise Json_not_graph | Object adj_lists -> List.iter (parse_adj g) adj_lists
and p7_1 d g h t = match !* d with | _ -> raise JsonExt.Json_decode_error in
| `Name "label" -> p8_1 d g h t let dec = Jsonm.decoder (`String j) in
| _ -> raise Json_not_graph let graph = KG.empty () in
and p6 d g h = match !* d with JsonExt.cannonize dec |> parse_graph graph; graph;;
| `String r -> p7 d g h r
| _ -> raise Json_not_graph let is_titlecase s =
and p6_1 d g h = match !* d with String.length s > 0
| `String t -> p7_1 d g h t && 'A' <= s.[0] && s.[0] <= 'Z';;
| _ -> raise Json_not_graph
and p5 d g h = match !* d with let query_for_json j =
| `Name "label" -> p6 d g h let parse_item i =
| `Name "to" -> p6_1 d g h if is_titlecase i then Variable i else Value i in
| _ -> raise Json_not_graph let parse_triple = function
and p4 d g h = match !* d with | Array [String i1; String i2; String i3] ->
| `Os -> p5 d g h {head = parse_item i1;
| `Oe -> p4 d g h rel = parse_item i2;
| `Ae -> p2 d g tail = parse_item i3}
| _ -> raise Json_not_graph | _ -> raise JsonExt.Json_decode_error in
and p3 d g h = match !* d with let parse_query = function
| `As -> p4 d g h | Array triples -> List.map parse_triple triples
| _ -> raise Json_not_graph | _ -> raise JsonExt.Json_decode_error in
and p2 d g = match !* d with let dec = Jsonm.decoder (`String j) in
| `Name h -> p3 d g h JsonExt.cannonize dec |> parse_query;;
| `Oe -> p1 d g
| _ -> raise Json_not_graph
and p1 d g = match !* d with
| `Os -> p2 d g
| `End -> g
| _ -> raise Json_not_graph
in
p1 (Jsonm.decoder (`String j)) (KG.empty ());;
(* Close the connection that backs the given streams *) (* Close the connection that backs the given streams *)
let terminate (ic, oc) = let terminate (ic, oc) =
...@@ -134,7 +95,6 @@ let handle_client (ic, oc, addr) = ...@@ -134,7 +95,6 @@ let handle_client (ic, oc, addr) =
Response.make 200 ""; Response.make 200 "";
| _ -> Response.make 405 "" | _ -> Response.make 405 ""
end; end;
| "/query" -> Response.make 200 "Query.";
| _ -> Response.make 404 ""; | _ -> Response.make 404 "";
in begin try in begin try
Request.read ic |> handle_request |> Response.write oc; Request.read ic |> handle_request |> Response.write oc;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment