Skip to content

Commit

Permalink
cohttp-eio : renovate Server module
Browse files Browse the repository at this point in the history
  • Loading branch information
@bikallem
bikallem committed Feb 16, 2023
1 parent f25bcd7 commit 2db1420
Show file tree
Hide file tree
Showing 5 changed files with 118 additions and 605 deletions.
14 changes: 7 additions & 7 deletions cohttp-eio/examples/server1.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,17 +30,17 @@ let text =

open Cohttp_eio

let app : Server.request -> Server.response =
fun ((req, _, _) : Server.request) ->
match Http.Request.resource req with
| "/" -> Server.text_response text
| "/html" -> Server.html_response text
| _ -> Server.not_found_response
let app req =
match Request.resource req with
| "/" -> Response.text text
| "/html" -> Response.html text
| _ -> Response.not_found

let () =
let port = ref 8080 in
Arg.parse
[ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ]
ignore "An HTTP/1.1 server";

Eio_main.run @@ fun env -> Server.run ~port:!port env app
Eio_main.run @@ fun env ->
Server.run ~port:!port ~on_error:raise env#domain_mgr env#net env#clock app
95 changes: 1 addition & 94 deletions cohttp-eio/src/cohttp_eio.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,98 +4,5 @@ module Chunked_body = Chunked_body
module Method = Method
module Request = Request
module Response = Response

(** [Server] is a HTTP 1.1 server. *)
module Server : sig
type request = Http.Request.t * Eio.Buf_read.t * Eio.Net.Sockaddr.stream
(** The request headers, a reader for the socket, and the address of the
client. To read the request body, use {!read_fixed} or {!read_chunked}. *)

type response = Http.Response.t * Body.t
type handler = request -> response

type 'a env =
< domain_mgr : Eio.Domain_manager.t
; net : Eio.Net.t
; clock : Eio.Time.clock
; .. >
as
'a

(** {1 Request Body} *)

val read_fixed : Http.Request.t -> Eio.Buf_read.t -> string option
(** [read_fixed (request, buf_read)] is [Some content], where [content] is of
length [n] if "Content-Length" header is a valid integer value [n] in
[request].
[buf_read] is updated to reflect that [n] bytes was read.
If ["Content-Length"] header is missing or is an invalid value in
[request] OR if the request http method is not one of [POST], [PUT] or
[PATCH], then [None] is returned. *)

val read_chunked :
Http.Request.t ->
Eio.Buf_read.t ->
(Body.chunk -> unit) ->
Http.Header.t option
(** [read_chunked request buf_read chunk_handler] is [Some updated_headers] if
"Transfer-Encoding" header value is "chunked" in [request] and all chunks
in [buf_read] are read successfully. [updated_headers] is the updated
headers as specified by the chunked encoding algorithm in https:
//datatracker.ietf.org/doc/html/rfc7230#section-4.1.3.
[buf_read] is updated to reflect the number of bytes read. Returns [None]
if [Transfer-Encoding] header in [headers] is not specified as "chunked" *)

(** {1 Response} *)

val text_response : string -> response
(** [text t s] returns a HTTP/1.1, 200 status response with "Content-Type"
header set to "text/plain". *)

val html_response : string -> response
(** [html t s] returns a HTTP/1.1, 200 status response with header set to
"Content-Type: text/html". *)

val not_found_response : response
(** [not_found t] returns a HTTP/1.1, 404 status response. *)

val internal_server_error_response : response
(** [internal_server_error] returns a HTTP/1.1, 500 status response. *)

val bad_request_response : response
(* [bad_request t] returns a HTTP/1.1, 400 status response. *)

(** {1 Run Server} *)

val run :
?socket_backlog:int -> ?domains:int -> port:int -> 'a env -> handler -> 'b
(** [run ~socket_backlog ~domains ~port env handler] runs a HTTP/1.1 server
executing [handler] and listening on [port]. [env] corresponds to
{!val:Eio.Stdenv.t}.
[socket_backlog] is the number of pending connections for tcp server
socket. The default is [128].
[domains] is the number of OCaml 5.0 domains the server will use. The
default is [1]. You may use {!val:Domain.recommended_domain_count} to
configure a multicore capable server. *)

val connection_handler :
handler ->
#Eio.Time.clock ->
#Eio.Net.stream_socket ->
Eio.Net.Sockaddr.stream ->
unit
(** [connection_handler request_handler] is a connection handler, suitable for
passing to {!Eio.Net.accept_fork}. *)

