carlos / todomvc-bakeoff Public

Download this file

1	(* todo-ocaml: <bin> --socket <path> --db <path>, or --listen 127.0.0.1:<port>
2	in place of --socket for local runs. *)
3
4	let usage = "app (--socket <path> | --listen 127.0.0.1:<port>) --db <path>"
5
6	(* Bodies are form posts; 1 MiB is far more than any title needs. *)
7	let max_body = 1 lsl 20
8
9	(* The request line and headers of one request, together. *)
10	let max_head = 64 * 1024
11
12	(* Each connection costs at most about max_head + max_body of buffers. *)
13	let max_connections = 256
14
15	(* A socket that refuses to read more than [remaining] bytes. cohttp-eio
16	parses headers from an unbounded buffer, so every read goes through one
17	of these: a connection starts with max_head bytes, and each request it
18	carries gets max_body + max_head more (its body, then the next request's
19	head). Running out raises [Head_too_large]. *)
20	module Budget = struct
21	exception Head_too_large
22
23	type t = { flow : Eio.Flow.source_ty Eio.Resource.t; mutable remaining : int }
24
25	let read_methods = []
26
27	let single_read t buf =
28	if t.remaining <= 0 then raise Head_too_large;
29	let buf = if Cstruct.length buf > t.remaining then Cstruct.sub buf 0 t.remaining else buf in
30	let n = Eio.Flow.single_read t.flow buf in
31	t.remaining <- t.remaining - n;
32	n
33
34	let handler = Eio.Flow.Pi.source (module struct
35	type nonrec t = t
36	let read_methods = read_methods
37	let single_read = single_read
38	end)
39
40	let source t : Eio.Flow.source_ty Eio.Resource.t = Eio.Resource.T (t, handler)
41
42	(* The budget of the connection whose request is being handled. *)
43	let key : t Eio.Fiber.key = Eio.Fiber.create_key ()
44
45	let next_request () =
46	Option.iter (fun t -> t.remaining <- max_body + max_head) (Eio.Fiber.get key)
47	end
48
49	let fail fmt = Printf.ksprintf (fun s -> prerr_endline ("app: " ^ s); exit 2) fmt
50
51	let parse_listen s =
52	match String.rindex_opt s ':' with
53	| None -> fail "--listen wants 127.0.0.1:<port>, got %S" s
54	| Some i -> (
55	let host = String.sub s 0 i and port = String.sub s (i + 1) (String.length s - i - 1) in
56	match (host, int_of_string_opt port) with
57	| "127.0.0.1", Some port when port > 0 && port < 65536 ->
58	(`Tcp (Eio.Net.Ipaddr.V4.loopback, port), "http://" ^ s)
59	| "127.0.0.1", _ -> fail "bad port in --listen %S" s
60	| _ -> fail "--listen only binds 127.0.0.1, got %S" host)
61
62	let to_app_request req body =
63	let headers = Http.Request.headers req in
64	let uri = Uri.of_string (Http.Request.resource req) in
65	{
66	Todo.App.meth = Http.Method.to_string (Http.Request.meth req);
67	path = Uri.path uri;
68	query = List.map (fun (k, v) -> (k, String.concat "," v)) (Uri.query uri);
69	header = Http.Header.get headers;
70	body;
71	}
72
73	let callback app _conn req body =
74	Budget.next_request ();
75	let body =
76	match Http.Request.meth req with
77	| `POST -> Eio.Buf_read.(parse take_all) ~max_size:max_body body
78	| _ -> Ok ""
79	in
80	let (res : Todo.App.response) =
81	match body with
82	| Ok body -> Todo.App.handle app (to_app_request req body)
83	| Error _ -> Todo.App.text 413 "Request body too large\n"
84	in
85	let headers = Http.Header.of_list res.headers in
86	let status = Http.Status.of_int res.status in
87	match Http.Request.meth req with
88	| `HEAD ->
89	let headers = Http.Header.add headers "content-length" (string_of_int (String.length res.body)) in
90	Cohttp_eio.Server.respond ~headers ~status ~body:(Eio.Flow.string_source "") ()
91	| _ -> Cohttp_eio.Server.respond_string ~headers ~status ~body:res.body ()
92
93	(* One connection: cohttp-eio's own loop over keep-alive requests, reading
94	through a Budget. A head too large for it gets 431 and the connection
95	closes. *)
96	let connection server socket peer =
97	Eio.Switch.run @@ fun sw ->
98	let budget = { Budget.flow = (socket :> Eio.Flow.source_ty Eio.Resource.t); remaining = max_head } in
99	let input = Eio.Buf_read.of_flow ~max_size:max_head (Budget.source budget) in
100	Eio.Fiber.with_binding Budget.key budget @@ fun () ->
101	try
102	Eio.Buf_write.with_flow socket @@ fun output ->
103	try Cohttp_eio.Server.callback server (sw, peer) input output
104	with Budget.Head_too_large | Eio.Buf_read.Buffer_limit_exceeded ->
105	Eio.Buf_write.string output
106	"HTTP/1.1 431 Request Header Fields Too Large\r\ncontent-length: 0\r\nconnection: close\r\n\r\n"
107	with Eio.Io (Eio.Net.E (Connection_reset _), _) -> ()
108
109	let () =
110	let socket = ref "" and listen = ref "" and db = ref "" in
111	Arg.parse
112	[ ("--socket", Arg.Set_string socket, "<path> unix socket to listen on");
113	("--listen", Arg.Set_string listen, "<127.0.0.1:port> TCP address, for local runs");
114	("--db", Arg.Set_string db, "<path> SQLite database file") ]
115	(fun a -> fail "unexpected argument %S" a)
116	usage;
117	if !db = "" || (!socket = "") = (!listen = "") then (prerr_endline ("usage: " ^ usage); exit 2);
118	let addr, origin =
119	if !listen <> "" then parse_listen !listen
120	else
121	( `Unix !socket,
122	match Sys.getenv_opt "CARLOS_HOST" with
123	| Some h when h <> "" -> "https://" ^ h
124	| _ -> "http://localhost" )
125	in
126	let store = Todo.Store.open_ !db in
127	let app = Todo.App.create ~store ~origin ~version:Todo.Version.v in
128	(* SIGTERM and SIGINT stop the server; Condition.broadcast is signal-safe. *)
129	let stop = Eio.Condition.create () in
130	let on_signal _ = Eio.Condition.broadcast stop in
131	Sys.set_signal Sys.sigterm (Sys.Signal_handle on_signal);
132	Sys.set_signal Sys.sigint (Sys.Signal_handle on_signal);
133	Eio_posix.run (fun env ->
134	Eio.Switch.run (fun sw ->
135	(match addr with `Unix path when Sys.file_exists path -> Sys.remove path | _ -> ());
136	let sock = Eio.Net.listen ~sw ~backlog:128 ~reuse_addr:true (Eio.Stdenv.net env) addr in
137	Printf.eprintf "app: %s listening on %s\n%!" Todo.Version.v
138	(if !listen <> "" then !listen else !socket);
139	let server = Cohttp_eio.Server.make ~callback:(callback app) () in
140	Eio.Fiber.first
141	(fun () -> Eio.Condition.await_no_mutex stop)
142	(fun () ->
143	Eio.Net.run_server sock (connection server) ~max_connections ~on_error:(fun e ->
144	Printf.eprintf "app: %s\n%!" (Printexc.to_string e)))));
145	(match addr with `Unix path -> (try Sys.remove path with Sys_error _ -> ()) | _ -> ());
146	Todo.Store.close store;
147	prerr_endline "app: stopped"
148