Merge pull request #65 from c-cube/wip-cleanup-2023-06-20

cleanup and IO backend

Makefile

@@ -2,11 +2,12 @@
 
 all: build test
 
+OPTS?=--profile=release
 build:
-	@dune build @install
+	@dune build @install $(OPTS)
 
 test:
-	@dune runtest --no-buffer --force
+	@dune runtest --no-buffer --force $(OPTS)
 
 clean:
 	@dune clean
@@ -16,7 +17,7 @@ doc:
 
 WATCH?= "@install @runtest"
 watch:
-	@dune build $(WATCH) -w
+	@dune build $(OPTS) $(WATCH) -w
 
 .PHONY: benchs tests build watch
 

echo.sh

@@ -1,2 +1,2 @@
 #!/bin/sh
-exec dune exec --profile=release "examples/echo.exe" -- $@
+exec dune exec --display=quiet --profile=release "examples/echo.exe" -- $@

examples/echo.ml

@@ -33,6 +33,16 @@ let middleware_stat () : S.Middleware.t * (unit -> string) =
   in
   m, get_stat
 
+(* ugly AF *)
+let base64 x =
+  let ic, oc = Unix.open_process "base64" in
+  output_string oc x;
+  flush oc;
+  close_out oc;
+  let r = input_line ic in
+  ignore (Unix.close_process (ic, oc));
+  r
+
 let () =
   let port_ = ref 8080 in
   let j = ref 32 in
@@ -106,6 +116,35 @@ let () =
         S.Response.fail ~code:500 "couldn't upload file: %s"
           (Printexc.to_string e));
 
+  (* protected by login *)
+  S.add_route_handler server
+    S.Route.(exact "protected" @/ return)
+    (fun req ->
+      let ok =
+        match S.Request.get_header req "authorization" with
+        | Some v ->
+          S._debug (fun k -> k "authenticate with %S" v);
+          v = "Basic " ^ base64 "user:foobar"
+        | None -> false
+      in
+      if ok then (
+        (* FIXME: a logout link *)
+        let s =
+          "<p>hello, this is super secret!</p><a href=\"/logout\">log out</a>"
+        in
+        S.Response.make_string (Ok s)
+      ) else (
+        let headers =
+          S.Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"")
+        in
+        S.Response.fail ~code:401 ~headers "invalid"
+      ));
+
+  (* logout *)
+  S.add_route_handler server
+    S.Route.(exact "logout" @/ return)
+    (fun _req -> S.Response.fail ~code:401 "logged out");
+
   (* stats *)
   S.add_route_handler server
     S.Route.(exact "stats" @/ return)
@@ -171,6 +210,24 @@ let () =
                             txt " (GET) to access a VFS embedded in the binary";
                           ];
                       ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/protected" ] [ txt "/protected" ];
+                            txt
+                              " (GET) to see a protected page (login: user, \
+                               password: foobar)";
+                          ];
+                      ];
+                    li []
+                      [
+                        pre []
+                          [
+                            a [ A.href "/logout" ] [ txt "/logout" ];
+                            txt " (POST) to log out";
+                          ];
+                      ];
                   ];
               ];
           ]

src/Tiny_httpd.ml

@@ -4,3 +4,4 @@ include Tiny_httpd_server
 module Util = Tiny_httpd_util
 module Dir = Tiny_httpd_dir
 module Html = Tiny_httpd_html
+module IO = Tiny_httpd_io

src/Tiny_httpd.mli

@@ -85,6 +85,10 @@ module Buf = Tiny_httpd_buf
 
 module Byte_stream = Tiny_httpd_stream
 
+(** {2 IO Abstraction} *)
+
+module IO = Tiny_httpd_io
+
 (** {2 Main Server Type} *)
 
 (** @inline *)

src/Tiny_httpd_buf.ml

@@ -20,6 +20,16 @@ let add_bytes (self : t) s i len : unit =
   Bytes.blit s i self.bytes self.i len;
   self.i <- self.i + len
 
