Don't attempt read from closed fd in dune_rpc_lwt

This fixes a bug where RPC clients built with dune_rpc_lwt would crash
while disconnecting as they attempted to read from a channel whose
underlying file descriptor had been closed.

Also updates the dune-rpc-lwt expect test to expect the text "success"
to be printed by the client after its connection is closed. It wasn't
being printed prior to this change.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

CHANGES.md

@@ -115,6 +115,9 @@ Unreleased
   would not be included whenever `(generate_opam_files true)` was set and the
   `.install` file wasn't yet generated. (#7547, @rgrinberg)
 
+- Fix bug where RPC clients built with dune-rpc-lwt would crash when closing
+  their connection to the server (#7581, @gridbugs)
+
 3.7.1 (2023-04-04)
 ------------------
 

otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml

@@ -42,33 +42,45 @@ module V1 = struct
       (struct
         type t = Lwt_io.input_channel * Lwt_io.output_channel
 
-        let read (i, _) =
+        let read (i, o) =
+          (* The input and output channels share the same file descriptor. If
+             the output channel has been closed, reading from the input channel
+             will result in an error. *)
+          let is_channel_closed () = Lwt_io.is_closed o in
           let open Csexp.Parser in
           let lexer = Lexer.create () in
           let rec loop depth stack =
-            let* res = Lwt_io.read_char_opt i in
-            match res with
-            | None ->
+            if is_channel_closed () then (
               Lexer.feed_eoi lexer;
-              Lwt.return_none
-            | Some c -> (
-              match Lexer.feed lexer c with
-              | Await -> loop depth stack
-              | Lparen -> loop (depth + 1) (Stack.open_paren stack)
-              | Rparen ->
-                let stack = Stack.close_paren stack in
-                let depth = depth - 1 in
-                if depth = 0 then
-                  let sexps = Stack.to_list stack in
-                  sexps |> List.hd |> Lwt.return_some
-                else loop depth stack
-              | Atom count ->
-                let* atom =
-                  let bytes = Bytes.create count in
-                  let+ () = Lwt_io.read_into_exactly i bytes 0 count in
-                  Bytes.to_string bytes
-                in
-                loop depth (Stack.add_atom atom stack))
+              Lwt.return_none)
+            else
+              let* res = Lwt_io.read_char_opt i in
+              match res with
+              | None ->
+                Lexer.feed_eoi lexer;
+                Lwt.return_none
+              | Some c -> (
+                match Lexer.feed lexer c with
+                | Await -> loop depth stack
+                | Lparen -> loop (depth + 1) (Stack.open_paren stack)
+                | Rparen ->
+                  let stack = Stack.close_paren stack in
+                  let depth = depth - 1 in
+                  if depth = 0 then
+                    let sexps = Stack.to_list stack in
+                    sexps |> List.hd |> Lwt.return_some
+                  else loop depth stack
+                | Atom count ->
+                  if is_channel_closed () then (
+                    Lexer.feed_eoi lexer;
+                    Lwt.return_none)
+                  else
+                    let* atom =
+                      let bytes = Bytes.create count in
+                      let+ () = Lwt_io.read_into_exactly i bytes 0 count in
+                      Bytes.to_string bytes
+                    in
+                    loop depth (Stack.add_atom atom stack))
           in
           loop 0 Stack.Empty
 

otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml

@@ -118,7 +118,8 @@ let%expect_test "run and connect" =
     {|
     started session
     received ping. shutting down.
-    dune build finished with 0 |}]
+    dune build finished with 0
+    success |}]
 
 module Logger = struct
   (* A little helper to make the output from the client and server