unikernel/duniverse/ocaml-h2/examples/mirage/unikernel.ml

@@ -0,0 +1,54 @@
+open Lwt.Infix
+open H2
+
+module type HTTP2 = H2_mirage.Server
+
+module Dispatch (C : Mirage_console.S) (Http2 : HTTP2) = struct
+  let log c fmt = Printf.ksprintf (C.log c) fmt
+
+  let get_content c path =
+    log c "Replying: %s" path >|= fun () -> "Hello from the h2 unikernel"
+
+  let dispatcher c reqd =
+    let { Request.target; _ } = Reqd.request reqd in
+    Lwt.catch
+      (fun () ->
+         get_content c target >|= fun body ->
+         let response =
+           Response.create
+             ~headers:
+               (Headers.of_list
+                  [ "content-length", body |> String.length |> string_of_int ])
+             `OK
+         in
+         Reqd.respond_with_string reqd response body)
+      (fun exn ->
+         let response = Response.create `Internal_server_error in
+         Lwt.return
+           (Reqd.respond_with_string reqd response (Printexc.to_string exn)))
+    |> ignore
+
+  let serve c dispatch =
+    let error_handler ?request:_ _error mk_response =
+      let response_body = mk_response Headers.empty in
+      Body.Writer.write_string response_body "Error handled";
+      Body.Writer.flush response_body (fun () ->
+        Body.Writer.close response_body)
+    in
+    Http2.create_connection_handler
+      ?config:None
+      ~request_handler:(dispatch c)
+      ~error_handler
+end
+
+(** Server boilerplate *)
+module Make (C : Mirage_console.S) (Clock : Mirage_clock.PCLOCK) (Http2 : HTTP2) =
+struct
+  module D = Dispatch (C) (Http2)
+
+  let log c fmt = Printf.ksprintf (C.log c) fmt
+
+  let start c _clock http2 =
+    log c "started unikernel listen on port 8001" >>= fun () ->
+    http2 (`TCP 8001) @@ D.serve c D.dispatcher
+end