unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/README.md

@@ -0,0 +1,14 @@
+# RPC Client Example
+
+This project contains an executable `rpc_client` which connects to the RPC
+server started when Dune is run in watch mode. To use this program, start Dune
+in watch mode:
+
+```
+$ dune build --watch
+```
+
+Then run `rpc_client` from the same directory as `dune` was run from. The
+`rpc_client` program will connect to the server (`dune build --watch` starts an
+RPC server) and perform several RPC calls to it before instructing the server
+(over RPC) to shutdown.

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/dune

@@ -0,0 +1,5 @@
+(executable
+ (name rpc_client)
+ (package dune-rpc-lwt)
+ (public_name dune-rpc-lwt-example-client)
+ (libraries dune-rpc dune-rpc-lwt csexp lwt lwt.unix))

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/rpc_client.ml

@@ -0,0 +1,55 @@
+let () =
+  let init =
+    Dune_rpc.V1.Initialize.create
+      ~id:(Dune_rpc.V1.Id.make (Csexp.Atom "example_rpc_client"))
+  in
+  let where = Dune_rpc_lwt.V1.Where.default ~build_dir:"_build" () in
+  Lwt_main.run
+    (let open Lwt.Syntax in
+     let open Lwt.Infix in
+     let* chan = Dune_rpc_lwt.V1.connect_chan where in
+     Dune_rpc_lwt.V1.Client.connect chan init ~f:(fun client ->
+       print_endline "Sending ping to server...";
+       let* () =
+         let* request =
+           Dune_rpc_lwt.V1.Client.Versioned.prepare_request
+             client
+             Dune_rpc.V1.Request.ping
+           >|= Result.get_ok
+         in
+         Dune_rpc_lwt.V1.Client.request client request () >|= Result.get_ok
+       in
+       print_endline "Got response from server...";
+       print_endline "Creating progress stream...";
+       let* progress_stream =
+         Dune_rpc_lwt.V1.Client.poll client Dune_rpc.V1.Sub.progress >|= Result.get_ok
+       in
+       print_endline "Waiting for next progress event...";
+       let* progress_event = Dune_rpc_lwt.V1.Client.Stream.next progress_stream in
+       let message =
+         match progress_event with
+         | None -> "(none)"
+         | Some Success -> "Success"
+         | Some Failed -> "Failed"
+         | Some Interrupted -> "Interrupted"
+         | Some (In_progress { complete; remaining; failed }) ->
+           Printf.sprintf
+             "In_progress { complete = %d;  remaining = %d;  failed = %d }"
+             complete
+             remaining
+             failed
+         | Some Waiting -> "Waiting"
+       in
+       print_endline (Printf.sprintf "Got progress_event: %s" message);
+       print_endline "Shutting down RPC server...";
+       let* () =
+         let* shutdown_notification =
+           Dune_rpc_lwt.V1.Client.Versioned.prepare_notification
+             client
+             Dune_rpc.V1.Notification.shutdown
+           >|= Result.get_ok
+         in
+         Dune_rpc_lwt.V1.Client.notification client shutdown_notification ()
+       in
+       Lwt.return ()))
+;;

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/test/dune

@@ -0,0 +1,3 @@
+(cram
+ (applies_to :whole_subtree)
+ (deps %{bin:dune} ../rpc_client.exe))

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/test/rpc-client-example.t/dune

@@ -0,0 +1,2 @@
+(executable
+ (name hello))

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/test/rpc-client-example.t/dune-project

@@ -0,0 +1 @@
+(lang dune 3.8)

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/test/rpc-client-example.t/hello.ml

@@ -0,0 +1 @@
+print_endline "hello"

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/examples/rpc_client/test/rpc-client-example.t/run.t

@@ -0,0 +1,21 @@
+Start Dune in watch mode, sending errors to `/dev/null` to suppress the alerts
+about using the unstable module Dune_rpc.
+
+  $ export XDG_STATE_HOME="$PWD/.dune.state"
+  $ mkdir $XDG_STATE_HOME
+
+  $ dune build -w 2> /dev/null &
+
+Wait for the program produced by the above step to exist.
+  $ while ! test -f _build/default/hello.exe; do sleep 1; done
+
+Run the program. The program takes care of shutting down the build server.
+  $ ../../rpc_client.exe
+  Sending ping to server...
+  Got response from server...
+  Creating progress stream...
+  Waiting for next progress event...
+  Got progress_event: Success
+  Shutting down RPC server...
+
+  $ wait

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/src/dune

