diff --git a/examples/dune b/examples/dune index be6aa799..741e204c 100644 --- a/examples/dune +++ b/examples/dune @@ -4,6 +4,11 @@ (modules sse_server) (libraries tiny_httpd unix ptime ptime.clock.os)) +(executable + (name sse_server_domains) + (modules sse_server_domains) + (libraries tiny_httpd tiny_httpd_domains unix ptime ptime.clock.os)) + (executable (name sse_client) (modules sse_client) @@ -15,6 +20,12 @@ (modules echo vfs) (libraries tiny_httpd tiny_httpd_camlzip)) +(executable + (name echo_domains) + (flags :standard -warn-error -a+8) + (modules echo_domains vfs_domains) + (libraries tiny_httpd tiny_httpd_camlzip tiny_httpd_domains)) + (rule (targets test_output.txt) (deps (:script ./run_test.sh) ./sse_client.exe ./sse_server.exe) @@ -51,3 +62,24 @@ (progn (echo "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:0. ()") (echo "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs"))))) + +; to make dune happy, duplicate vfs FIXME! +(rule + (targets vfs_domains.ml) + (deps (source_tree files) (:out test_output.txt.expected)) + (enabled_if (= %{system} "linux")) + (action (run %{bin:tiny-httpd-vfs-pack} -o %{targets} + --mirror=files/ + --file=test_out.txt,%{out} + ; --url=example_dot_com,http://example.com ; this breaks tests in opam sandbox 😢 + ))) + +(rule + (targets vfs_domains.ml) + (enabled_if (<> %{system} "linux")) + (action + (with-stdout-to + %{targets} + (progn + (echo "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:0. ()") + (echo "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs"))))) diff --git a/examples/echo_domains.ml b/examples/echo_domains.ml new file mode 100644 index 00000000..b74cce7a --- /dev/null +++ b/examples/echo_domains.ml @@ -0,0 +1,146 @@ + +module S = Tiny_httpd +module D = Tiny_httpd_domains + +let now_ = Unix.gettimeofday + +(* util: a little middleware collecting statistics *) +let middleware_stat () : S.Middleware.t * (unit -> string) = + let n_req = ref 0 in + let total_time_ = ref 0. in + let parse_time_ = ref 0. in + let build_time_ = ref 0. in + let write_time_ = ref 0. in + + let m h req ~resp = + incr n_req; + let t1 = S.Request.start_time req in + let t2 = now_ () in + h req ~resp:(fun response -> + let t3 = now_ () in + resp response; + let t4 = now_ () in + total_time_ := !total_time_ +. (t4 -. t1); + parse_time_ := !parse_time_ +. (t2 -. t1); + build_time_ := !build_time_ +. (t3 -. t2); + write_time_ := !write_time_ +. (t4 -. t3); + ) + and get_stat () = + Printf.sprintf "%d requests (average response time: %.3fms = %.3fms + %.3fms + %.3fms)" + !n_req (!total_time_ /. float !n_req *. 1e3) + (!parse_time_ /. float !n_req *. 1e3) + (!build_time_ /. float !n_req *. 1e3) + (!write_time_ /. float !n_req *. 1e3) + in + m, get_stat + +let () = + let port_ = ref 8080 in + let j = ref 32 in + let nbd = ref (Domain.recommended_domain_count ()) in + + Arg.parse (Arg.align [ + "--port", Arg.Set_int port_, " set port"; + "-p", Arg.Set_int port_, " set port"; + "-n", Arg.Set_int nbd, " set number of domains"; + "--debug", Arg.Unit (fun () -> S._enable_debug true), " enable debug"; + "-j", Arg.Set_int j, " maximum number of connections"; + ]) (fun _ -> raise (Arg.Bad "")) "echo [option]*"; + + let pool = Domainslib.Task.setup_pool ~num_domains:!nbd () in + let new_thread = D.new_thread pool in + let server = S.create ~port:!port_ ~max_connections:!j ~new_thread () in + Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16*1024) server; + + let m_stats, get_stats = middleware_stat () in + S.add_middleware server ~stage:(`Stage 1) m_stats; + + (* say hello *) + S.add_route_handler ~meth:`GET server + S.Route.(exact "hello" @/ string @/ return) + (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n"))); + + (* compressed file access *) + S.add_route_handler ~meth:`GET server + S.Route.(exact "zcat" @/ string_urlencoded @/ return) + (fun path _req -> + let ic = open_in path in + let str = S.Byte_stream.of_chan ic in + let mime_type = + try + let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in + try + let s = ["Content-Type", String.trim (input_line p)] in + ignore @@ Unix.close_process_in p; + s + with _ -> ignore @@ Unix.close_process_in p; [] + with _ -> [] + in + S.Response.make_stream ~headers:mime_type (Ok str) + ); + + (* echo request *) + S.add_route_handler server + S.Route.(exact "echo" @/ return) + (fun req -> + let q = + S.Request.query req |> List.map (fun (k,v) -> Printf.sprintf "%S = %S" k v) + |> String.concat ";" + in + S.Response.make_string + (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." S.Request.pp req q))); + + (* file upload *) + S.add_route_handler_stream ~meth:`PUT server + S.Route.(exact "upload" @/ string @/ return) + (fun path req -> + S._debug (fun k->k "start upload %S, headers:\n%s\n\n%!" path + (Format.asprintf "%a" S.Headers.pp (S.Request.headers req))); + try + let oc = open_out @@ "/tmp/" ^ path in + S.Byte_stream.to_chan oc req.S.Request.body; + flush oc; + S.Response.make_string (Ok "uploaded file") + with e -> + S.Response.fail ~code:500 "couldn't upload file: %s" (Printexc.to_string e) + ); + + (* stats *) + S.add_route_handler server S.Route.(exact "stats" @/ return) + (fun _req -> + let stats = get_stats() in + S.Response.make_string @@ Ok stats + ); + + (* VFS *) + Tiny_httpd_dir.add_vfs server + ~config:(Tiny_httpd_dir.config ~download:true + ~dir_behavior:Tiny_httpd_dir.Index_or_lists ()) + ~vfs:Vfs_domains.vfs ~prefix:"vfs"; + + (* main page *) + S.add_route_handler server S.Route.(return) + (fun _req -> + let open Tiny_httpd_html in + let h = html [] [ + head[][title[][txt "index of echo"]]; + body[][ + h3[] [txt "welcome!"]; + p[] [b[] [txt "endpoints are:"]]; + ul[] [ + li[][pre[][txt "/hello/:name (GET)"]]; + li[][pre[][a[A.href "/echo/"][txt "echo"]; txt " echo back query"]]; + li[][pre[][txt "/upload/:path (PUT) to upload a file"]]; + li[][pre[][txt "/zcat/:path (GET) to download a file (deflate transfer-encoding)"]]; + li[][pre[][a[A.href "/stats/"][txt"/stats/"]; txt" (GET) to access statistics"]]; + li[][pre[][a[A.href "/vfs/"][txt"/vfs"]; txt" (GET) to access a VFS embedded in the binary"]]; + ] + ] + ] in + let s = to_string_top h in + S.Response.make_string ~headers:["content-type", "text/html"] @@ Ok s); + + Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server); + match D.run pool server with + | Ok () -> () + | Error e -> raise e diff --git a/examples/run_test.sh b/examples/run_test.sh index 97d920b6..c70a6175 100755 --- a/examples/run_test.sh +++ b/examples/run_test.sh @@ -10,3 +10,14 @@ sleep 0.1 kill $PID echo "success" + +if [ -x ./sse_server_domains.exe ]; then + ./sse_server_domains.exe -p $PORT & + PID=$! + + sleep 0.1 + ./sse_client.exe -p $PORT --alarm=1 /count | tr -d '\r' || true + + kill $PID + echo "success with domains" +fi diff --git a/examples/sse_server_domains.ml b/examples/sse_server_domains.ml new file mode 100644 index 00000000..9f3f19d5 --- /dev/null +++ b/examples/sse_server_domains.ml @@ -0,0 +1,66 @@ + +(* serves some streams of events *) + +module S = Tiny_httpd +module D = Tiny_httpd_domains + +let port = ref 8080 +let nbd = ref (Domain.recommended_domain_count ()) + +let () = + Arg.parse (Arg.align [ + "-p", Arg.Set_int port, " port to listen on"; + "-n", Arg.Set_int nbd, " set number of domains"; + "--debug", Arg.Bool S._enable_debug, " toggle debug"; + ]) (fun _ -> ()) "sse_clock [opt*]"; + + let pool = Domainslib.Task.setup_pool ~num_domains:!nbd () in + let new_thread = D.new_thread pool in + let server = S.create ~port:!port ~new_thread () in + + let extra_headers = [ + "Access-Control-Allow-Origin", "*"; + "Access-Control-Allow-Methods", "POST, GET, OPTIONS"; + ] in + + (* tick/tock goes the clock *) + S.add_route_server_sent_handler server S.Route.(exact "clock" @/ return) + (fun _req (module EV : S.SERVER_SENT_GENERATOR) -> + S._debug (fun k->k"new connection"); + EV.set_headers extra_headers; + let tick = ref true in + while true do + let now = Ptime_clock.now() in + S._debug (fun k->k"send clock ev %s" (Format.asprintf "%a" Ptime.pp now)); + EV.send_event ~event:(if !tick then "tick" else "tock") + ~data:(Ptime.to_rfc3339 now) (); + tick := not !tick; + + Unix.sleepf 1.0; + done; + ); + + (* just count *) + S.add_route_server_sent_handler server S.Route.(exact "count" @/ return) + (fun _req (module EV : S.SERVER_SENT_GENERATOR) -> + let n = ref 0 in + while true do + EV.send_event ~data:(string_of_int !n) (); + incr n; + Unix.sleepf 0.1; + done; + ); + S.add_route_server_sent_handler server S.Route.(exact "count" @/ int @/ return) + (fun n _req (module EV : S.SERVER_SENT_GENERATOR) -> + for i=0 to n do + EV.send_event ~data:(string_of_int i) (); + Unix.sleepf 0.1; + done; + EV.close(); + ); + + Printf.printf "listening on http://localhost:%d/\n%!" (S.port server); + match D.run pool server with + | Ok () -> () + | Error e -> + Printf.eprintf "error: %s\n%!" (Printexc.to_string e); exit 1 diff --git a/examples/test_output.txt.expected b/examples/test_output.txt.expected index 5adb0103..4a5d16f8 100644 --- a/examples/test_output.txt.expected +++ b/examples/test_output.txt.expected @@ -24,3 +24,29 @@ data: 8 data: 9 success +listening on http://localhost:8082/ +connect to 127.0.0.1:8082 +HTTP/1.1 200 OK +content-type: text/event-stream + +data: 0 + +data: 1 + +data: 2 + +data: 3 + +data: 4 + +data: 5 + +data: 6 + +data: 7 + +data: 8 + +data: 9 + +success with domains diff --git a/tests/echo1.expect b/tests/echo1.expect index 56575a10..7473433c 100644 --- a/tests/echo1.expect +++ b/tests/echo1.expect @@ -43,7 +43,7 @@ sub test_out.txt - (209b) + (431b)