(** {1 Basic Handlers} *)

val not_found_handler : handler
(** [not_found_handler] return HTTP 404 response. *)
end

module Server = Server
module Client = Client
195 changes: 20 additions & 175 deletions cohttp-eio/src/server.ml
View file
Original file line number Diff line number Diff line change
@@ -1,205 +1,50 @@
module Buf_read = Eio.Buf_read
module Buf_write = Eio.Buf_write
module Switch = Eio.Switch

type middleware = handler -> handler
and handler = request -> response
and request = Http.Request.t * Eio.Buf_read.t * Eio.Net.Sockaddr.stream
and response = Http.Response.t * Body.t

type 'a env =
< domain_mgr : Eio.Domain_manager.t
; net : Eio.Net.t
; clock : Eio.Time.clock
; .. >
as
'a

(* Request *)

let read_fixed request reader =
match Http.Request.meth request with
| `POST | `PUT | `PATCH ->
let ( let* ) o f = Option.bind o f in
let ( let+ ) o f = Option.map f o in
let* v = Http.Header.get request.headers "Content-Length" in
let+ content_length = int_of_string_opt v in
Buf_read.take content_length reader
| _ -> None

let read_chunked request reader f =
Body.read_chunked reader (Http.Request.headers request) f

(* Responses *)

let is_custom body = match body with Body.Custom _ -> true | _ -> false

let text_response body =
let headers =
Http.Header.of_list
[
("content-type", "text/plain; charset=UTF-8");
("content-length", string_of_int @@ String.length body);
]
in
let response =
Http.Response.make ~version:`HTTP_1_1 ~status:`OK ~headers ()
in
(response, Body.Fixed body)

let html_response body =
let headers =
Http.Header.of_list
[
("content-type", "text/html; charset=UTF-8");
("content-length", string_of_int @@ String.length body);
]
in
let response =
Http.Response.make ~version:`HTTP_1_1 ~status:`OK ~headers ()
in
(response, Body.Fixed body)

let not_found_response = (Http.Response.make ~status:`Not_found (), Body.Empty)

let internal_server_error_response =
(Http.Response.make ~status:`Internal_server_error (), Body.Empty)

let bad_request_response =
(Http.Response.make ~status:`Bad_request (), Body.Empty)

