unikernel/duniverse/httpun/examples/mirage/unikernel.ml

@@ -0,0 +1,52 @@
+open Lwt.Infix
+open Httpun
+
+module type HTTP = httpun_mirage.Server
+
+module Dispatch (C: Mirage_console.S) (Http: HTTP) = 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 httpun unikernel"
+
+  let dispatcher c { Gluten.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.write_string response_body "Error handled";
+      Body.flush response_body (fun () -> Body.close_writer response_body)
+    in
+    Http.create_connection_handler
+      ?config:None
+      ~request_handler:(dispatch c)
+      ~error_handler
+end
+
+(** Server boilerplate *)
+module Make (C : Mirage_console.S) (Clock : Mirage_clock.PCLOCK) (Http: HTTP) = struct
+
+  module D  = Dispatch (C) (Http)
+
+  let log c fmt = Printf.ksprintf (C.log c) fmt
+  let start c _clock http =
+    log c "started unikernel listen on port 8001" >>= fun () ->
+    http (`TCP 8001) @@ D.serve c D.dispatcher
+end