@@ -0,0 +1,4 @@
+(library
+ (name dune_rpc_lwt)
+ (public_name dune-rpc-lwt)
+ (libraries csexp dune_rpc lwt lwt.unix unix))

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml

@@ -0,0 +1,134 @@
+open Dune_rpc.V1
+open Lwt.Syntax
+
+module V1 = struct
+  module Fiber = struct
+    include Lwt
+
+    let fork_and_join_unit (x : unit -> unit Lwt.t) y =
+      let open Lwt in
+      Lwt.both (x ()) (y ()) >|= snd
+    ;;
+
+    let finalize f ~finally = Lwt.finalize f finally
+
+    let parallel_iter ls ~f =
+      let stream = Lwt_stream.from ls in
+      Lwt_stream.iter_p f stream
+    ;;
+
+    module Ivar = struct
+      type 'a t = 'a Lwt.t * 'a Lwt.u
+
+      let create () = Lwt.task ()
+
+      let fill (_, u) x =
+        Lwt.wakeup u x;
+        Lwt.return_unit
+      ;;
+
+      let read (x, _) = x
+    end
+
+    module O = Syntax
+  end
+
+  module Client =
+    Client.Make
+      (Fiber)
+      (struct
+        type t = Lwt_io.input_channel * Lwt_io.output_channel
+
+        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 =
+            if is_channel_closed ()
+            then (
+              Lexer.feed_eoi lexer;
+              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
+        ;;
+
+        let write (_, o) = function
+          | None -> Lwt_io.close o
+          | Some csexps ->
+            Lwt_list.iter_s (fun sexp -> Lwt_io.write o (Csexp.to_string sexp)) csexps
+        ;;
+      end)
+
+  module Where =
+    Where.Make
+      (Fiber)
+      (struct
+        let read_file s : (string, exn) result Lwt.t =
+          Lwt.catch
+            (fun () -> Lwt_result.ok (Lwt_io.with_file ~mode:Input s Lwt_io.read))
+            Lwt_result.fail
+        ;;
+
+        let analyze_path s =
+          Lwt.try_bind
+            (fun () -> Lwt_unix.stat s)
+            (fun stat ->
+               Lwt.return
+                 (match stat.st_kind with
+                  | Unix.S_SOCK -> Ok `Unix_socket
+                  | S_REG -> Ok `Normal_file
+                  | _ -> Ok `Other))
+            (fun e -> Lwt.return (Error e))
+        ;;
+      end)
+
+  let connect_chan where =
+    let+ fd =
+      let domain, sockaddr =
+        match where with
+        | `Unix socket -> Unix.PF_UNIX, Unix.ADDR_UNIX socket
+        | `Ip (`Host host, `Port port) ->
+          let addr = Unix.inet_addr_of_string host in
+          Unix.PF_INET, Unix.ADDR_INET (addr, port)
+      in
+      let fd = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in
+      let+ () = Lwt_unix.connect fd sockaddr in
+      fd
+    in
+    let fd mode = Lwt_io.of_fd fd ~mode in
+    fd Input, fd Output
+  ;;
+end

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.mli

@@ -0,0 +1,14 @@
+module V1 : sig
+  open Dune_rpc.V1
+
+  module Client :
+    Client.S
+    with type 'a fiber := 'a Lwt.t
+     and type chan := Lwt_io.input_channel * Lwt_io.output_channel
+
+  module Where : Where.S with type 'a fiber := 'a Lwt.t
+
+  val connect_chan
+    :  Dune_rpc.V1.Where.t
+    -> (Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
+end

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/test/dune

@@ -0,0 +1,25 @@
+(library
+ (name dune_rpc_lwt_tests)
+ (enabled_if
+  (>= %{ocaml_version} 4.13))
+ (inline_tests
+  (deps
+   (package dune)))
+ (libraries
+  dune_rpc
+  csexp_rpc
+  unix
+  dune_engine
+  csexp
+  stdune
+  lwt
+  lwt.unix
+  dune_rpc_lwt
+  ;; This is because of the (implicit_transitive_deps false)
+  ;; in dune-project
+  ppx_expect.config
+  ppx_expect.config_types
+  base
+  ppx_inline_test.config)
+ (preprocess
+  (pps ppx_expect)))

unikernel/duniverse/dune_/otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml

@@ -0,0 +1,152 @@
+(* end to end tests of dune_rpc. Verify that whatever is exposed to the client
+   is usable *)
+
+open Stdune
+open Lwt.Syntax
+open Dune_rpc.V1
+open Dune_rpc_lwt.V1
+
+let _XDG_STATE_HOME = "XDG_STATE_HOME"
+let xdg_state_dir = Temp.create Dir ~prefix:"lwt" ~suffix:"dune"
+let () = Unix.putenv _XDG_STATE_HOME (Stdune.Path.to_absolute_filename xdg_state_dir)
+
+let connect ~root_dir =
+  let build_dir = Filename.concat root_dir "_build" in
+  let env =
+    let env =
+      Env.add
+        Env.initial
+        ~var:_XDG_STATE_HOME
+        ~value:(Stdune.Path.to_absolute_filename xdg_state_dir)
+    in
+    Env.get env
+  in
+  let* res = Where.get ~env ~build_dir in
+  match res with
+  | Error e -> Lwt.fail e
+  | Ok None -> Lwt.fail_with (sprintf "unable to establish to connection in %s" build_dir)
+  | Ok (Some where) ->
+    let where =
+      match where with
+      | `Unix addr ->
+        (* this hackery is needed because the temp dir we wrote the socket to is
+           symlinked on a mac *)
+        let addr =
+          match Unix.realpath addr with
+          | s -> s
+          | exception Unix.Unix_error _ -> addr
+        in
+        `Unix
+          (match String.drop_prefix addr ~prefix:(Sys.getcwd () ^ "/") with
+           | None -> addr
+           | Some addr -> Filename.concat "." addr)
+      | _ as s -> s
+    in
+    connect_chan where
+;;
+
+let build_watch ~root_dir =
+  Lwt_process.open_process_none
+    ~stdin:`Close
+    ~stderr:`Dev_null
+    ( "dune"
+    , [| "dune"
+       ; "build"
+       ; "--no-print-directory"
+       ; "--root"
+       ; root_dir
+       ; "-w"
+       ; "--file-watcher"
+       ; "manual"
+       ; "@install"
+      |] )
+;;
+
+let run_with_timeout f =
+  Lwt.catch
+    (fun () ->
+       let+ () =
+         Lwt_unix.with_timeout 3.0 (fun () ->
+           let+ _ = f () in
+           ())
+       in
+       print_endline "success")
+    (fun exn ->
+       (match exn with
+        | Lwt_unix.Timeout -> print_endline "timeout"
+        | _ -> ());
+       Lwt.return_unit)
+;;
+
+let initial_cwd = Sys.getcwd ()
+
+let%expect_test "run and connect" =
+  let initialize = Initialize.create ~id:(Id.make (Csexp.Atom "test")) in
+  Sys.chdir initial_cwd;
+  Lwt_main.run
+    (let* root_dir = Lwt_io.create_temp_dir () in
+     Sys.chdir root_dir;
+     let build = build_watch ~root_dir in
+     let rpc =
+       let* () = Lwt_unix.sleep 0.5 in
+       connect ~root_dir
+     in
+     let run_client =
+       let* rpc = rpc in
+       Client.connect rpc initialize ~f:(fun t ->
+         print_endline "started session";
+         let* ping = Client.Versioned.prepare_request t Request.ping in
+         let ping =
+           match ping with
+           | Ok p -> p
+           | Error _ -> assert false
+         in
+         let* res = Client.request t ping () in
+         match res with
+         | Error _ -> failwith "unexpected"
+         | Ok () ->
+           print_endline "received ping. shutting down.";
+           let* shutdown =
+             Client.Versioned.prepare_notification t Notification.shutdown
+           in
+           let shutdown =
+             match shutdown with
+             | Ok s -> s
+             | Error _ -> assert false
+           in
+           Client.notification t shutdown ())
+     in
+     let run_build =
+       let+ res = build#status in
+       match res with
+       | WEXITED i -> printfn "dune build finished with %i" i
+       | _ -> assert false
+     in
+     Lwt.finalize
+       (fun () -> run_with_timeout (fun () -> Lwt.all [ run_client; run_build ]))
+       (fun () ->
+          build#terminate;
+          Lwt.return_unit));
+  [%expect
+    {|
+    started session
+    received ping. shutting down.
+    dune build finished with 0
+    success |}]
+;;
+
+module Logger = struct
+  (* A little helper to make the output from the client and server
+     deterministic. Log messages are batched and outputted at the end. *)
+  type t =
+    { mutable messages : string list
+    ; name : string
+    }
+
+  let create ~name = { messages = []; name }
+  let log t fmt = Printf.ksprintf (fun m -> t.messages <- m :: t.messages) fmt
+
+  let print { messages; name } =
+    List.rev messages |> List.iter ~f:(fun msg -> printfn "%s: %s" name msg)
+  ;;
+end