From c66f0232f55d9267166a3876e283fadc2c174b32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Sat, 9 Dec 2017 05:24:05 +0100 Subject: [PATCH] RPC: add BSON serialization --- lib_data_encoding/data_encoding.ml | 14 ++++++++++ lib_data_encoding/data_encoding.mli | 16 +++++++++++ lib_rpc-http/RPC_client.ml | 18 ++++++++++++- lib_rpc-http/media_type.ml | 42 +++++++++++++++++++++++++++-- lib_rpc-http/media_type.mli | 1 + 5 files changed, 88 insertions(+), 3 deletions(-) diff --git a/lib_data_encoding/data_encoding.ml b/lib_data_encoding/data_encoding.ml index c48091cd0..ac6b7f321 100644 --- a/lib_data_encoding/data_encoding.ml +++ b/lib_data_encoding/data_encoding.ml @@ -14,6 +14,7 @@ type json = | `A of json list | `Null | `String of string ] +type bson = Json_repr_bson.bson type json_schema = Json_schema.schema @@ -397,6 +398,19 @@ module Json = struct (fun msg -> raise (Cannot_destruct ([], Failure msg))) fmt + type t = json + +end + +module Bson = struct + + type t = Json_repr_bson.bson + + include Json_repr_bson.Json_encoding + + let construct e v = construct (Json.get_json e) v + let destruct e v = destruct (Json.get_json e) v + end module Encoding = struct diff --git a/lib_data_encoding/data_encoding.mli b/lib_data_encoding/data_encoding.mli index 12435175a..96a7113cd 100644 --- a/lib_data_encoding/data_encoding.mli +++ b/lib_data_encoding/data_encoding.mli @@ -58,6 +58,7 @@ type json = | `A of json list | `Null | `String of string ] +type bson = Json_repr_bson.bson type json_schema = Json_schema.schema @@ -380,6 +381,8 @@ val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding module Json : sig + type t = json + (** Create a {!Json_encoding.encoding} from an {encoding}. *) val convert : 'a encoding -> 'a Json_encoding.encoding @@ -438,6 +441,19 @@ module Json : sig end +module Bson : sig + + type t = Json_repr_bson.bson + + (** Construct a BSON object from an encoding. *) + val construct : 't encoding -> 't -> bson + + (** Destruct a BSON object into a value. + Fail with an exception if the JSON object and encoding do not match.. *) + val destruct : 't encoding -> bson -> 't + +end + (** Classify an encoding wrt. its binary serialization as explained in the preamble. *) val classify : 'a encoding -> [ `Fixed of int | `Dynamic | `Variable ] diff --git a/lib_rpc-http/RPC_client.ml b/lib_rpc-http/RPC_client.ml index 6e245c34c..1064a0f09 100644 --- a/lib_rpc-http/RPC_client.ml +++ b/lib_rpc-http/RPC_client.ml @@ -271,7 +271,7 @@ let generic_json_call ?logger ?body meth uri : (Data_encoding.json, Data_encodin (Cohttp_lwt.Body.of_string (Data_encoding_ezjsonm.to_string b)) end in let media = Media_type.json in - generic_call meth ?logger ~accept:[Media_type.json] ?body ~media uri >>=? function + generic_call meth ?logger ~accept:Media_type.[bson ; json] ?body ~media uri >>=? function | `Ok (body, (Some ("application", "json") | None), _) -> begin Cohttp_lwt.Body.to_string body >>= fun body -> match Data_encoding_ezjsonm.from_string body with @@ -282,6 +282,22 @@ let generic_json_call ?logger ?body meth uri : (Data_encoding.json, Data_encodin media_type = Media_type.(name json) ; error = msg }) end + | `Ok (body, Some ("application", "bson"), _) -> begin + Cohttp_lwt.Body.to_string body >>= fun body -> + match Json_repr_bson.bytes_to_bson ~laziness:false ~copy:false + (Bytes.unsafe_of_string body) with + | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) -> + let error = Format.asprintf "(at offset: %d) %s" pos msg in + request_failed meth uri + (Unexpected_content { content = body ; + media_type = Media_type.(name bson) ; + error }) + | bson -> + return (`Ok (Json_repr.convert + (module Json_repr_bson.Repr) + (module Json_repr.Ezjsonm) + bson)) + end | `Ok (_body, Some (l, r), _) -> request_failed meth uri (Unexpected_content_type { received = l^"/"^r ; diff --git a/lib_rpc-http/media_type.ml b/lib_rpc-http/media_type.ml index 0c8e1260f..a955a9f25 100644 --- a/lib_rpc-http/media_type.ml +++ b/lib_rpc-http/media_type.ml @@ -39,9 +39,47 @@ let json = { end ; } + +let bson = { + name = Cohttp.Accept.MediaType ("application", "bson") ; + q = Some 100 ; + pp = begin fun _enc ppf raw -> + match Json_repr_bson.bytes_to_bson ~laziness:false ~copy:false + (Bytes.unsafe_of_string raw) with + | exception Json_repr_bson.Bson_decoding_error (msg, _, _) -> + Format.fprintf ppf + "@[Invalid BSON:@ %s@]" + msg + | bson -> + let json = + Json_repr.convert + (module Json_repr_bson.Repr) + (module Json_repr.Ezjsonm) + bson in + Data_encoding_ezjsonm.pp ppf json + end ; + construct = begin fun enc v -> + Bytes.unsafe_to_string @@ + Json_repr_bson.bson_to_bytes @@ + Data_encoding.Bson.construct enc v + end ; + destruct = begin fun enc body -> + match Json_repr_bson.bytes_to_bson ~laziness:false ~copy:false + (Bytes.unsafe_of_string body) with + | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) -> + Error (Format.asprintf "(at offset: %d) %s" pos msg) + | bson -> + try Ok (Data_encoding.Bson.destruct enc bson) + with Data_encoding.Json.Cannot_destruct (_, exn) -> + Error (Format.asprintf "%a" + (fun fmt -> Data_encoding.Json.print_error fmt) + exn) + end ; +} + let octet_stream = { name = Cohttp.Accept.MediaType ("application", "octet-stream") ; - q = Some 500 ; + q = Some 200 ; pp = begin fun enc ppf raw -> match Data_encoding.Binary.of_bytes enc (MBytes.of_string raw) with | None -> Format.fprintf ppf "Invalid bonary data." @@ -61,4 +99,4 @@ let octet_stream = { end ; } -let all_media_types = [ json ; octet_stream ] +let all_media_types = [ json ; bson ; octet_stream ] diff --git a/lib_rpc-http/media_type.mli b/lib_rpc-http/media_type.mli index 10a557bd8..40a7d0da7 100644 --- a/lib_rpc-http/media_type.mli +++ b/lib_rpc-http/media_type.mli @@ -18,6 +18,7 @@ type t = Resto_cohttp.Media_type.Make(RPC_encoding).t = { val name : t -> string val json : t +val bson : t val octet_stream : t val all_media_types : t list