unikernel/duniverse/ocaml-h2/examples/lwt/lwt_echo_server2.ml

@@ -0,0 +1,155 @@
+let set_interval s f destroy =
+  let rec set_interval_loop s f n =
+    let timeout =
+      Lwt_timeout.create s (fun () ->
+        if n > 0
+        then (if f () then set_interval_loop s f (n - 1))
+        else destroy ())
+    in
+    Lwt_timeout.start timeout
+  in
+  set_interval_loop s f 2
+
+let connection_handler : Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t =
+  let open H2 in
+  let request_handler : Unix.sockaddr -> Reqd.t -> unit =
+   fun _client_address request_descriptor ->
+    let request = Reqd.request request_descriptor in
+    match request.meth, request.target with
+    | `GET, "/" | `POST, "/" ->
+      let request_body = Reqd.request_body request_descriptor in
+      let response_content_type =
+        match Headers.get request.headers "content-type" with
+        | Some request_content_type -> request_content_type
+        | None -> "application/octet-stream"
+      in
+      let rec respond () =
+        Body.Reader.schedule_read
+          request_body
+          ~on_eof:(fun () ->
+            let response =
+              Response.create
+                ~headers:
+                  (Headers.of_list [ "content-type", response_content_type ])
+                `OK
+            in
+            Reqd.respond_with_string
+              request_descriptor
+              response
+              "non-empty data.")
+          ~on_read:(fun _request_data ~off:_ ~len:_ -> respond ())
+      in
+      respond ()
+    | `POST, "/other" ->
+      let request_body = Reqd.request_body request_descriptor in
+      let response_content_type =
+        match Headers.get request.headers "content-type" with
+        | Some request_content_type -> request_content_type
+        | None -> "application/octet-stream"
+      in
+      let response =
+        Response.create
+          ~headers:(Headers.of_list [ "content-type", response_content_type ])
+          `OK
+      in
+      let response_body =
+        Reqd.respond_with_streaming request_descriptor response
+      in
+      let rec respond () =
+        Body.Reader.schedule_read
+          request_body
+          ~on_eof:(fun () ->
+            set_interval
+              1
+              (fun () ->
+                 Body.Writer.write_string response_body "FOO";
+                 (* Body.flush response_body ignore; *)
+                 true)
+              (* Body.flush response_body ignore; *)
+                 (fun () -> Body.Writer.close response_body))
+          ~on_read:(fun request_data ~off ~len ->
+            Body.Writer.write_bigstring response_body request_data ~off ~len;
+            respond ())
+      in
+      respond ()
+    | `POST, "/foo" ->
+      let response =
+        Response.create
+          `OK
+          ~headers:(Headers.of_list [ "content-type", "text/event-stream" ])
+      in
+      let request_body = Reqd.request_body request_descriptor in
+      let response_body =
+        Reqd.respond_with_streaming request_descriptor response
+      in
+      (* let (finished, notify) = Lwt.wait () in *)
+      let rec on_read _request_data ~off:_ ~len:_ =
+        Body.Writer.flush response_body (fun _ ->
+          Body.Reader.schedule_read request_body ~on_eof ~on_read)
+      and on_eof () =
+        set_interval
+          2
+          (fun () ->
+             let _ =
+               Body.Writer.write_string response_body "data: some data\n\n"
+             in
+             Body.Writer.flush response_body ignore;
+             true)
+          (fun () ->
+             let _ =
+               Body.Writer.write_string response_body "event: end\ndata: 1\n\n"
+             in
+             Body.Writer.flush response_body (fun _ ->
+               Body.Writer.close response_body))
+      in
+      Body.Reader.schedule_read ~on_read ~on_eof request_body;
+      ()
+    | _ ->
+      Reqd.respond_with_string
+        request_descriptor
+        (Response.create `Method_not_allowed)
+        "Hello, Sean."
+  in
+  let error_handler :
+       Unix.sockaddr
+      -> ?request:H2.Request.t
+      -> _
+      -> (Headers.t -> Body.Writer.t)
+      -> unit
+    =
+   fun _client_address ?request:_ error start_response ->
+    let response_body = start_response Headers.empty in
+    (match error with
+    | `Exn exn ->
+      Body.Writer.write_string response_body (Printexc.to_string exn);
+      Body.Writer.write_string response_body "\n"
+    | #Status.standard as error ->
+      Body.Writer.write_string
+        response_body
+        (Status.default_reason_phrase error));
+    Body.Writer.close response_body
+  in
+  H2_lwt_unix.Server.create_connection_handler
+    ?config:None
+    ~request_handler
+    ~error_handler
+
+let () =
+  let open Lwt.Infix in
+  Sys.(set_signal sigpipe Signal_ignore);
+  let port = ref 8080 in
+  Arg.parse
+    [ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
+    ignore
+    "Echoes POST requests. Runs forever.";
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
+  Lwt.async (fun () ->
+    Lwt_io.establish_server_with_client_socket listen_address connection_handler
+    >>= fun _server ->
+    Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
+    print_string "To send a POST request, try\n\n";
+    print_string "  echo foo | dune exec examples/lwt/lwt_post.exe\n\n";
+    flush stdout;
+    Lwt.return_unit);
+  let forever, _ = Lwt.wait () in
+  Lwt_main.run forever