Shell/RPC: enforce Host when using CORS.

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

@@ -67,3 +67,11 @@ let add_headers headers cors origin_header =
     Cohttp.Header.add_multi headers
       "Access-Control-Allow-Headers" cors.allowed_headers in
   add_allow_origin cors_headers cors origin_header
+
+let check_host headers cors =
+  match Cohttp.Header.get headers "Host" with
+  | None -> List.mem "*" cors.allowed_origins
+  | Some host ->
+      match find_matching_origin cors.allowed_origins host with
+      | None -> false
+      | Some _ -> true

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

@@ -36,3 +36,4 @@ val add_allow_origin:
 val add_headers:
   Cohttp.Header.t -> t -> string option -> Cohttp.Header.t
 
+val check_host: Cohttp.Header.t -> t -> bool

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

@@ -86,8 +86,7 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
     | Ok x -> f x
     | Error err -> Lwt.return_error err
 
-  let callback server (_io, con) req body =
-    (* FIXME: check inbound adress *)
+  let callback server ((_io, con) : Cohttp_lwt_unix.Server.conn) req body =
     let uri = Request.uri req in
     let path = Uri.pct_decode (Uri.path uri) in
     lwt_log_info "(%s) receive request to %s"
@@ -96,6 +95,11 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct
     let req_headers = Request.headers req in
     begin
       match Request.meth req with
+      | #Resto.meth when server.cors.allowed_origins <> [] &&
+                         not (Cors.check_host req_headers server.cors) ->
+          Lwt.return_ok
+            (Response.make ~status:`Forbidden (),
+             Cohttp_lwt.Body.empty)
       | #Resto.meth as meth -> begin
           Directory.lookup server.root ()
             meth path >>=? fun (Directory.Service s) ->