Server-client hello world application

24 files changed, 322 insertions, 0 deletions

diff --git a/.ocamlformat b/.ocamlformat
new file mode 100644
index 0000000..aa5495a
--- /dev/null
+++ b/.ocamlformat
@@ -0,0 +1,2 @@
+profile = janestreet
+version = 0.26.1
\ No newline at end of file
diff --git a/client/bin/client.ml b/client/bin/client.ml
new file mode 100644
index 0000000..fbff801
--- /dev/null
+++ b/client/bin/client.ml
@@ -0,0 +1,3 @@
+open! Core
+
+let () = Command_unix.run Hello_world_client.Main.command
diff --git a/client/bin/dune b/client/bin/dune
new file mode 100644
index 0000000..242182f
--- /dev/null
+++ b/client/bin/dune
@@ -0,0 +1,6 @@
+(executable
+ (public_name hello_world_client)
+ (name client)
+ (libraries core core_unix.command_unix hello_world_client)
+ (preprocess
+  (pps ppx_jane)))
diff --git a/client/src/client.ml b/client/src/client.ml
new file mode 100644
index 0000000..ebed09b
--- /dev/null
+++ b/client/src/client.ml
@@ -0,0 +1,11 @@
+open! Core
+open Async
+open Hello_world_protocol
+
+let hello_world_rpc ~where_to_connect ~query =
+  Rpc.Connection.with_client where_to_connect (fun conn ->
+    let%bind.Deferred.Or_error conn = Versioned_rpc.Connection_with_menu.create conn in
+    Hello_world.dispatch conn query)
+  >>| Result.map_error ~f:Error.of_exn
+  >>| Or_error.join
+;;
diff --git a/client/src/client.mli b/client/src/client.mli
new file mode 100644
index 0000000..b4376bf
--- /dev/null
+++ b/client/src/client.mli
@@ -0,0 +1,8 @@
+open! Core
+open Async
+open Hello_world_protocol
+
+val hello_world_rpc
+  :  where_to_connect:[< Socket.Address.t ] Tcp.Where_to_connect.t
+  -> query:Hello_world.Query.t
+  -> Hello_world.Response.t Deferred.Or_error.t
diff --git a/client/src/dune b/client/src/dune
new file mode 100644
index 0000000..cba2c3c
--- /dev/null
+++ b/client/src/dune
@@ -0,0 +1,6 @@
+(library
+ (inline_tests)
+ (name hello_world_client)
+ (libraries core async hello_world_protocol)
+ (preprocess
+  (pps ppx_inline_test ppx_jane)))
diff --git a/client/src/hello_world_client.ml b/client/src/hello_world_client.ml
new file mode 100644
index 0000000..a5a59ad
--- /dev/null
+++ b/client/src/hello_world_client.ml
@@ -0,0 +1 @@
+module Main = Main
diff --git a/client/src/main.ml b/client/src/main.ml
new file mode 100644
index 0000000..96bd4e0
--- /dev/null
+++ b/client/src/main.ml
@@ -0,0 +1,31 @@
+open! Core
+open Async
+
+let hello_world_rpc_command =
+  Command.async_or_error
+    ~summary:"Hello world RPC"
+    (let%map_open.Command hello = anon ("HELLO" %: string)
+     and world = anon ("WORLD" %: string)
+     and host =
+       flag
+         "host"
+         (optional_with_default "127.0.0.1" string)
+         ~doc:"STRING Host to connect to"
+     and port =
+       flag "port" (optional_with_default 8080 int) ~doc:"INT Port to connect to"
+     in
+     fun () ->
+       let where_to_connect =
+         Tcp.Where_to_connect.of_host_and_port (Host_and_port.create ~host ~port)
+       in
+       let%map.Deferred.Or_error response =
+         Client.hello_world_rpc ~where_to_connect ~query:{ hello; world }
+       in
+       match response with
+       | Error error -> print_endline [%string "Error: %{Error.to_string_hum error}."]
+       | Ok response -> print_endline response)
+;;
+
+let command =
+  Command.group ~summary:"Hello world rpcs" [ "hello-world", hello_world_rpc_command ]
+;;
diff --git a/client/src/main.mli b/client/src/main.mli
new file mode 100644
index 0000000..780124b
--- /dev/null
+++ b/client/src/main.mli
@@ -0,0 +1,3 @@
+open! Core
+
+val command : Command.t
diff --git a/dune-project b/dune-project
new file mode 100644
index 0000000..ffcc448
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,20 @@
+(lang dune 3.10)
+
+(name hello_world_rpc)
+
+(generate_opam_files false)
+
+(authors "Franciszek Malinka")
+
+(license MIT)
+
+(package
+ (name hello_world_rpc)
+ (synopsis "Example Async RPC server-client application")
+ (description
+  "This is a simple Async RPC application developed after my internship at Jane Street. I'll probably use it in the future as a handy example to refer from. Also, I haven't seen much Async RPCs examples on the web.")
+ (depends ocaml dune)
+ (tags
+  (async rpc)))
+
+; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project
diff --git a/protocol/dune b/protocol/dune
new file mode 100644
index 0000000..e0ad4bc
--- /dev/null
+++ b/protocol/dune
@@ -0,0 +1,6 @@
+(library
+ (inline_tests)
+ (name hello_world_protocol)
+ (libraries core babel async)
+ (preprocess
+  (pps ppx_inline_test ppx_jane)))
diff --git a/protocol/hello_world.ml b/protocol/hello_world.ml
new file mode 100644
index 0000000..c373ef1
--- /dev/null
+++ b/protocol/hello_world.ml
@@ -0,0 +1,64 @@
+module Stable = struct
+  open Core.Core_stable
+
+  module Query = struct
+    module V1 = struct
+      type t =
+        { hello : String.V1.t
+        ; world : String.V1.t
+        }
+      [@@deriving sexp, compare, bin_io]
+    end
+  end
+
+  module Response = struct
+    module V1 = struct
+      type t = String.V1.t Or_error.V2.t [@@deriving sexp, compare, bin_io]
+    end
+  end
+end
+
+open! Core
+open Async
+
+let rpc version bin_query bin_response =
+  Rpc.Rpc.create ~name:"hello-world-rpc" ~version ~bin_query ~bin_response
+;;
+
+let v1 = rpc 1 Stable.Query.V1.bin_t Stable.Response.V1.bin_t
+let caller = Babel.Caller.Rpc.singleton v1
+
+let%expect_test _ =
+  Babel.Caller.print_shapes caller;
+  [%expect
+    {|
+    ((((name hello-world-rpc) (version 1))
+      (Rpc (query 13d043897ea4e5bd11e00a5e10ac5a96)
+       (response a77b3b6e3753246ce7ec1f3467c939eb)))) |}];
+  return ()
+;;
+
+let callee = Babel.Callee.Rpc.singleton v1
+
+let%expect_test _ =
+  Babel.Callee.print_shapes callee;
+  let () =
+    [%expect
+      {|
+    (Ok
+     ((hello-world-rpc
+       ((1
+         (Rpc (query 13d043897ea4e5bd11e00a5e10ac5a96)
+          (response a77b3b6e3753246ce7ec1f3467c939eb))))))) |}]
+  in
+  let description = Babel.check_compatibility_exn ~caller ~callee in
+  print_s [%sexp (description : Rpc.Description.t)];
+  [%expect {| ((name hello-world-rpc) (version 1)) |}];
+  return ()
+;;
+
+let dispatch = Babel.Caller.Rpc.dispatch_multi caller
+let implement f = Babel.Callee.implement_multi_exn callee ~f
+
+module Query = Stable.Query.V1
+module Response = Stable.Response.V1
diff --git a/protocol/hello_world.mli b/protocol/hello_world.mli
new file mode 100644
index 0000000..a81e2da
--- /dev/null
+++ b/protocol/hello_world.mli
@@ -0,0 +1,33 @@
+open! Core
+open Async
+
+module Query : sig
+  type t =
+    { hello : string
+    ; world : string
+    }
+  [@@deriving sexp_of]
+end
+
+module Response : sig
+  type t = string Or_error.t [@@deriving sexp_of]
+end
+
+module Stable : sig
+  module Query : sig
+    module V1 : Stable_without_comparator with type t = Query.t
+  end
+
+  module Response : sig
+    module V1 : Stable_without_comparator with type t = Response.t
+  end
+end
+
+val dispatch
+  :  Versioned_rpc.Connection_with_menu.t
+  -> Query.t
+  -> Response.t Or_error.t Deferred.t
+
+val implement
+  :  ('a -> Rpc.Description.t -> Query.t -> Response.t Deferred.t)
+  -> 'a Rpc.Implementation.t list
diff --git a/protocol/hello_world_protocol.ml b/protocol/hello_world_protocol.ml
new file mode 100644
index 0000000..cc8b622
--- /dev/null
+++ b/protocol/hello_world_protocol.ml
@@ -0,0 +1 @@
+module Hello_world = Hello_world
diff --git a/server/bin/dune b/server/bin/dune
new file mode 100644
index 0000000..2416ff3
--- /dev/null
+++ b/server/bin/dune
@@ -0,0 +1,6 @@
+(executable
+ (public_name hello_world_server)
+ (name server)
+ (libraries core core_unix.command_unix hello_world_server)
+ (preprocess
+  (pps ppx_jane)))
diff --git a/server/bin/server.ml b/server/bin/server.ml
new file mode 100644
index 0000000..42f5aa0
--- /dev/null
+++ b/server/bin/server.ml
@@ -0,0 +1,3 @@
+open! Core
+
+let () = Command_unix.run Hello_world_server.Main.command
diff --git a/server/src/config.ml b/server/src/config.ml
new file mode 100644
index 0000000..fab88f7
--- /dev/null
+++ b/server/src/config.ml
@@ -0,0 +1,10 @@
+open! Core
+open Async
+
+type t =
+  { uppercase : bool
+  ; port : int
+  }
+[@@deriving sexp]
+
+let load filename = Reader.load_sexp filename t_of_sexp
diff --git a/server/src/config.mli b/server/src/config.mli
new file mode 100644
index 0000000..fb27f6e
--- /dev/null
+++ b/server/src/config.mli
@@ -0,0 +1,10 @@
+open! Core
+open Async
+
+type t =
+  { uppercase : bool
+  ; port : int
+  }
+[@@deriving sexp]
+
+val load : Filename.t -> t Deferred.Or_error.t
diff --git a/server/src/dune b/server/src/dune
new file mode 100644
index 0000000..952b1d2
--- /dev/null
+++ b/server/src/dune
@@ -0,0 +1,11 @@
+(library
+ (inline_tests)
+ (name hello_world_server)
+ (libraries
+  core
+  core_unix.command_unix
+  async.log_extended
+  async
+  hello_world_protocol)
+ (preprocess
+  (pps ppx_inline_test ppx_jane)))
diff --git a/server/src/hello_world_server.ml b/server/src/hello_world_server.ml
new file mode 100644
index 0000000..a5a59ad
--- /dev/null
+++ b/server/src/hello_world_server.ml
@@ -0,0 +1 @@
+module Main = Main
diff --git a/server/src/main.ml b/server/src/main.ml
new file mode 100644
index 0000000..3c2f7aa
--- /dev/null
+++ b/server/src/main.ml
@@ -0,0 +1,20 @@
+open! Core
+open Async
+
+let command =
+  Command.async_or_error
+    ~summary:"Run Hello World RPC server"
+    (let%map_open.Command () =
+       Log_extended.Command.setup_via_params
+         ~log_to_console_by_default:(Stderr Color)
+         ~log_to_syslog_by_default:false
+         ()
+     and uppercase = flag "uppercase" no_arg ~doc:"Uppercase the message"
+     and port = flag "port" (optional int) ~doc:"INT port to listen on" in
+     Log.Global.set_output (Log_extended.Global.get_output ());
+     fun () ->
+       let port = Option.value ~default:8080 port in
+       let config = { Config.uppercase; port } in
+       let%bind.Deferred.Or_error server = Server.init config in
+       Server.run server |> Deferred.ok)
+;;
diff --git a/server/src/main.mli b/server/src/main.mli
new file mode 100644
index 0000000..780124b
--- /dev/null
+++ b/server/src/main.mli
@@ -0,0 +1,3 @@
+open! Core
+
+val command : Command.t
diff --git a/server/src/server.ml b/server/src/server.ml
new file mode 100644
index 0000000..f6a1954
--- /dev/null
+++ b/server/src/server.ml
@@ -0,0 +1,56 @@
+open! Core
+open Async
+open Hello_world_protocol
+
+type t = { config : Config.t } [@@deriving sexp_of]
+type rpc_state = Socket.Address.Inet.t * Rpc.Connection.t [@@deriving sexp_of]
+
+let init config = Deferred.Or_error.return { config }
+let construct_hello_world ~hello ~world = [%string "%{hello}, %{world}!"]
+
+let log_rpc rpc_state rpc_description =
+  Log.Global.debug_s
+    [%message "New Rpc" (rpc_state : rpc_state) (rpc_description : Rpc.Description.t)]
+;;
+
+let hello_world_implementation
+  { config }
+  rpc_state
+  rpc_description
+  (query : Hello_world.Query.t)
+  =
+  log_rpc rpc_state rpc_description;
+  let response = construct_hello_world ~hello:query.hello ~world:query.world in
+  (if config.uppercase then String.uppercase response else response)
+  |> Deferred.Or_error.return
+;;
+
+let unkown_rpc rpc_state ~rpc_tag ~version =
+  ignore rpc_state;
+  Log.Global.error_s [%message "Unkown rpc" rpc_tag (version : int)];
+  `Close_connection
+;;
+
+let implementations t =
+  let implementations =
+    List.concat
+      [ Hello_world_protocol.Hello_world.implement (hello_world_implementation t) ]
+  in
+  let implementations = Versioned_rpc.Menu.add implementations in
+  Rpc.Implementations.create_exn ~implementations ~on_unknown_rpc:(`Call unkown_rpc)
+;;
+
+let run { config } =
+  let where_to_listen = Tcp.Where_to_listen.of_port config.port in
+  Log.Global.info_s
+    [%message "Spinning up server" (where_to_listen : Tcp.Where_to_listen.inet)];
+  let%bind server =
+    Rpc.Connection.serve
+      ~implementations:(implementations { config })
+      ~initial_connection_state:(fun address connection -> address, connection)
+      ~where_to_listen
+      ()
+  in
+  ignore server;
+  Deferred.never ()
+;;
diff --git a/server/src/server.mli b/server/src/server.mli
new file mode 100644
index 0000000..3bfbffa
--- /dev/null
+++ b/server/src/server.mli
@@ -0,0 +1,7 @@
+open! Core
+open Async
+
+type t [@@deriving sexp_of]
+
+val init : Config.t -> t Deferred.Or_error.t
+val run : t -> unit Deferred.t