test and examples for domains

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")))))

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

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

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

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

tests/echo1.expect

@@ -43,7 +43,7 @@ sub
 <a href="/vfs/test_out.txt">
 test_out.txt
 </a>
- (209b)
+ (431b)
 </li>
 </ul>
 </body>