ocaml: handle unexpected error cases from the notifications pipe

The `Lwt_unix.read` is supposed to return 0 for EOF and >0 for number
of bytes read. Error results from the syscall are supposed to be handled
by the library. However there is evidence that an error `-1` is leaking
through, so add some logging and exit the process instead of spinning.

Signed-off-by: David Scott <dave@recoil.org>

Author: djs55

Makefile

@@ -107,7 +107,8 @@ OCAML_C_SRC := \
 OCAML_WHERE := $(shell ocamlc -where)
 OCAML_PACKS := cstruct cstruct-lwt io-page io-page.unix uri mirage-block \
 	mirage-block-unix qcow unix threads lwt lwt.unix logs logs.fmt   \
-	mirage-unix prometheus-app conduit-lwt cohttp-lwt-unix
+	mirage-unix prometheus-app conduit-lwt cohttp-lwt-unix \
+	unix-type-representations
 OCAML_LDLIBS := -L $(OCAML_WHERE) \
 	$(shell ocamlfind query cstruct)/cstruct.a \
 	$(shell ocamlfind query cstruct)/libcstruct_stubs.a \
@@ -120,6 +121,7 @@ OCAML_LDLIBS := -L $(OCAML_WHERE) \
 	$(shell ocamlfind query threads)/libthreadsnat.a \
 	$(shell ocamlfind query mirage-block-unix)/libmirage_block_unix_stubs.a \
 	$(shell ocamlfind query base)/libbase_stubs.a \
+	$(shell ocamlfind query unix-type-representations)/libunix_type_representations_stubs.a \
         $(LIBEV) \
 	-lasmrun -lunix
 

src/lib/mirage_block_ocaml.ml

@@ -416,6 +416,7 @@ let process_one t =
    requests and forks background threads to process all the requests. *)
 let serve_forever () =
   let buf = Bytes.make 1 '\000' in
+  Printf.fprintf stderr "Using fd %d for I/O notifications\n%!" (Unix_representations.int_of_file_descr Protocol.request_reader);
   (* According to https://ocsigen.org/lwt/3.2.1/api/Lwt_unix non-blocking mode
      is fastest, and used by default with Unix pipes. *)
   let blocking = false in
@@ -429,6 +430,12 @@ let serve_forever () =
       Printf.fprintf stderr "Got EOF while reading signal from the pipe\n%!";
       exit 1
     end;
+    if n < 0 then begin
+      (* This should never happen and might indicate a bug elsewhere handling
+         the blocking mode of the fd. *)
+      Printf.fprintf stderr "Got %d while reading signal from the pipe\n%!" n;
+      exit 2
+    end;
     let all = Protocol.take_all () in
     let (_: unit Lwt.t list) = List.map process_one all in
     loop () in