Resto: split Resto_cohttp.Server

bin_node/node_run_command.ml

@@ -176,7 +176,7 @@ let init_rpc (rpc_config: Node_config_file.rpc) node =
             port
             (if rpc_config.tls = None then "" else " (TLS enabled)") >>= fun () ->
           RPC_server.launch ~host mode dir
-            ~media_types:RPC_server.[ json ; octet_stream ]
+            ~media_types:Media_type.all_media_types
             ~cors:{ allowed_origins = rpc_config.cors_origins ;
                     allowed_headers = rpc_config.cors_headers } >>= fun server ->
           return (Some server)

lib_node_http/RPC_server.ml

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type cors = Resto_cohttp.Server.cors = {
+type cors = Resto_cohttp.Cors.t = {
   allowed_headers : string list ;
   allowed_origins : string list ;
 }
@@ -16,34 +16,3 @@ include Resto_directory
 module Directory = Resto_directory.Make(RPC.Data)
 
 include Resto_cohttp.Server.Make(RPC.Data)(Logging.RPC)
-
-let json  = {
-  name = "application/json" ;
-  construct = begin fun enc v ->
-    Data_encoding_ezjsonm.to_string @@
-    Data_encoding.Json.construct enc v
-  end ;
-  destruct = begin fun enc body ->
-    match Data_encoding_ezjsonm.from_string body with
-    | Error _ as err -> err
-    | Ok json ->
-        try Ok (Data_encoding.Json.destruct enc json)
-        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 = "application/octet-stream" ;
-  construct = begin fun enc v ->
-    MBytes.to_string @@
-    Data_encoding.Binary.to_bytes enc v
-  end ;
-  destruct = begin fun enc s ->
-    match Data_encoding.Binary.of_bytes enc (MBytes.of_string s) with
-    | None -> Error "Failed to parse binary data."
-    | Some data -> Ok data
-  end ;
-}

lib_node_http/RPC_server.mli

@@ -19,15 +19,6 @@ type cors = {
   allowed_origins : string list ;
 }
 
-type media_type = {
-  name: string ;
-  construct: 'a. 'a Data_encoding.t -> 'a -> string ;
-  destruct: 'a. 'a Data_encoding.t -> string -> ('a, string) result ;
-}
-
-val json : media_type
-val octet_stream : media_type
-
 (** A handle on the server worker. *)
 type server
 
@@ -35,7 +26,7 @@ type server
 val launch :
   ?host:string ->
   ?cors:cors ->
-  media_types:media_type list ->
+  media_types:Media_type.t list ->
   Conduit_lwt_unix.server ->
   unit Directory.t ->
   server Lwt.t

lib_node_http/media_type.ml

@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Resto_cohttp.Media_type.Make(RPC.Data)
+
+let json  = {
+  name = Cohttp.Accept.MediaType ("application", "json") ;
+  q = Some 1000 ;
+  construct = begin fun enc v ->
+    Data_encoding_ezjsonm.to_string @@
+    Data_encoding.Json.construct enc v
+  end ;
+  destruct = begin fun enc body ->
+    match Data_encoding_ezjsonm.from_string body with
+    | Error _ as err -> err
+    | Ok json ->
+        try Ok (Data_encoding.Json.destruct enc json)
+        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 ;
+  construct = begin fun enc v ->
+    MBytes.to_string @@
+    Data_encoding.Binary.to_bytes enc v
+  end ;
+  destruct = begin fun enc s ->
+    match Data_encoding.Binary.of_bytes enc (MBytes.of_string s) with
+    | None -> Error "Failed to parse binary data."
+    | Some data -> Ok data
+  end ;
+}
+
+let all_media_types = [ json ; octet_stream ]

lib_node_http/media_type.mli

@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = Resto_cohttp.Media_type.Make(RPC.Data).t = {
+  name: Cohttp.Accept.media_range ;
+  q: int option ;
+  construct: 'a. 'a Data_encoding.t -> 'a -> string ;
+  destruct: 'a. 'a Data_encoding.t -> string -> ('a, string) result ;
+}
+
+val json : t
+val octet_stream : t
+
+val all_media_types : t list
+
+
+val accept_header : t list -> string
+val first_complete_media : t list -> ((string * string) * t) option

vendors/ocplib-resto/lib_resto-cohttp/cors.ml

@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  allowed_headers : string list ;
+  allowed_origins : string list ;
+}
+
+let default = { allowed_headers = [] ; allowed_origins = [] }
+
+let check_origin_matches origin allowed_origin =
+  String.equal "*" allowed_origin ||
+  String.equal allowed_origin origin ||
+  begin
+    let allowed_w_slash = allowed_origin ^ "/" in
+    let len_a_w_s = String.length allowed_w_slash in
+    let len_o = String.length origin in
+    (len_o >= len_a_w_s) &&
+    String.equal allowed_w_slash @@ String.sub origin 0 len_a_w_s
+  end
+
+let find_matching_origin allowed_origins origin =
+  let matching_origins =
+    List.filter (check_origin_matches origin) allowed_origins in
+  let compare_by_length_neg a b =
+    ~- (compare (String.length a) (String.length b)) in
+  let matching_origins_sorted =
+    List.sort compare_by_length_neg matching_origins in
+  match matching_origins_sorted with
+  | [] -> None
+  | x :: _ -> Some x
+
+let add_headers headers cors origin_header =
+  let cors_headers =
+    Cohttp.Header.add_multi headers
+      "Access-Control-Allow-Headers" cors.allowed_headers in
+  match origin_header with
+  | None -> cors_headers
+  | Some origin ->
+      match find_matching_origin cors.allowed_origins origin with
+      | None -> cors_headers
+      | Some allowed_origin ->
+          Cohttp.Header.add_multi cors_headers
+            "Access-Control-Allow-Origin" [allowed_origin]

vendors/ocplib-resto/lib_resto-cohttp/cors.mli

@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  allowed_headers : string list ;
+  allowed_origins : string list ;
+}
+
+val default: t
+
+val add_headers:
+  Cohttp.Header.t -> t -> string option -> Cohttp.Header.t
+

vendors/ocplib-resto/lib_resto-cohttp/media_type.ml

@@ -0,0 +1,85 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Make (Encoding : Resto.ENCODING) = struct
+
+  open Cohttp
+
+  type t = {
+    name: Cohttp.Accept.media_range ;
+    q: int option ;
+    construct: 'a. 'a Encoding.t -> 'a -> string ;
+    destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
+  }
+
+  let name_of_media_type = function
+    | Accept.AnyMedia            -> "*/*"
+    | AnyMediaSubtype type_      -> type_ ^ "/*"
+    | MediaType (type_, subtype) -> type_ ^ "/" ^ subtype
+
+  let name { name ; _ } = name_of_media_type name
+
+  let rec has_complete_media = function
+    | [] -> false
+    | { name = MediaType _ ; _ } :: _ -> true
+    | _ :: l -> has_complete_media l
+
+  let rec first_complete_media = function
+    | [] -> None
+    | { name = MediaType (l,r) ; _ } as m :: _ -> Some ((l, r), m)
+    | _ :: l -> first_complete_media l
+
+  let matching_media (type_, subtype) = function
+    | Accept.AnyMedia       -> true
+    | AnyMediaSubtype type_'       -> type_' = type_
+    | MediaType (type_', subtype') -> type_' = type_ && subtype' = subtype
+
+  let rec find_media received = function
+    | [] -> None
+    | { name ; _ } as media :: _ when matching_media received name ->
+        Some media
+    | _ :: mts -> find_media received mts
+
+  (* Inspired from ocaml-webmachine *)
+
+  let media_match (_, (range, _)) media =
+    match media.name with
+    | AnyMedia | AnyMediaSubtype _ -> false
+    | MediaType (type_, subtype) ->
+        let open Accept in
+        match range with
+        | AnyMedia                     -> true
+        | AnyMediaSubtype type_'       -> type_' = type_
+        | MediaType (type_', subtype') -> type_' = type_ && subtype' = subtype
+
+  let resolve_accept_header provided header =
+    let ranges = Accept.(media_ranges header |> qsort) in
+    let rec loop = function
+      | [] -> None
+      | r :: rs ->
+          try
+            let media = List.find (media_match r) provided in
+            Some (name_of_media_type media.name, media)
+          with Not_found -> loop rs
+    in
+    loop ranges
+
+  let accept_header ranges =
+    let ranges =
+      List.map (fun r ->
+          let q = match r.q with None -> 1000 | Some i -> i in
+          (q, (r.name, []))) ranges in
+    (Accept.string_of_media_ranges ranges)
+
+  let acceptable_encoding ranges =
+    String.concat ", "
+      (List.map (fun f -> name_of_media_type f.name) ranges)
+
+end

vendors/ocplib-resto/lib_resto-cohttp/media_type.mli

@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*  ocplib-resto                                                          *)
+(*  Copyright (C) 2016, OCamlPro.                                         *)
+(*                                                                        *)
+(*    All rights reserved.  This file is distributed under the terms      *)
+(*    of the GNU Lesser General Public License version 2.1, with the      *)
+(*    special exception on linking described in the file LICENSE.         *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Make (Encoding : Resto.ENCODING) : sig
+
+  type t = {
+    name: Cohttp.Accept.media_range ;
+    q: int option ;
+    construct: 'a. 'a Encoding.t -> 'a -> string ;
+    destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
+  }
+
+  val name: t -> string
+
+  val has_complete_media: t list -> bool
+  val first_complete_media: t list -> ((string * string) * t) option
+
+  val find_media: (string * string) -> t list -> t option
+
+  val resolve_accept_header: t list -> string option -> (string * t) option
+
+  val accept_header: t list -> string
+  val acceptable_encoding: t list -> string
+
+end

vendors/ocplib-resto/lib_resto-cohttp/server.ml

@@ -9,77 +9,6 @@
 
 open Lwt.Infix
 
-module Utils = struct
-
-  let split_path path =
-    let l = String.length path in
-    let rec do_slashes acc i =
-      if i >= l then
-        List.rev acc
-      else if String.get path i = '/' then
-        do_slashes acc (i + 1)
-      else
-        do_component acc i i
-    and do_component acc i j =
-      if j >= l then
-        if i = j then
-          List.rev acc
-        else
-          List.rev (String.sub path i (j - i) :: acc)
-      else if String.get path j = '/' then
-        do_slashes (String.sub path i (j - i) :: acc) j
-      else
-        do_component acc i (j + 1) in
-    do_slashes [] 0
-
-end
-
-type cors = {
-  allowed_headers : string list ;
-  allowed_origins : string list ;
-}
-
-module Cors = struct
-
-  let default = { allowed_headers = [] ; allowed_origins = [] }
-
-  let check_origin_matches origin allowed_origin =
-    String.equal "*" allowed_origin ||
-    String.equal allowed_origin origin ||
-    begin
-      let allowed_w_slash = allowed_origin ^ "/" in
-      let len_a_w_s = String.length allowed_w_slash in
-      let len_o = String.length origin in
-      (len_o >= len_a_w_s) &&
-      String.equal allowed_w_slash @@ String.sub origin 0 len_a_w_s
-    end
-
-  let find_matching_origin allowed_origins origin =
-    let matching_origins =
-      List.filter (check_origin_matches origin) allowed_origins in
-    let compare_by_length_neg a b =
-      ~- (compare (String.length a) (String.length b)) in
-    let matching_origins_sorted =
-      List.sort compare_by_length_neg matching_origins in
-    match matching_origins_sorted with
-    | [] -> None
-    | x :: _ -> Some x
-
-  let add_headers headers cors origin_header =
-    let cors_headers =
-      Cohttp.Header.add_multi headers
-        "Access-Control-Allow-Headers" cors.allowed_headers in
-    match origin_header with
-    | None -> cors_headers
-    | Some origin ->
-        match find_matching_origin cors.allowed_origins origin with
-        | None -> cors_headers
-        | Some allowed_origin ->
-            Cohttp.Header.add_multi cors_headers
-              "Access-Control-Allow-Origin" [allowed_origin]
-
-end
-
 module ConnectionMap = Map.Make(Cohttp.Connection)
 
 module type LOGGING = sig
@@ -106,46 +35,14 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
   module Service = Resto.MakeService(Encoding)
   module Directory = Resto_directory.Make(Encoding)
 
-  type media_type = {
+  module Media_type = Media_type.Make(Encoding)
-    name: string ;
-    construct: 'a. 'a Encoding.t -> 'a -> string ;
-    destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
-  }
-
-  module Media_type = struct
-
-    (* Inspired from ocaml-webmachine *)
-
-    let media_match (_, (range, _)) media =
-      let type_, subtype =
-        match Utils.split_path media.name with
-        | [x ; y] -> x, y
-        | _      ->
-            Format.kasprintf invalid_arg "invalid media_type '%s'" media.name in
-      let open Accept in
-      match range with
-      | AnyMedia                     -> true
-      | AnyMediaSubtype type_'       -> type_' = type_
-      | MediaType (type_', subtype') -> type_' = type_ && subtype' = subtype
-
-    let match_header provided header =
-      let ranges = Accept.(media_ranges header |> qsort) in
-      let rec loop = function
-        | [] -> None
-        | r :: rs ->
-            try Some(List.find (media_match r) provided)
-            with Not_found -> loop rs
-      in
-      loop ranges
-
-  end
 
   type server = {
     root : unit Directory.directory ;
     mutable streams : (unit -> unit) ConnectionMap.t ;
-    cors : cors ;
+    cors : Cors.t ;
-    media_types : media_type list ;
+    media_types : Media_type.t list ;
-    default_media_type : media_type ;
+    default_media_type : string * Media_type.t ;
     stopper : unit Lwt.u ;
     mutable worker : unit Lwt.t ;
   }
@@ -187,23 +84,31 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
             meth path >>=? fun (Directory.Service s) ->
           begin
             match Header.get req_headers "content-type" with
-            | None -> Lwt.return_ok server.default_media_type
+            | None -> Lwt.return_ok (snd server.default_media_type)
             | Some content_type ->
-                match List.find (fun { name ; _ } -> name = content_type)
+                match Utils.split_path content_type with
-                        server.media_types with
+                | [x ; y] -> begin
-                | exception Not_found ->
+                    match Media_type.find_media (x, y) server.media_types with
+                    | None ->
+                        Lwt.return_error (`Unsupported_media_type content_type)
+                    | Some media_type ->
+                        Lwt.return_ok media_type
+                  end
+                | _ ->
                     Lwt.return_error (`Unsupported_media_type content_type)
-                | media_type -> Lwt.return_ok media_type
           end >>=? fun input_media_type ->
+          lwt_debug "(%s) input media type %s"
+            (Connection.to_string con)
+            (Media_type.name input_media_type) >>= fun () ->
           begin
             match Header.get req_headers "accept" with
             | None -> Lwt.return_ok server.default_media_type
             | Some accepted ->
-                match Media_type.match_header
+                match Media_type.resolve_accept_header
                         server.media_types (Some accepted) with
                 | None -> Lwt.return_error `Not_acceptable
                 | Some media_type -> Lwt.return_ok media_type
-          end >>=? fun output_media_type ->
+          end >>=? fun (output_content_type, output_media_type) ->
           begin
             match Resto.Query.parse s.types.query
                     (List.map
@@ -213,6 +118,9 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
                 Lwt.return_error (`Cannot_parse_query s)
             | query -> Lwt.return_ok query
           end >>=? fun query ->
