Fix launch request dropped when pipelined after initialize

CHANGELOG.md

@@ -5,6 +5,11 @@
 * Fix the empty "Globals" scope on OCaml >= 5.2 (#74). Globals are numbered by
   `Symtable.Global.t` rather than by `Ident.t` since 5.2, and reading the SYMB
   section with the old key type left the scope empty.
+* Fix a `launch` request being dropped when sent immediately after
+  `initialize`. The Launch handler was registered one scheduler tick after the
+  initialize response was sent, so a pipelined `launch` could arrive first, be
+  silently dropped ("Can not find handler"), and leave the session stuck with no
+  `initialized` event.
 
 ### Added
 

src/adapter/state_uninitialized.ml

@@ -18,6 +18,11 @@ let run rpc =
             ~supports_breakpoint_locations_request:(Some true)
             ~supports_value_formatting_options:(Some true) ())
       in
-      Lwt.wakeup_later resolver (arg, caps);
+      (* Wake immediately so that the next state registers
+         its Launch/Attach handlers synchronously, before this handler returns
+         and the initialize response is sent. Otherwise a client that pipelines
+         "launch" right after "initialize" can have it arrive before the handler
+         exists, and it is silently dropped. *)
+      Lwt.wakeup resolver (arg, caps);
       Lwt.return caps);
   promise

test/dune

@@ -17,6 +17,29 @@
   (pps lwt_ppx))
  (libraries dap.types dap_client lwt lwt.unix))
 
+; A raw-framing client (does not use dap_client, so it can pipeline requests).
+(executable
+ (name test_launch_race)
+ (modules test_launch_race)
+ (preprocess
+  (pps lwt_ppx))
+ (libraries lwt lwt.unix))
+
+(rule
+ (targets test_launch_race.actual)
+ (deps
+  (:driver test_launch_race.exe)
+  (:adapter %{exe:../src/main/main.exe})
+  fixtures/hello.bc)
+ (action
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_launch_race.expected test_launch_race.actual)))
+
 (rule
  (targets test_scopes.actual)
  (deps

test/test_launch_race.expected

@@ -0,0 +1 @@
+received the initialized event

test/test_launch_race.ml

@@ -0,0 +1,74 @@
+(* Regression test for the initialize/launch handler race. A client that
+   pipelines "launch" right after "initialize", sending both before reading the
+   initialize response, must still have its launch handled and receive the
+   "initialized" event. Before the fix the launch could arrive before the
+   adapter had registered the Launch handler and was silently dropped, so no
+   "initialized" event ever came (see the intermittent CI timeout).
+
+   This talks to the adapter with raw framing rather than the Debug_rpc client,
+   so we can pipeline the two requests. *)
+
+let adapter =
+  match Sys.getenv_opt "EARLYBIRD_ADAPTER" with
+  | Some adapter -> adapter
+  | None -> failwith "EARLYBIRD_ADAPTER is not set"
+
+let program = Filename.concat (Sys.getcwd ()) "fixtures/hello.bc"
+
+let frame seq command arguments =
+  let body =
+    Printf.sprintf {|{"seq":%d,"type":"request","command":"%s","arguments":%s}|}
+      seq command arguments
+  in
+  Printf.sprintf "Content-Length: %d\r\n\r\n%s" (String.length body) body
+
+(* Whether [sub] occurs in [s]. *)
+let contains_substring s sub =
+  let n = String.length s and m = String.length sub in
+  let rec at i = i + m <= n && (String.sub s i m = sub || at (i + 1)) in
+  m = 0 || at 0
+
+(* Read one DAP message and return its raw JSON body. *)
+let read_message ic =
+  let rec headers content_length =
+    let%lwt line = Lwt_io.read_line ic in
+    match String.trim line with
+    | "" -> Lwt.return content_length
+    | line -> (
+        match String.split_on_char ':' line with
+        | [ key; value ] when String.trim key = "Content-Length" ->
+            headers (int_of_string (String.trim value))
+        | _ -> headers content_length)
+  in
+  let%lwt length = headers 0 in
+  let buf = Bytes.create length in
+  Lwt_io.read_into_exactly ic buf 0 length;%lwt
+  Lwt.return (Bytes.to_string buf)
+
+let main () =
+  let proc = Lwt_process.open_process (adapter, [| adapter; "debug" |]) in
+  let init = frame 1 "initialize" {|{"adapterID":"ocaml"}|} in
+  let launch =
+    frame 2 "launch"
+      (Printf.sprintf
+         {|{"name":"race","program":%S,"stopOnEntry":false,"console":"internalConsole"}|}
+         program)
+  in
+  Lwt_io.write proc#stdin (init ^ launch);%lwt
+  Lwt_io.flush proc#stdin;%lwt
+  let rec wait_initialized () =
+    let%lwt message = read_message proc#stdout in
+    if contains_substring message {|"initialized"|} then
+      Lwt.return "received the initialized event"
+    else wait_initialized ()
+  in
+  let timeout =
+    Lwt_unix.sleep 30.0;%lwt
+    Lwt.return "timed out waiting for the initialized event"
+  in
+  let%lwt result = Lwt.pick [ wait_initialized (); timeout ] in
+  print_endline result;
+  proc#terminate;
+  Lwt.return ()
+
+let () = Lwt_main.run (main ())