Reproducer for exception Unix.Unix_error(Unix.EBADF, "check_descriptor", "")

config.ml

open Mirage

let stack = generic_stackv4 default_network

let cond = conduit_direct stack

let http_srv = http_server @@ cond

let res_dns = resolver_dns stack

let http_port =
  let doc = Key.Arg.info ~doc:"Listening HTTP port." ["http"] in
  Key.(create "http_port" Arg.(opt int 8080 doc))

let main =
  let packages = [
    package "uri";
  ] in
  let keys = List.map Key.abstract [ http_port; ] in
  foreign
    ~packages ~keys
    "Dispatch.HTTP" (pclock @-> http @-> resolver @-> conduit @-> job)

let () =
  register "http" [main $ default_posix_clock $ http_srv $ res_dns $ cond]

dispatch.ml

let http_src = Logs.Src.create "http" ~doc:"HTTP server"
module Http_log = (val Logs.src_log http_src : Logs.LOG)

module C = Cohttp_mirage.Client

module HTTP
    (Pclock: Mirage_types.PCLOCK)
    (S: Cohttp_lwt.S.Server)
    (RES: Resolver_lwt.S)
    (CON: Conduit_mirage.S)
=
struct

  let serve ctx =
    let callback (_, cid) request _body =
      let uri = Cohttp.Request.uri request in
      let cid = Cohttp.Connection.to_string cid in
      Http_log.info (fun f -> f "[%s] serving %s." cid (Uri.to_string uri));
      Lwt.catch
      (fun () ->
          C.call ~ctx `GET @@ Uri.of_string "http://pastebin.com/raw/r381BpBu"
      )
      (fun e ->
        Http_log.info (fun f -> f "Uncaught exception: %s\n%s\n" (Printexc.to_string e) (Printexc.get_backtrace ()));
        S.respond_not_found ()
      )
    in
    let conn_closed (_,cid) =
      let cid = Cohttp.Connection.to_string cid in
      Http_log.info (fun f -> f "[%s] closing" cid);
    in
    S.make ~conn_closed ~callback ()

  let start _clock http res_dns con =
    let ctx = Cohttp_mirage.Client.ctx res_dns con in
    let http_port = Key_gen.http_port () in
    let tcp = `TCP http_port in
    let http =
      Http_log.info (fun f -> f "listening on %d/TCP" http_port);
      http tcp @@ serve ctx
    in
    http
end

let () = Printexc.record_backtrace true

stress-test.sh

printf 'url="http://localhost:8080"\n%.0s' {1..1000} | curl -v -K -