53 lines
1.6 KiB
OCaml
53 lines
1.6 KiB
OCaml
|
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
|