let http_date clock =
let now = Eio.Time.now clock |> Ptime.of_float_s |> Option.get in
let (year, mm, dd), ((hh, min, ss), _) = Ptime.to_date_time now in
let weekday = Ptime.weekday now in
let weekday =
match weekday with
| `Mon -> "Mon"
| `Tue -> "Tue"
| `Wed -> "Wed"
| `Thu -> "Thu"
| `Fri -> "Fri"
| `Sat -> "Sat"
| `Sun -> "Sun"
in
let month =
match mm with
| 1 -> "Jan"
| 2 -> "Feb"
| 3 -> "Mar"
| 4 -> "Apr"
| 5 -> "May"
| 6 -> "Jun"
| 7 -> "Jul"
| 8 -> "Aug"
| 9 -> "Sep"
| 10 -> "Oct"
| 11 -> "Nov"
| 12 -> "Dec"
| _ -> failwith "Invalid HTTP datetime value"
in
Format.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" weekday dd month year hh
min ss

let write_response ?request clock writer (response, body) =
let headers =
let request_meth = Option.map Http.Request.meth request in
Body.add_content_length
(Http.Response.requires_content_length ?request_meth response)
(Http.Response.headers response)
body
in
let headers =
(* https://www.rfc-editor.org/rfc/rfc9110#section-6.6.1 *)
match Http.Response.status response with
| #Http.Status.informational | #Http.Status.server_error -> headers
| _ -> Http.Header.add headers "Date" (http_date clock)
in
let version = Http.Version.to_string response.version in
let status = Http.Status.to_string response.status in
Buf_write.string writer version;
Buf_write.char writer ' ';
Buf_write.string writer status;
Buf_write.string writer "\r\n";
Rwer.write_headers writer headers;
Buf_write.string writer "\r\n";
let write_chunked_trailers =
Option.map Http.Request.supports_chunked_trailers request
in
Body.write_body ?write_chunked_trailers writer body

(* request parsers *)

let meth =
let open Eio.Buf_read.Syntax in
let+ meth = Rwer.(token <* space) in
Http.Method.of_string meth

let resource =
let open Eio.Buf_read.Syntax in
Rwer.(take_while1 (fun c -> c != ' ') <* space)

let[@warning "-3"] http_request t =
let open Eio.Buf_read.Syntax in
let meth = meth t in
let resource = resource t in
let version = Rwer.(version <* crlf) t in
let headers = Rwer.http_headers t in
let encoding = Http.Header.get_transfer_encoding headers in
{ Http.Request.meth; resource; version; headers; scheme = None; encoding }

(* main *)
type handler = Request.server_request -> Response.server_response
(* type middleware = handler -> handler *)

let rec handle_request clock client_addr reader writer flow handler =
match http_request reader with
match Request.parse client_addr reader with
| request ->
let response, body = handler (request, reader, client_addr) in
write_response ~request clock writer (response, body);
if Http.Request.is_keep_alive request then
let response = handler request in
Response.write response clock writer;
if Request.keep_alive request then
handle_request clock client_addr reader writer flow handler
| (exception End_of_file)
| (exception Eio.Io (Eio.Net.E (Connection_reset _), _)) ->
()
| exception (Failure _ as ex) ->
write_response clock writer bad_request_response;
Response.(write bad_request clock writer);
raise ex
| exception ex ->
write_response clock writer internal_server_error_response;
Response.(write internal_server_error clock writer);
raise ex

let connection_handler (handler : handler) clock flow client_addr =
let connection_handler handler clock flow client_addr =
let reader = Buf_read.of_flow ~initial_size:0x1000 ~max_size:max_int flow in
Buf_write.with_flow flow (fun writer ->
handle_request clock client_addr reader writer flow handler)

let run_domain env ssock handler =
let on_error exn =
Printf.fprintf stderr "Error handling connection: %s\n%!"
(Printexc.to_string exn)
in
let handler = connection_handler handler env#clock in
Switch.run (fun sw ->
let run_domain clock ssock on_error handler =
let handler = connection_handler handler clock in
Eio.Switch.run (fun sw ->
let rec loop () =
Eio.Net.accept_fork ~sw ssock ~on_error handler;
loop ()
in
loop ())

let run ?(socket_backlog = 128) ?(domains = 1) ~port env handler =
Switch.run @@ fun sw ->
let domain_mgr = Eio.Stdenv.domain_mgr env in
let run ?(backlog = 128) ?(domains = 1) ~port ~on_error
(domain_mgr : #Eio.Domain_manager.t) (net : #Eio.Net.t)
(clock : #Eio.Time.clock) handler =
Eio.Switch.run @@ fun sw ->
let ssock =
Eio.Net.listen (Eio.Stdenv.net env) ~sw ~reuse_addr:true ~reuse_port:true
~backlog:socket_backlog
Eio.Net.listen net ~sw ~reuse_addr:true ~backlog
(`Tcp (Eio.Net.Ipaddr.V4.loopback, port))
in
for _ = 2 to domains do
Eio.Std.Fiber.fork ~sw (fun () ->
Eio.Domain_manager.run domain_mgr (fun () ->
run_domain env ssock handler))
run_domain clock ssock on_error handler))
done;
run_domain env ssock handler

(* Basic handlers *)
run_domain clock ssock on_error handler

let not_found_handler _ = not_found_response
let not_found_handler _ = Response.not_found
38 changes: 38 additions & 0 deletions cohttp-eio/src/server.mli
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,38 @@
(** [Server] is a HTTP 1.1 server. *)

type handler = Request.server_request -> Response.server_response

val run :
?backlog:int ->
?domains:int ->
port:int ->
on_error:(exn -> unit) ->
#Eio.Domain_manager.t ->
#Eio.Net.t ->
#Eio.Time.clock ->
handler ->
'c
(** [run ~port on_error domain_mgr net clock handler] runs a HTTP/1.1 server
executing [handler] and listening on [port].
@param backlog
is the number of pending connections for tcp server socket. The default is
[128].
@param domains
is the number of OCaml 5.0 domains the server will use. The default is
[1]. You may use {!val:Domain.recommended_domain_count} to configure a
multicore capable server. *)

val connection_handler :
handler ->
#Eio.Time.clock ->
#Eio.Net.stream_socket ->
Eio.Net.Sockaddr.stream ->
unit
(** [connection_handler request_handler client_addr conn] is a connection
handler, suitable for passing to {!Eio.Net.accept_fork}. *)

(** {1 Basic Handlers} *)

val not_found_handler : handler
(** [not_found_handler] return HTTP 404 response. *)
Loading

0 comments on commit 2db1420

Please sign in to comment.