(* Copyright (c) 2010-2011 Yoran Heling * * Permission is hereby granted, free of charge, to any person obtaining * a copy of this software and associated documentation files (the * "Software"), to deal in the Software without restriction, including * without limitation the rights to use, copy, modify, merge, publish, * distribute, sublicense, and/or sell copies of the Software, and to * permit persons to whom the Software is furnished to do so, subject to * the following conditions: * * The above copyright notice and this permission notice shall be included * in all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* This is a very minimal standard-compliant JSON parser/generator, because the * currently available JSON libraries for OCaml try to do too much and have too * many dependencies. * * - The aim of this library is to be small rather than fast. * It was made to parse and generate small (~1kB to 100kB) messages. * Performance should be acceptable as long as the input does not contain long * strings with a lot of escaped characters. (e.g. binary data encoded in a * JSON string is a bad idea.) * * - Error detecting is correct. Error reporting, however, is rather minimal. * * - This library conforms to RFC 4627, with two exceptions: * 1. The top-level JSON value does not have to be an array or object, but can * be any valid JSON value. An application would have to check for the type * of the value anyway. * 2. All data after the end of the JSON string is ignored, and may thus * contain garbage. For example, the following JSON string is valid: * true{"data":1} * Parsing that will simply give you (Bool true) * * - All data is assumed to be encoded in UTF-8 * In particular: * - When parsing, \uxxxx string escapes are converted into their UTF-8 * representation. * - When serializing, all non-printable 7-bit string characters are escaped * to their native JSON control character (e.g. \b or \t) or as \u00xx. * Everything else is passed as-is. * * Note that I have not fully tested how this library reacts to various forms of * JSON input, but I do not expect any major problems. * (Some portions and ideas of this code were borrowed from yojson) * *) (* H E A D E R *) { (* Primary JSON data structure. Integers and numbers are left as strings in * order to avoid losing data to precision or overflows (and int<>string<>float * conversion really isn't that hard to do in application code) *) type json = Object of (string * json) list | Array of json list | Bool of bool | Null | String of string | Int of string | Number of string exception JSON_Error exception JSON_Array_End exception JSON_Object_End exception JSON_Incorrect_Type (* Based on common.ml:utf8_of_bytes from yojson, although this one is less efficient *) let utf8_of_bytes a b c d = let i = (a lsl 12) lor (b lsl 8) lor (c lsl 4) lor d in let str = "000" in if i < 0x80 then ( str.[0] <- char_of_int i; String.sub str 0 1 ) else if i < 0x800 then ( str.[0] <- char_of_int (0xc0 lor ((i lsr 6) land 0x1f)); str.[1] <- char_of_int (0x80 lor (i land 0x3f)); String.sub str 0 2 ) else ( str.[0] <- char_of_int (0xe0 lor ((i lsr 12) land 0xf)); str.[1] <- char_of_int (0x80 lor ((i lsr 6) land 0x3f)); str.[2] <- char_of_int (0x80 lor (i land 0x3f)); String.sub str 0 3 ) (* from yojosn -> read.mll:hex *) let int_of_hex c = match c with | '0'..'9' -> int_of_char c - int_of_char '0' | 'a'..'f' -> int_of_char c - int_of_char 'a' + 10 | 'A'..'F' -> int_of_char c - int_of_char 'A' + 10 | _ -> assert false (* 0-255 -> \u00(00-ff) (this function isn't the reverse of int_of_hex, but oh well) *) let hex_of_int i = let s = "\\u0000" in let a = i lsr 4 in let b = i land 0x0f in s.[4] <- char_of_int ((if a < 10 then int_of_char '0' else int_of_char 'a' - 10) + a); s.[5] <- char_of_int ((if b < 10 then int_of_char '0' else int_of_char 'a' - 10) + b); s } (* D E F I N I T I O N S *) let ws = [' ' '\t' '\n' '\r'] let digit = ['0'-'9'] let digit1 = ['1'-'9'] let integer = '-'? ( digit | ( digit1 digit+ ) ) let frac = '.' digit+ let exp = ['e' 'E'] ['+' '-']? let number = (integer frac) | (integer exp) | (integer frac exp) let hex = ['0'-'9' 'a'-'f' 'A'-'F'] let strlit = [^ '\000'-'\031' '"' '\\'] (* R U L E S *) rule json_val = parse | ws+ { json_val lexbuf } | "true" { Bool true } | "false" { Bool false } | "null" { Null } | integer as i { Int i } | number as n { Number n } | '"' { String (json_string "" lexbuf) } | ']' { raise JSON_Array_End } | '}' { raise JSON_Object_End } | '[' { let rec element () = try ( json_sep lexbuf; let v = try json_val lexbuf with JSON_Array_End -> raise JSON_Error in v :: (element ()) ) with JSON_Array_End -> [] in Array ( try let v = json_val lexbuf in v :: (element ()) with JSON_Array_End -> []) } | '{' { let rec pair () = try ( json_sep lexbuf; let name = try json_val lexbuf with JSON_Object_End -> raise JSON_Error in let str = match name with | String x -> x | _ -> raise JSON_Error in json_valsep lexbuf; let value = try json_val lexbuf with JSON_Object_End -> raise JSON_Error in (str, value) :: (pair ()) ) with JSON_Object_End -> [] in Object ( try let name = json_val lexbuf in let str = match name with | String x -> x | _ -> raise JSON_Error in json_valsep lexbuf; let value = try json_val lexbuf with JSON_Object_End -> raise JSON_Error in (str, value) :: (pair ()) with JSON_Object_End -> []) } | _ | eof { raise JSON_Error } and json_sep = parse | ',' { () } | ']' { raise JSON_Array_End } | '}' { raise JSON_Object_End } | ws+ { json_sep lexbuf } | _ | eof { raise JSON_Error } and json_valsep = parse | ':' { () } | '}' { raise JSON_Object_End } | ws+ { json_valsep lexbuf } | _ | eof { raise JSON_Error } and json_string str = parse | "\\\"" { json_string (str ^ "\"") lexbuf } | "\\\\" { json_string (str ^ "\\") lexbuf } | "\\/" { json_string (str ^ "/") lexbuf } | "\\b" { json_string (str ^ "\b") lexbuf } | "\\f" { json_string (str ^ "\x0c") lexbuf } | "\\n" { json_string (str ^ "\n") lexbuf } | "\\r" { json_string (str ^ "\r") lexbuf } | "\\t" { json_string (str ^ "\t") lexbuf } | "\\u" (hex as a) (hex as b) (hex as c) (hex as d) { json_string (str ^ (utf8_of_bytes (int_of_hex a) (int_of_hex b) (int_of_hex c) (int_of_hex d))) lexbuf } | strlit+ as s { json_string (str ^ s) lexbuf } | '"' { str } | _ | eof { raise JSON_Error } and json_string_write out = parse | "\\" { out "\\\\"; json_string_write out lexbuf } | "\"" { out "\\\""; json_string_write out lexbuf } | "\b" { out "\\b"; json_string_write out lexbuf } | "\x0c" { out "\\f"; json_string_write out lexbuf } | "\n" { out "\\n"; json_string_write out lexbuf } | "\r" { out "\\r"; json_string_write out lexbuf } | "\t" { out "\\t"; json_string_write out lexbuf } | [^ '\\' '"' '\x00'-'\x1F' '\x7F' ]+ as s { out s; json_string_write out lexbuf } | [ '\x00'-'\x1F' '\x7F' ] as c { out (hex_of_int (int_of_char c)); json_string_write out lexbuf } | eof { () } (* F O O T E R *) { let json_of_string str = json_val (Lexing.from_string str) let json_of_channel ch = json_val (Lexing.from_channel ch) let json_of_function f = json_val (Lexing.from_function f) let json_out_str out str = out "\""; json_string_write out (Lexing.from_string str); out "\"" let rec json_gen out obj = match obj with | Null -> out "null" | Bool false -> out "false" | Bool true -> out "true" | Int x | Number x -> out x | String x -> json_out_str out x | Array l -> ( out "["; let i = ref false in List.iter (fun x -> (match !i with true -> out "," | false -> i := true); json_gen out x ) l; out "]" ) | Object l -> ( out "{"; let i = ref false in List.iter (fun (n,v) -> (match !i with true -> out "," | false -> i := true); json_out_str out n; out ":"; json_gen out v ) l; out "}" ) let string_of_json obj = let str = ref "" in json_gen (fun s -> str := !str ^ s) obj; !str (* convenience functions *) let get_string = function | String x -> x | _ -> raise JSON_Incorrect_Type let get_bool = function | Bool x -> x | _ -> raise JSON_Incorrect_Type let get_int = function | Int x -> x | _ -> raise JSON_Incorrect_Type let get_number = function | Number x -> x | _ -> raise JSON_Incorrect_Type let get_array = function | Array x -> x | _ -> raise JSON_Incorrect_Type let get_object = function | Object x -> x | _ -> raise JSON_Incorrect_Type let get_value obj key = match obj with | Object l -> let _,v = List.find (fun (n,_) -> n = key) l in v | _ -> raise JSON_Incorrect_Type }