Remove BufIO HTTP handler type completely

HTTP handlers of type BufIO did not actually read from through the
buffer at all. Instead, they all assert that the buffer is empty and
then simply use the file descriptor.

All HTTP handlers now directly use file descriptors. The handler type
simply becomes:

    type 'a handler = Http.Request.t -> Unix.file_descr -> 'a -> unit

Signed-off-by: Rob Hoes <[email protected]>

ocaml/database/db_remote_cache_access_v1.ml

@@ -126,11 +126,10 @@ module DBCacheRemoteListener = struct
         raise e
 end
 
-let handler req bio _ =
-  let fd = Buf_io.fd_of bio in
+let handler req fd _ =
   (* fd only used for writing *)
   let body =
-    Http_svr.read_body ~limit:Db_globs.http_limit_max_rpc_size req bio
+    Http_svr.read_body ~limit:Db_globs.http_limit_max_rpc_size req fd
   in
   let body_xml = Xml.parse_string body in
   let reply_xml = DBCacheRemoteListener.process_xmlrpc body_xml in

ocaml/database/db_remote_cache_access_v1.mli

@@ -1,2 +1,2 @@
-val handler : Http.Request.t -> Buf_io.t -> 'a -> unit
+val handler : Http.Request.t -> Unix.file_descr -> 'a -> unit
 (** HTTP handler for v1 of the remote DB access protocol *)

ocaml/database/db_remote_cache_access_v2.ml

@@ -67,11 +67,10 @@ let process_rpc (req : Rpc.t) =
         Response.Too_many_values (x, y, z)
     )
 
-let handler req bio _ =
-  let fd = Buf_io.fd_of bio in
+let handler req fd _ =
   (* fd only used for writing *)
   let body =
-    Http_svr.read_body ~limit:Db_globs.http_limit_max_rpc_size req bio
+    Http_svr.read_body ~limit:Db_globs.http_limit_max_rpc_size req fd
   in
   let request_rpc = Jsonrpc.of_string body in
   let reply_rpc = process_rpc request_rpc in

ocaml/database/db_remote_cache_access_v2.mli

@@ -1,2 +1,2 @@
-val handler : Http.Request.t -> Buf_io.t -> 'a -> unit
+val handler : Http.Request.t -> Unix.file_descr -> 'a -> unit
 (** HTTP handler for v2 of the remote DB access protocol *)

ocaml/libs/http-lib/http_svr.ml

@@ -67,9 +67,7 @@ module Stats = struct
 end
 
 (** Type of a function which can handle a Request.t *)