+          lwt_debug "(%s) ouput media type %s"
+            (Connection.to_string con)
+            (Media_type.name output_media_type) >>= fun () ->
           let output = output_media_type.construct s.types.output
           and error = function
             | None -> Cohttp_lwt.Body.empty, Transfer.Fixed 0L
@@ -222,7 +130,7 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
                 Transfer.Fixed (Int64.of_int (String.length s)) in
           let headers = Header.init () in
           let headers =
-            Header.add headers "content-type" output_media_type.name in
+            Header.add headers "content-type" output_content_type in
           begin
             match s.types.input with
             | Service.No_input ->
@@ -367,9 +275,7 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
              "Failed to parse the query string: %s" s)
     | Error `Not_acceptable ->
         let accepted_encoding =
-          String.concat ", "
+          Media_type.acceptable_encoding server.media_types in
-            (List.map (fun f -> f.name)
-               server.media_types) in
         Lwt.return
           (Response.make ~status:`Not_acceptable (),
            Cohttp_lwt.Body.of_string accepted_encoding)
@@ -389,9 +295,10 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
       ?(cors = Cors.default)
       ~media_types
       mode root =
-    if media_types = [] then
+    let default_media_type =
-      invalid_arg "RestoCohttp.launch(empty media type list)" ;
+      match Media_type.first_complete_media media_types with
-    let default_media_type = List.hd media_types in
+      | None -> invalid_arg "RestoCohttp.launch(empty media type list)"
+      | Some ((l, r), m) -> l^"/"^r, m in
     let stop, stopper = Lwt.wait () in
     let server = {
       root ;

vendors/ocplib-resto/lib_resto-cohttp/server.mli

@@ -10,11 +10,6 @@
 
 (** Typed RPC services: server implementation. *)
 
-type cors = {
-  allowed_headers : string list ;
-  allowed_origins : string list ;
-}
-
 module type LOGGING = sig
 
   val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
@@ -33,20 +28,14 @@ end
 
 module Make (Encoding : Resto.ENCODING) (Log : LOGGING) : sig
 
-  type media_type = {
-    name: string ;
-    construct: 'a. 'a Encoding.t -> 'a -> string ;
-    destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
-  }
-
   (** A handle on the server worker. *)
   type server
 
   (** Promise a running RPC server.*)
   val launch :
     ?host:string ->
-    ?cors:cors ->
+    ?cors:Cors.t ->
-    media_types:media_type list ->
+    media_types:Media_type.Make(Encoding).t list ->
     Conduit_lwt_unix.server ->
     unit Resto_directory.Make(Encoding).t ->
     server Lwt.t

vendors/ocplib-resto/lib_resto-cohttp/utils.ml

@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+let split_path path =
+  let l = String.length path in
+  let rec do_slashes acc i =
+    if i >= l then
+      List.rev acc
+    else if String.get path i = '/' then
+      do_slashes acc (i + 1)
+    else
+      do_component acc i i
+  and do_component acc i j =
+    if j >= l then
+      if i = j then
+        List.rev acc
+      else
+        List.rev (String.sub path i (j - i) :: acc)
+    else if String.get path j = '/' then
+      do_slashes (String.sub path i (j - i) :: acc) j
+    else
+      do_component acc i (j + 1) in
+  do_slashes [] 0

vendors/ocplib-resto/lib_resto-cohttp/utils.mli

@@ -0,0 +1,10 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val split_path: string -> string list