+let[@inline] add_string self str : unit =
+  add_bytes self (Bytes.unsafe_of_string str) 0 (String.length str)
+
+let add_buffer (self : t) (buf : Buffer.t) : unit =
+  let len = Buffer.length buf in
+  if self.i + len >= Bytes.length self.bytes then
+    resize self (self.i + (self.i / 2) + len + 10);
+  Buffer.blit buf 0 self.bytes self.i len;
+  self.i <- self.i + len
+
 let contents (self : t) : string = Bytes.sub_string self.bytes 0 self.i
 
 let contents_and_clear (self : t) : string =

src/Tiny_httpd_buf.mli

@@ -24,3 +24,11 @@ val contents_and_clear : t -> string
 val add_bytes : t -> bytes -> int -> int -> unit
 (** Append given bytes slice to the buffer.
     @since 0.5 *)
+
+val add_string : t -> string -> unit
+(** Add string.
+    @since NEXT_RELEASE *)
+
+val add_buffer : t -> Buffer.t -> unit
+(** Append bytes from buffer.
+    @since NEXT_RELEASE *)

src/Tiny_httpd_io.ml

@@ -0,0 +1,103 @@
+(** IO abstraction.
+
+    We abstract IO so we can support classic unix blocking IOs
+    with threads, and modern async IO with Eio.
+
+    {b NOTE}: experimental.
+
+    @since NEXT_RELEASE
+*)
+
+module Buf = Tiny_httpd_buf
+
+module In_channel = struct
+  type t = {
+    input: bytes -> int -> int -> int;
+        (** Read into the slice. Returns [0] only if the
+        channel is closed. *)
+    close: unit -> unit;
+  }
+
+  let of_in_channel ?(close_noerr = false) (ic : in_channel) : t =
+    {
+      input = (fun buf i len -> input ic buf i len);
+      close =
+        (fun () ->
+          if close_noerr then
+            close_in_noerr ic
+          else
+            close_in ic);
+    }
+
+  let of_unix_fd ?(close_noerr = false) (fd : Unix.file_descr) : t =
+    {
+      input = (fun buf i len -> Unix.read fd buf i len);
+      close =
+        (fun () ->
+          if close_noerr then (
+            try Unix.close fd with _ -> ()
+          ) else
+            Unix.close fd);
+    }
+
+  let[@inline] input (self : t) buf i len = self.input buf i len
+  let[@inline] close self : unit = self.close ()
+end
+
+module Out_channel = struct
+  type t = {
+    output: bytes -> int -> int -> unit;  (** Output slice *)
+    flush: unit -> unit;  (** Flush underlying buffer *)
+    close: unit -> unit;
+  }
+
+  let of_out_channel ?(close_noerr = false) (oc : out_channel) : t =
+    {
+      output = (fun buf i len -> output oc buf i len);
+      flush = (fun () -> flush oc);
+      close =
+        (fun () ->
+          if close_noerr then
+            close_out_noerr oc
+          else
+            close_out oc);
+    }
+
+  let[@inline] output (self : t) buf i len : unit = self.output buf i len
+
+  let[@inline] output_string (self : t) (str : string) : unit =
+    self.output (Bytes.unsafe_of_string str) 0 (String.length str)
+
+  let[@inline] close self : unit = self.close ()
+  let[@inline] flush self : unit = self.flush ()
+
+  let output_buf (self : t) (buf : Buf.t) : unit =
+    let b = Buf.bytes_slice buf in
+    output self b 0 (Buf.size buf)
+end
+
+(** A TCP server abstraction *)
+module TCP_server = struct
+  type conn_handler = {
+    handle: In_channel.t -> Out_channel.t -> unit;
+        (** Handle client connection *)
+  }
+
+  type t = {
+    endpoint: unit -> string * int;
+        (** Endpoint we listen on. This can only be called from within [serve]. *)
+    active_connections: unit -> int;
+        (** Number of connections currently active *)
+    running: unit -> bool;  (** Is the server currently running? *)
+    stop: unit -> unit;
+        (** Ask the server to stop. This might not take effect immediately. *)
+  }
+  (** Running server. *)
+
+  type builder = {
+    serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit;
+        (** Blocking call to listen for incoming connections and handle them.
+            Uses the connection handler to handle individual client connections. *)
+  }
+  (** A TCP server implementation. *)
+end