-type 'a handler =
-  | BufIO of (Http.Request.t -> Buf_io.t -> 'a -> unit)
-  | FdIO of (Http.Request.t -> Unix.file_descr -> 'a -> unit)
+type 'a handler = Http.Request.t -> Unix.file_descr -> 'a -> unit
 
 (* try and do f (unit -> unit), ignore exceptions *)
 let best_effort f = try f () with _ -> ()
@@ -270,19 +268,15 @@ let respond_to_options req s =
     (fun _ -> ())
 
 (** If no handler matches the request then call this callback *)
-let default_callback req bio _ =
-  response_forbidden (Buf_io.fd_of bio) ;
+let default_callback req fd _ =
+  response_forbidden fd ;
   req.Request.close <- true
 
 module TE = struct
   type 'a t = {stats: Stats.t; stats_m: Mutex.t; handler: 'a handler}
 
   let empty () =
-    {
-      stats= Stats.empty ()
-    ; stats_m= Mutex.create ()
-    ; handler= BufIO default_callback
-    }
+    {stats= Stats.empty (); stats_m= Mutex.create (); handler= default_callback}
 end
 
 module MethodMap = Map.Make (struct
@@ -499,7 +493,6 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd =
 let handle_one (x : 'a Server.t) ss context req =
   let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in
   let span = Http.Request.traceparent_of req in
-  let ic = Buf_io.of_fd ss in
   let finished = ref false in
   try
     D.debug "Request %s" (Http.Request.to_string req) ;
@@ -513,14 +506,7 @@ let handle_one (x : 'a Server.t) ss context req =
         (Radix_tree.longest_prefix req.Request.uri method_map)
     in
     let@ _ = Tracing.with_child_trace span ~name:"handler" in
-    ( match te.TE.handler with
-    | BufIO handlerfn ->
-        handlerfn req ic context
-    | FdIO handlerfn ->
-        let fd = Buf_io.fd_of ic in
-        Buf_io.assert_buffer_empty ic ;
-        handlerfn req fd context
-    ) ;
+    te.TE.handler req ss context ;
     finished := req.Request.close ;
     Stats.update te.TE.stats te.TE.stats_m req ;
     !finished
@@ -685,7 +671,7 @@ let stop (socket, _name) =
 exception Client_requested_size_over_limit
 
 (** Read the body of an HTTP request (requires a content-length: header). *)
-let read_body ?limit req bio =
+let read_body ?limit req fd =
   match req.Request.content_length with
   | None ->
       failwith "We require a content-length: HTTP header"
@@ -696,7 +682,7 @@ let read_body ?limit req bio =
           if length > l then raise Client_requested_size_over_limit
         )
         limit ;
-      Unixext.really_read_string (Buf_io.fd_of bio) length
+      Unixext.really_read_string fd length
 
 (* Helpers to determine the client of a call *)
 

ocaml/libs/http-lib/http_svr.mli

@@ -18,9 +18,7 @@
 type uri_path = string
 
 (** A handler is a function which takes a request and produces a response *)
-type 'a handler =
-  | BufIO of (Http.Request.t -> Buf_io.t -> 'a -> unit)
-  | FdIO of (Http.Request.t -> Unix.file_descr -> 'a -> unit)
+type 'a handler = Http.Request.t -> Unix.file_descr -> 'a -> unit
 
 module Stats : sig
   (** Statistics recorded per-handler *)
@@ -120,7 +118,7 @@ val respond_to_options : Http.Request.t -> Unix.file_descr -> unit
 
 val headers : Unix.file_descr -> string list -> unit
 
-val read_body : ?limit:int -> Http.Request.t -> Buf_io.t -> string
+val read_body : ?limit:int -> Http.Request.t -> Unix.file_descr -> string
 
 (* Helpers to determine the client of a call *)
 

ocaml/xapi-cli-server/xapi_cli.ml

@@ -346,11 +346,8 @@ let exception_handler s e =
         [Cli_util.string_of_exn exc]
         s
 
-let handler (req : Http.Request.t) (bio : Buf_io.t) _ =
-  let str =
-    Http_svr.read_body ~limit:Constants.http_limit_max_cli_size req bio
-  in
-  let s = Buf_io.fd_of bio in
+let handler (req : Http.Request.t) (s : Unix.file_descr) _ =
+  let str = Http_svr.read_body ~limit:Constants.http_limit_max_cli_size req s in
   (* Tell the client the server version *)
   marshal_protocol s ;
   (* Read the client's protocol version *)

ocaml/xapi/api_server.ml

@@ -90,13 +90,12 @@ let create_thumbprint_header req response =
      )
 
 (** HTML callback that dispatches an RPC and returns the response. *)
-let callback is_json req bio _ =
+let callback is_json req fd _ =
   let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in
   let span = Http.Request.traceparent_of req in
-  let fd = Buf_io.fd_of bio in
   (* fd only used for writing *)
   let body =
-    Http_svr.read_body ~limit:Constants.http_limit_max_rpc_size req bio
+    Http_svr.read_body ~limit:Constants.http_limit_max_rpc_size req fd
   in
   try
     let rpc =
@@ -145,13 +144,12 @@ let callback is_json req bio _ =
       Backtrace.is_important e ; raise e
 
 (** HTML callback that dispatches an RPC and returns the response. *)
-let jsoncallback req bio _ =
+let jsoncallback req fd _ =
   let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in
-  let fd = Buf_io.fd_of bio in
   (* fd only used for writing *)
   let body =
     Http_svr.read_body ~limit:Xapi_database.Db_globs.http_limit_max_rpc_size req
-      bio
+      fd
   in
   try
     let json_rpc_version, id, rpc =
@@ -182,6 +180,4 @@ let jsoncallback req bio _ =
          )
       )
 
-let options_callback req bio _ =
-  let fd = Buf_io.fd_of bio in
-  Http_svr.respond_to_options req fd
+let options_callback req fd _ = Http_svr.respond_to_options req fd

ocaml/xapi/audit_log.ml

@@ -122,9 +122,7 @@ let log_timestamp_of_iso8601 iso8601_timestamp =
  eg. /audit_log?...&since=2009-09-10T11:31
  eg. /audit_log?...&since=2009-09-10
 *)
-let handler (req : Request.t) (bio : Buf_io.t) _ =
-  let s = Buf_io.fd_of bio in
-  Buf_io.assert_buffer_empty bio ;
+let handler (req : Request.t) (s : Unix.file_descr) _ =
   req.Request.close <- true ;
   Xapi_http.with_context (* makes sure to signal task-completed to cli *)
     (Printf.sprintf "audit_log_get request") req s (fun __context ->

ocaml/xapi/fileserver.ml

@@ -55,10 +55,8 @@ let access_forbidden req s =
   !Xapi_globs.website_https_only && is_external_http req s
 
 let send_file (uri_base : string) (dir : string) (req : Request.t)
-    (bio : Buf_io.t) _ =
+    (s : Unix.file_descr) _ =
   let uri_base_len = String.length uri_base in
-  let s = Buf_io.fd_of bio in
-  Buf_io.assert_buffer_empty bio ;
   let is_external_http = is_external_http req s in
   if is_external_http && !Xapi_globs.website_https_only then
     Http_svr.response_forbidden ~req s

ocaml/xapi/storage_mux.ml

@@ -880,9 +880,8 @@ module Local_domain_socket = struct
   let path = Filename.concat "/var/lib/xcp" "storage"
 
   (* receives external requests on Constants.sm_uri *)
-  let xmlrpc_handler process req bio _ =
-    let body = Http_svr.read_body req bio in
-    let s = Buf_io.fd_of bio in
+  let xmlrpc_handler process req s _ =
+    let body = Http_svr.read_body req s in
     let rpc = Xmlrpc.call_of_string body in
     (* Printf.fprintf stderr "Request: %s %s\n%!" rpc.Rpc.name (Rpc.to_string (List.hd rpc.Rpc.params)); *)
     let result = process rpc in

ocaml/xapi/wlb_reports.ml

@@ -144,9 +144,8 @@ let trim_and_send method_name tag recv_sock send_sock =
     Workload_balancing.raise_malformed_response' method_name
       "Expected data is truncated." s
 
-let handle req bio _method_name tag (method_name, request_func) =
-  let client_sock = Buf_io.fd_of bio in
-  Buf_io.assert_buffer_empty bio ;
+let handle req fd _method_name tag (method_name, request_func) =
+  let client_sock = fd in
   debug "handle: fd = %d"
     (Xapi_stdext_unix.Unixext.int_of_file_descr client_sock) ;
   req.Request.close <- true ;
@@ -171,7 +170,7 @@ let handle req bio _method_name tag (method_name, request_func) =
 (* GET /wlb_report?session_id=<session>&task_id=<task>&
                    report=<report name>&<param1>=<value1>&...
 *)
-let report_handler (req : Request.t) (bio : Buf_io.t) _ =
+let report_handler (req : Request.t) (fd : Unix.file_descr) _ =
   if not (List.mem_assoc "report" req.Request.query) then (
     error "Request for WLB report lacked 'report' parameter" ;
     failwith "Bad request"
@@ -182,10 +181,10 @@ let report_handler (req : Request.t) (bio : Buf_io.t) _ =
       (fun (k, _) -> not (List.mem k ["session_id"; "task_id"; "report"]))
       req.Request.query
   in
-  handle req bio "ExecuteReport" report_tag
+  handle req fd "ExecuteReport" report_tag
     (Workload_balancing.wlb_report_request report params)
 
 (* GET /wlb_diagnostics?session_id=<session>&task_id=<task> *)
-let diagnostics_handler (req : Request.t) (bio : Buf_io.t) _ =
-  handle req bio "GetDiagnostics" diagnostics_tag
+let diagnostics_handler (req : Request.t) (fd : Unix.file_descr) _ =
+  handle req fd "GetDiagnostics" diagnostics_tag
     Workload_balancing.wlb_diagnostics_request

ocaml/xapi/xapi.ml

@@ -786,86 +786,69 @@ let startup_script () =
 let master_only_http_handlers =
   [
     (* CA-26044: don't let people DoS random slaves *)
-    ("post_remote_db_access", Http_svr.BufIO remote_database_access_handler)
-  ; ( "post_remote_db_access_v2"
-    , Http_svr.BufIO remote_database_access_handler_v2
-    )
-  ; ("get_repository", Http_svr.FdIO Repository.get_repository_handler)
-  ; ("get_updates", Http_svr.FdIO Xapi_pool.get_updates_handler)
+    ("post_remote_db_access", remote_database_access_handler)
+  ; ("post_remote_db_access_v2", remote_database_access_handler_v2)
+  ; ("get_repository", Repository.get_repository_handler)
+  ; ("get_updates", Xapi_pool.get_updates_handler)
   ]
 
 let common_http_handlers () =
   let handlers =
     [
-      ("get_services_xenops", Http_svr.FdIO Xapi_services.get_handler)
-    ; ("put_services_xenops", Http_svr.FdIO Xapi_services.put_handler)
-    ; ("post_services_xenops", Http_svr.FdIO Xapi_services.post_handler)
-    ; ("get_services_sm", Http_svr.FdIO Xapi_services.get_handler)
-    ; ("put_services_sm", Http_svr.FdIO Xapi_services.put_handler)
-    ; ("post_services_sm", Http_svr.FdIO Xapi_services.post_handler)
-    ; ("get_services", Http_svr.FdIO Xapi_services.get_handler)
-    ; ("post_services", Http_svr.FdIO Xapi_services.post_handler)
-    ; ("put_services", Http_svr.FdIO Xapi_services.put_handler)
-    ; ("put_import", Http_svr.FdIO Import.handler)
-    ; ("put_import_metadata", Http_svr.FdIO Import.metadata_handler)
-    ; ("put_import_raw_vdi", Http_svr.FdIO Import_raw_vdi.handler)
-    ; ("get_export", Http_svr.FdIO Export.handler)
-    ; ("get_export_metadata", Http_svr.FdIO Export.metadata_handler)
-    ; ("get_export_raw_vdi", Http_svr.FdIO Export_raw_vdi.handler)
-    ; ("connect_console", Http_svr.FdIO (Console.handler Console.real_proxy))
-    ; ("connect_console_ws", Http_svr.FdIO (Console.handler Console.ws_proxy))
-    ; ("post_cli", Http_svr.BufIO Xapi_cli.handler)
-    ; ("get_host_backup", Http_svr.FdIO Xapi_host_backup.host_backup_handler)
-    ; ("put_host_restore", Http_svr.FdIO Xapi_host_backup.host_restore_handler)
-    ; ( "get_host_logs_download"
-      , Http_svr.FdIO Xapi_logs_download.logs_download_handler
-      )
-    ; ( "put_pool_patch_upload"
-      , Http_svr.FdIO Xapi_pool_patch.pool_patch_upload_handler
-      )
-    ; ("get_vncsnapshot", Http_svr.FdIO Xapi_vncsnapshot.vncsnapshot_handler)
-    ; ( "get_pool_xml_db_sync"
-      , Http_svr.FdIO Pool_db_backup.pull_database_backup_handler
-      )
-    ; ( "put_pool_xml_db_sync"
-      , Http_svr.FdIO Pool_db_backup.push_database_restore_handler
-      )
-    ; ( "get_config_sync"
-      , Http_svr.FdIO Config_file_sync.config_file_sync_handler
-      )
-    ; ("get_system_status", Http_svr.FdIO System_status.handler)
-    ; (Constants.get_vm_rrd, Http_svr.FdIO Rrdd_proxy.get_vm_rrd_forwarder)
-    ; (Constants.get_host_rrd, Http_svr.FdIO Rrdd_proxy.get_host_rrd_forwarder)
-    ; (Constants.get_sr_rrd, Http_svr.FdIO Rrdd_proxy.get_sr_rrd_forwarder)
-    ; ( Constants.get_rrd_updates
-      , Http_svr.FdIO Rrdd_proxy.get_rrd_updates_forwarder
-      )
-    ; (Constants.put_rrd, Http_svr.FdIO Rrdd_proxy.put_rrd_forwarder)
-    ; ("get_blob", Http_svr.FdIO Xapi_blob.handler)
-    ; ("put_blob", Http_svr.FdIO Xapi_blob.handler)
-    ; ("put_messages", Http_svr.FdIO Xapi_message.handler)
-    ; ("connect_remotecmd", Http_svr.FdIO Xapi_remotecmd.handler)
-    ; ("get_wlb_report", Http_svr.BufIO Wlb_reports.report_handler)
-    ; ("get_wlb_diagnostics", Http_svr.BufIO Wlb_reports.diagnostics_handler)
-    ; ("get_audit_log", Http_svr.BufIO Audit_log.handler)
-    ; ("post_root", Http_svr.BufIO (Api_server.callback false))
-    ; ("post_json", Http_svr.BufIO (Api_server.callback true))
-    ; ("post_jsonrpc", Http_svr.BufIO Api_server.jsoncallback)
-    ; ("post_root_options", Http_svr.BufIO Api_server.options_callback)
-    ; ("post_json_options", Http_svr.BufIO Api_server.options_callback)
-    ; ("post_jsonrpc_options", Http_svr.BufIO Api_server.options_callback)
-    ; ( "get_pool_update_download"
-      , Http_svr.FdIO Xapi_pool_update.pool_update_download_handler
-      )
-    ; ("get_host_updates", Http_svr.FdIO Xapi_host.get_host_updates_handler)
-    ; ("put_bundle", Http_svr.FdIO Xapi_pool.put_bundle_handler)
+      ("get_services_xenops", Xapi_services.get_handler)
+    ; ("put_services_xenops", Xapi_services.put_handler)
+    ; ("post_services_xenops", Xapi_services.post_handler)
+    ; ("get_services_sm", Xapi_services.get_handler)
+    ; ("put_services_sm", Xapi_services.put_handler)
+    ; ("post_services_sm", Xapi_services.post_handler)
+    ; ("get_services", Xapi_services.get_handler)
+    ; ("post_services", Xapi_services.post_handler)
+    ; ("put_services", Xapi_services.put_handler)
+    ; ("put_import", Import.handler)
+    ; ("put_import_metadata", Import.metadata_handler)
+    ; ("put_import_raw_vdi", Import_raw_vdi.handler)
+    ; ("get_export", Export.handler)
+    ; ("get_export_metadata", Export.metadata_handler)
+    ; ("get_export_raw_vdi", Export_raw_vdi.handler)
+    ; ("connect_console", Console.handler Console.real_proxy)
+    ; ("connect_console_ws", Console.handler Console.ws_proxy)
+    ; ("post_cli", Xapi_cli.handler)
+    ; ("get_host_backup", Xapi_host_backup.host_backup_handler)
+    ; ("put_host_restore", Xapi_host_backup.host_restore_handler)
+    ; ("get_host_logs_download", Xapi_logs_download.logs_download_handler)
+    ; ("put_pool_patch_upload", Xapi_pool_patch.pool_patch_upload_handler)
+    ; ("get_vncsnapshot", Xapi_vncsnapshot.vncsnapshot_handler)
+    ; ("get_pool_xml_db_sync", Pool_db_backup.pull_database_backup_handler)
+    ; ("put_pool_xml_db_sync", Pool_db_backup.push_database_restore_handler)
+    ; ("get_config_sync", Config_file_sync.config_file_sync_handler)
+    ; ("get_system_status", System_status.handler)
+    ; (Constants.get_vm_rrd, Rrdd_proxy.get_vm_rrd_forwarder)
+    ; (Constants.get_host_rrd, Rrdd_proxy.get_host_rrd_forwarder)
+    ; (Constants.get_sr_rrd, Rrdd_proxy.get_sr_rrd_forwarder)
+    ; (Constants.get_rrd_updates, Rrdd_proxy.get_rrd_updates_forwarder)
+    ; (Constants.put_rrd, Rrdd_proxy.put_rrd_forwarder)
+    ; ("get_blob", Xapi_blob.handler)
+    ; ("put_blob", Xapi_blob.handler)
+    ; ("put_messages", Xapi_message.handler)
+    ; ("connect_remotecmd", Xapi_remotecmd.handler)
+    ; ("get_wlb_report", Wlb_reports.report_handler)
+    ; ("get_wlb_diagnostics", Wlb_reports.diagnostics_handler)
+    ; ("get_audit_log", Audit_log.handler)
+    ; ("post_root", Api_server.callback false)
+    ; ("post_json", Api_server.callback true)
+    ; ("post_jsonrpc", Api_server.jsoncallback)
+    ; ("post_root_options", Api_server.options_callback)
+    ; ("post_json_options", Api_server.options_callback)
+    ; ("post_jsonrpc_options", Api_server.options_callback)
+    ; ("get_pool_update_download", Xapi_pool_update.pool_update_download_handler)
+    ; ("get_host_updates", Xapi_host.get_host_updates_handler)
+    ; ("put_bundle", Xapi_pool.put_bundle_handler)
     ]
   in
   if !Xapi_globs.disable_webserver then
     handlers
   else
-    ("get_root", Http_svr.BufIO (Fileserver.send_file "/" !Xapi_globs.web_dir))
-    :: handlers
+    ("get_root", Fileserver.send_file "/" !Xapi_globs.web_dir) :: handlers
 
 let listen_unix_socket sock_path =
   (* Always listen on the Unix domain socket first *)