RPC: add BSON serialization

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

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 ]
 

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 ;

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 ]

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