simon/tiny_httpd
1
0
Fork 0
mirror of https://github.com/c-cube/tiny_httpd.git synced 2025-12-05 19:00:32 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

ocamlformat

Browse source
This commit is contained in:
Simon Cruanes 2023-05-23 17:40:18 -04:00
parent 30a355da5a
commit 0908d71e19
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
34 changed files with 2103 additions and 1983 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
.ocamlformat Normal file
View file

@ -0,0 +1,14 @@
version = 0.24.1
profile=conventional
margin=80
if-then-else=k-r
parens-ite=true
parens-tuple=multi-line-only
sequence-style=terminator
type-decl=compact
break-cases=toplevel
cases-exp-indent=2
field-space=tight-decl
leading-nested-match-parens=true
module-item-spacing=compact
quiet=true

97
examples/dune
View file

@ -1,53 +1,68 @@
(executable
(name sse_server)
(modules sse_server)
(libraries tiny_httpd unix ptime ptime.clock.os))
(executable
(name sse_server)
(modules sse_server)
(libraries tiny_httpd unix ptime ptime.clock.os))
(name sse_client)
(modules sse_client)
(libraries unix))
(executable
(name sse_client)
(modules sse_client)
(libraries unix))
(executable
(name echo)
(flags :standard -warn-error -a+8)
(modules echo vfs)
(libraries tiny_httpd tiny_httpd_camlzip))
(name echo)
(flags :standard -warn-error -a+8)
(modules echo vfs)
(libraries tiny_httpd tiny_httpd_camlzip))
(rule
(targets test_output.txt)
(deps (:script ./run_test.sh) ./sse_client.exe ./sse_server.exe)
(enabled_if (= %{system} "linux"))
(package tiny_httpd)
(action
(with-stdout-to %{targets} (run %{script}))))
(targets test_output.txt)
(deps
(:script ./run_test.sh)
./sse_client.exe
./sse_server.exe)
(enabled_if
(= %{system} "linux"))
(package tiny_httpd)
(action
(with-stdout-to
%{targets}
(run %{script}))))
(rule
(alias runtest)
(package tiny_httpd)
(enabled_if (= %{system} "linux"))
(deps test_output.txt)
(action
(diff test_output.txt.expected test_output.txt)))
(alias runtest)
(package tiny_httpd)
(enabled_if
(= %{system} "linux"))
(deps test_output.txt)
(action
(diff test_output.txt.expected test_output.txt)))
; produce an embedded FS
(rule
(targets vfs.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.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")))))
(targets vfs.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.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")))))

185
examples/echo.ml
View file

@ -1,4 +1,3 @@
module S = Tiny_httpd
let now_ = Unix.gettimeofday
@ -22,30 +21,34 @@ let middleware_stat () : S.Middleware.t * (unit -> string) =
total_time_ := !total_time_ +. (t4 -. t1);
parse_time_ := !parse_time_ +. (t2 -. t1);
build_time_ := !build_time_ +. (t3 -. t2);
write_time_ := !write_time_ +. (t4 -. t3);
)
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)
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
Arg.parse (Arg.align [
"--port", Arg.Set_int port_, " set port";
"-p", Arg.Set_int port_, " set port";
"--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]*";
Arg.parse
(Arg.align
[
"--port", Arg.Set_int port_, " set port";
"-p", Arg.Set_int port_, " set port";
"--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 server = S.create ~port:!port_ ~max_connections:!j () in
Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16*1024) server;
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;
@ -53,87 +56,127 @@ let () =
(* 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")));
(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 =
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 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)
);
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)));
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)
);
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)
S.add_route_handler server
S.Route.(exact "stats" @/ return)
(fun _req ->
let stats = get_stats() in
S.Response.make_string @@ Ok stats
);
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 ())
~config:
(Tiny_httpd_dir.config ~download:true
~dir_behavior:Tiny_httpd_dir.Index_or_lists ())
~vfs:Vfs.vfs ~prefix:"vfs";
(* main page *)
S.add_route_handler server S.Route.(return)
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);
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 S.run server with

22
examples/sse_client.ml
View file

@ -1,15 +1,20 @@
let addr = ref "127.0.0.1"
let port = ref 8080
let path = ref "/clock"
let bufsize = 1024
let () =
Arg.parse (Arg.align [
"-h", Arg.Set_string addr, " address to connect to";
"-p", Arg.Set_int port, " port to connect to";
"--alarm", Arg.Int (fun i->Unix.alarm i|>ignore), " set alarm (in seconds)";
]) (fun s -> path := s) "sse_client [opt]* path?";
Arg.parse
(Arg.align
[
"-h", Arg.Set_string addr, " address to connect to";
"-p", Arg.Set_int port, " port to connect to";
( "--alarm",
Arg.Int (fun i -> Unix.alarm i |> ignore),
" set alarm (in seconds)" );
])
(fun s -> path := s)
"sse_client [opt]* path?";
Format.printf "connect to %s:%d@." !addr !port;
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
@ -25,7 +30,8 @@ let () =
let buf = Bytes.create bufsize in
while !continue do
let n = input ic buf 0 bufsize in
if n=0 then continue := false;
output stdout buf 0 n; flush stdout
if n = 0 then continue := false;
output stdout buf 0 n;
flush stdout
done;
Format.printf "exit!@."

94
examples/sse_server.ml
View file

@ -1,4 +1,3 @@
(* serves some streams of events *)
module S = Tiny_httpd
@ -6,57 +5,68 @@ module S = Tiny_httpd
let port = ref 8080
let () =
Arg.parse (Arg.align [
"-p", Arg.Set_int port, " port to listen on";
"--debug", Arg.Bool S._enable_debug, " toggle debug";
]) (fun _ -> ()) "sse_clock [opt*]";
Arg.parse
(Arg.align
[
"-p", Arg.Set_int port, " port to listen on";
"--debug", Arg.Bool S._enable_debug, " toggle debug";
])
(fun _ -> ())
"sse_clock [opt*]";
let server = S.create ~port:!port () in
let extra_headers = [
"Access-Control-Allow-Origin", "*";
"Access-Control-Allow-Methods", "POST, GET, OPTIONS";
] 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)
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;
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;
);
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();
);
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 S.run server with
| Ok () -> ()
| Error e ->
Printf.eprintf "error: %s\n%!" (Printexc.to_string e); exit 1
Printf.eprintf "error: %s\n%!" (Printexc.to_string e);
exit 1

6
src/Tiny_httpd.ml
View file

@ -1,4 +1,3 @@
(** Tiny Httpd.
A small HTTP/1.1 server, in pure OCaml, along with some utilities
@ -8,13 +7,8 @@
*)
module Buf = Tiny_httpd_buf
module Byte_stream = Tiny_httpd_stream
include Tiny_httpd_server
module Util = Tiny_httpd_util
module Dir = Tiny_httpd_dir
module Html = Tiny_httpd_html

6
src/Tiny_httpd.mli
View file

@ -1,4 +1,3 @@
(** {1 Tiny Http Server}
This library implements a very simple, basic HTTP/1.1 server using blocking
@ -74,7 +73,6 @@ echo:
*)
(** {2 Tiny buffer implementation}
These buffers are used to avoid allocating too many byte arrays when
@ -93,7 +91,9 @@ module Byte_stream = Tiny_httpd_stream
(** {2 Main Server Type} *)
(** @inline *)
include module type of struct include Tiny_httpd_server end
include module type of struct
include Tiny_httpd_server
end
(** {2 Utils} *)

27
src/Tiny_httpd_buf.ml
View file

@ -1,18 +1,12 @@
type t = { mutable bytes: bytes; mutable i: int }
type t = {
mutable bytes: bytes;
mutable i: int;
}
let create ?(size=4_096) () : t =
{ bytes=Bytes.make size ' '; i=0 }
let create ?(size = 4_096) () : t = { bytes = Bytes.make size ' '; i = 0 }
let size self = self.i
let bytes_slice self = self.bytes
let clear self : unit =
if Bytes.length self.bytes > 4_096 * 1_024 then (
self.bytes <- Bytes.make 4096 ' '; (* free big buffer *)
);
if Bytes.length self.bytes > 4_096 * 1_024 then
self.bytes <- Bytes.make 4096 ' ' (* free big buffer *);
self.i <- 0
let resize self new_size : unit =
@ -20,16 +14,15 @@ let resize self new_size : unit =
Bytes.blit self.bytes 0 new_buf 0 self.i;
self.bytes <- new_buf
let add_bytes (self:t) s i len : unit =
if self.i + len >= Bytes.length self.bytes then (
resize self (self.i + self.i / 2 + len + 10);
);
let add_bytes (self : t) s i len : unit =
if self.i + len >= Bytes.length self.bytes then
resize self (self.i + (self.i / 2) + len + 10);
Bytes.blit s i 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 (self : t) : string = Bytes.sub_string self.bytes 0 self.i
let contents_and_clear (self:t) : string =
let contents_and_clear (self : t) : string =
let x = contents self in
clear self;
x

3
src/Tiny_httpd_buf.mli
View file

@ -1,4 +1,3 @@
(** Simple buffer.
These buffers are used to avoid allocating too many byte arrays when
@ -8,6 +7,7 @@
*)
type t
val size : t -> int
val clear : t -> unit
val create : ?size:int -> unit -> t
@ -24,4 +24,3 @@ val contents_and_clear : t -> string
val add_bytes : t -> bytes -> int -> int -> unit
(** Append given bytes slice to the buffer.
@since 0.5 *)

518
src/Tiny_httpd_dir.ml
View file

@ -3,62 +3,73 @@ module U = Tiny_httpd_util
module Html = Tiny_httpd_html
module Pf = Printf
type dir_behavior =
| Index | Lists | Index_or_lists | Forbidden
type dir_behavior = Index | Lists | Index_or_lists | Forbidden
type hidden = unit
type config = {
mutable download: bool;
mutable dir_behavior: dir_behavior;
mutable delete: bool;
mutable upload: bool;
mutable max_upload_size: int;
_rest: hidden
_rest: hidden;
}
let default_config_ : config =
{ download=true;
dir_behavior=Forbidden;
delete=false;
upload=false;
{
download = true;
dir_behavior = Forbidden;
delete = false;
upload = false;
max_upload_size = 10 * 1024 * 1024;
_rest=();
_rest = ();
}
let default_config () = default_config_
let config
?(download=default_config_.download)
?(dir_behavior=default_config_.dir_behavior)
?(delete=default_config_.delete)
?(upload=default_config_.upload)
?(max_upload_size=default_config_.max_upload_size)
() : config =
{ download; dir_behavior; delete; upload; max_upload_size;
_rest=()}
let config ?(download = default_config_.download)
?(dir_behavior = default_config_.dir_behavior)
?(delete = default_config_.delete) ?(upload = default_config_.upload)
?(max_upload_size = default_config_.max_upload_size) () : config =
{ download; dir_behavior; delete; upload; max_upload_size; _rest = () }
let contains_dot_dot s =
try
String.iteri
(fun i c ->
if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit)
if c = '.' && i + 1 < String.length s && String.get s (i + 1) = '.' then
raise Exit)
s;
false
with Exit -> true
(* Human readable size *)
let human_size (x:int) : string =
if x >= 1_000_000_000 then Printf.sprintf "%d.%dG" (x / 1_000_000_000) ((x/1_000_000) mod 1_000_000)
else if x >= 1_000_000 then Printf.sprintf "%d.%dM" (x / 1_000_000) ((x/1000) mod 1_000)
else if x >= 1_000 then Printf.sprintf "%d.%dk" (x/1000) ((x/100) mod 100)
else Printf.sprintf "%db" x
let human_size (x : int) : string =
if x >= 1_000_000_000 then
Printf.sprintf "%d.%dG" (x / 1_000_000_000) (x / 1_000_000 mod 1_000_000)
else if x >= 1_000_000 then
Printf.sprintf "%d.%dM" (x / 1_000_000) (x / 1000 mod 1_000)
else if x >= 1_000 then
Printf.sprintf "%d.%dk" (x / 1000) (x / 100 mod 100)
else
Printf.sprintf "%db" x
let header_html = "Content-Type", "text/html"
let (//) = Filename.concat
let ( // ) = Filename.concat
let encode_path s = U.percent_encode ~skip:(function '/' -> true|_->false) s
let _decode_path s = match U.percent_decode s with Some s->s | None -> s
let encode_path s =
U.percent_encode
~skip:(function
| '/' -> true
| _ -> false)
s
let is_hidden s = String.length s>0 && s.[0] = '.'
let _decode_path s =
match U.percent_decode s with
| Some s -> s
| None -> s
let is_hidden s = String.length s > 0 && s.[0] = '.'
module type VFS = sig
val descr : string
@ -74,42 +85,46 @@ end
type vfs = (module VFS)
let vfs_of_dir (top:string) : vfs =
let vfs_of_dir (top : string) : vfs =
let module M = struct
let descr = top
let (//) = Filename.concat
let ( // ) = Filename.concat
let is_directory f = Sys.is_directory (top // f)
let contains f = Sys.file_exists (top // f)
let list_dir f = Sys.readdir (top // f)
let read_file_content f =
let ic = Unix.(openfile (top // f) [O_RDONLY] 0) in
let ic = Unix.(openfile (top // f) [ O_RDONLY ] 0) in
Tiny_httpd_stream.of_fd ic
let create f =
let oc = open_out_bin (top // f) in
let write = output oc in
let close() = close_out oc in
let close () = close_out oc in
write, close
let delete f = Sys.remove (top // f)
let file_size f =
try Some (Unix.stat (top // f)).Unix.st_size
with _ -> None
try Some (Unix.stat (top // f)).Unix.st_size with _ -> None
let file_mtime f =
try Some (Unix.stat (top // f)).Unix.st_mtime
with _ -> None
try Some (Unix.stat (top // f)).Unix.st_mtime with _ -> None
end in
(module M)
let html_list_dir (module VFS:VFS) ~prefix ~parent d : Html.elt =
let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
let entries = VFS.list_dir d in
Array.sort String.compare entries;
let open Html in
(* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *)
let head =
head[][
title[][txtf "list directory %S" VFS.descr];
meta[A.charset "utf-8"];
] in
head []
[
title [] [ txtf "list directory %S" VFS.descr ];
meta [ A.charset "utf-8" ];
]
in
let n_hidden = ref 0 in
Array.iter (fun f -> if is_hidden f then incr n_hidden) entries;
@ -117,51 +132,70 @@ let html_list_dir (module VFS:VFS) ~prefix ~parent d : Html.elt =
let file_to_elt f : elt option =
if not @@ contains_dot_dot (d // f) then (
let fpath = d // f in
if not @@ VFS.contains fpath then (
Some (li[][txtf "%s [invalid file]" f])
) else (
if not @@ VFS.contains fpath then
Some (li [] [ txtf "%s [invalid file]" f ])
else (
let size =
match VFS.file_size fpath with
| Some f -> Printf.sprintf " (%s)" @@ human_size f
| None -> ""
in
Some (li'[] [
sub_e @@ a[A.href ("/" // prefix // fpath)][txt f];
(if VFS.is_directory fpath then sub_e @@ txt "[dir]" else sub_empty);
sub_e @@ txt size;
])
Some
(li' []
[
sub_e @@ a [ A.href ("/" // prefix // fpath) ] [ txt f ];
(if VFS.is_directory fpath then
sub_e @@ txt "[dir]"
else
sub_empty);
sub_e @@ txt size;
])
)
) else None
) else
None
in
let body = body'[] [
sub_e @@ h2[][txtf "Index of %S" d];
begin match parent with
| None -> sub_empty
| Some p ->
sub_e @@
a[A.href (encode_path ("/" // prefix // p))][txt"(parent directory)"]
end;
sub_e @@ ul' [] [
if !n_hidden>0 then
sub_e @@ details'[][
sub_e @@ summary[][txtf "(%d hidden files)" !n_hidden];
sub_seq (
seq_of_array entries
|> Seq.filter_map
(fun f -> if is_hidden f then file_to_elt f else None)
);
] else sub_empty;
sub_seq (
seq_of_array entries
|> Seq.filter_map (fun f ->
if not (is_hidden f) then file_to_elt f else None)
)
];
]
let body =
body' []
[
sub_e @@ h2 [] [ txtf "Index of %S" d ];
(match parent with
| None -> sub_empty
| Some p ->
sub_e
@@ a
[ A.href (encode_path ("/" // prefix // p)) ]
[ txt "(parent directory)" ]);
sub_e
@@ ul' []
[
(if !n_hidden > 0 then
sub_e
@@ details' []
[
sub_e
@@ summary [] [ txtf "(%d hidden files)" !n_hidden ];
sub_seq
(seq_of_array entries
|> Seq.filter_map (fun f ->
if is_hidden f then
file_to_elt f
else
None));
]
else
sub_empty);
sub_seq
(seq_of_array entries
|> Seq.filter_map (fun f ->
if not (is_hidden f) then
file_to_elt f
else
None));
];
]
in
html [][head; body]
html [] [ head; body ]
let finally_ ~h x f =
try
@ -173,120 +207,135 @@ let finally_ ~h x f =
raise e
(* @param on_fs: if true, we assume the file exists on the FS *)
let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS:VFS) as vfs) ~prefix server : unit=
let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
: unit =
let route () =
if prefix="" then S.Route.rest_of_path_urlencoded
else S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
if prefix = "" then
S.Route.rest_of_path_urlencoded
else
S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
in
if config.delete then (
S.add_route_handler server ~meth:`DELETE (route())
(fun path _req ->
if contains_dot_dot path then (
S.Response.fail_raise ~code:403 "invalid path in delete"
) else (
S.Response.make_string
(try
VFS.delete path; Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e))
)
);
) else (
S.add_route_handler server ~meth:`DELETE (route())
(fun _ _ -> S.Response.make_raw ~code:405 "delete not allowed");
);
if config.delete then
S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
if contains_dot_dot path then
S.Response.fail_raise ~code:403 "invalid path in delete"
else
S.Response.make_string
(try
VFS.delete path;
Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e)))
else
S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ ->
S.Response.make_raw ~code:405 "delete not allowed");
if config.upload then (
S.add_route_handler_stream server ~meth:`PUT (route())
if config.upload then
S.add_route_handler_stream server ~meth:`PUT (route ())
~accept:(fun req ->
match S.Request.get_header_int req "Content-Length" with
| Some n when n > config.max_upload_size ->
Error (403, "max upload size is " ^ string_of_int config.max_upload_size)
| Some _ when contains_dot_dot req.S.Request.path ->
Error (403, "invalid path (contains '..')")
| _ -> Ok ()
)
match S.Request.get_header_int req "Content-Length" with
| Some n when n > config.max_upload_size ->
Error
(403, "max upload size is " ^ string_of_int config.max_upload_size)
| Some _ when contains_dot_dot req.S.Request.path ->
Error (403, "invalid path (contains '..')")
| _ -> Ok ())
(fun path req ->
let write, close =
try VFS.create path
with e ->
S.Response.fail_raise ~code:403 "cannot upload to %S: %s"
path (Printexc.to_string e)
in
let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in
Tiny_httpd_stream.iter write req.S.Request.body;
close ();
S._debug (fun k->k "done uploading");
S.Response.make_raw ~code:201 "upload successful"
)
) else (
S.add_route_handler server ~meth:`PUT (route())
(fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed");
);
let write, close =
try VFS.create path
with e ->
S.Response.fail_raise ~code:403 "cannot upload to %S: %s" path
(Printexc.to_string e)
in
let req =
S.Request.limit_body_size ~max_size:config.max_upload_size req
in
Tiny_httpd_stream.iter write req.S.Request.body;
close ();
S._debug (fun k -> k "done uploading");
S.Response.make_raw ~code:201 "upload successful")
else
S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ ->
S.Response.make_raw ~code:405 "upload not allowed");
if config.download then (
S.add_route_handler server ~meth:`GET (route())
(fun path req ->
S._debug (fun k->k "path=%S" path);
let mtime = lazy (
match VFS.file_mtime path with
| None -> S.Response.fail_raise ~code:403 "Cannot access file"
| Some t -> Printf.sprintf "mtime: %.4f" t
) in
if contains_dot_dot path then (
S.Response.fail ~code:403 "Path is forbidden";
) else if not (VFS.contains path) then (
S.Response.fail ~code:404 "File not found";
) else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then (
S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime));
S.Response.make_raw ~code:304 ""
) else if VFS.is_directory path then (
S._debug (fun k->k "list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in
let parent = if Filename.basename path <> "." then Some parent else None in
match config.dir_behavior with
| Index | Index_or_lists when VFS.contains (path // "index.html") ->
(* redirect using path, not full path *)
let new_path = "/" // prefix // path // "index.html" in
S._debug (fun k->k "redirect to `%s`" new_path);
S.Response.make_void ~code:301 ()
~headers:S.Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists ->
let body = html_list_dir ~prefix vfs path ~parent |> Html.to_string_top in
S.Response.make_string
~headers:[header_html; "ETag", Lazy.force mtime]
(Ok body)
| Forbidden | Index ->
S.Response.make_raw ~code:405 "listing dir not allowed"
) else (
try
let mime_type =
if Filename.extension path = ".css" then (
["Content-Type", "text/css"]
) else if Filename.extension path = ".js" then (
["Content-Type", "text/javascript"]
) else if on_fs then (
(* call "file" util *)
try
let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" (top // path)) in
finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p
(fun p ->
try ["Content-Type", String.trim (input_line p)]
with _ -> [])
with _ -> []
) else []
in
let stream = VFS.read_file_content path in
S.Response.make_raw_stream
~headers:(mime_type@["Etag", Lazy.force mtime])
~code:200 stream
with e ->
S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e))
)
) else (
S.add_route_handler server ~meth:`GET (route())
(fun _ _ -> S.Response.make_raw ~code:405 "download not allowed");
);
if config.download then
S.add_route_handler server ~meth:`GET (route ()) (fun path req ->
S._debug (fun k -> k "path=%S" path);
let mtime =
lazy
(match VFS.file_mtime path with
| None -> S.Response.fail_raise ~code:403 "Cannot access file"
| Some t -> Printf.sprintf "mtime: %.4f" t)
in
if contains_dot_dot path then
S.Response.fail ~code:403 "Path is forbidden"
else if not (VFS.contains path) then
S.Response.fail ~code:404 "File not found"
else if
S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime)
then (
S._debug (fun k ->
k "cached object %S (etag: %S)" path (Lazy.force mtime));
S.Response.make_raw ~code:304 ""
) else if VFS.is_directory path then (
S._debug (fun k -> k "list dir %S (topdir %S)" path VFS.descr);
let parent = Filename.(dirname path) in
let parent =
if Filename.basename path <> "." then
Some parent
else
None
in
match config.dir_behavior with
| (Index | Index_or_lists) when VFS.contains (path // "index.html") ->
(* redirect using path, not full path *)
let new_path = "/" // prefix // path // "index.html" in
S._debug (fun k -> k "redirect to `%s`" new_path);
S.Response.make_void ~code:301 ()
~headers:S.Headers.(empty |> set "location" new_path)
| Lists | Index_or_lists ->
let body =
html_list_dir ~prefix vfs path ~parent |> Html.to_string_top
in
S.Response.make_string
~headers:[ header_html; "ETag", Lazy.force mtime ]
(Ok body)
| Forbidden | Index ->
S.Response.make_raw ~code:405 "listing dir not allowed"
) else (
try
let mime_type =
if Filename.extension path = ".css" then
[ "Content-Type", "text/css" ]
else if Filename.extension path = ".js" then
[ "Content-Type", "text/javascript" ]
else if on_fs then (
(* call "file" util *)
try
let p =
Unix.open_process_in
(Printf.sprintf "file -i -b %S" (top // path))
in
finally_
~h:(fun p -> ignore @@ Unix.close_process_in p)
p
(fun p ->
try [ "Content-Type", String.trim (input_line p) ]
with _ -> [])
with _ -> []
) else
[]
in
let stream = VFS.read_file_content path in
S.Response.make_raw_stream
~headers:(mime_type @ [ "Etag", Lazy.force mtime ])
~code:200 stream
with e ->
S.Response.fail ~code:500 "error while reading file: %s"
(Printexc.to_string e)
))
else
S.add_route_handler server ~meth:`GET (route ()) (fun _ _ ->
S.Response.make_raw ~code:405 "download not allowed");
()
let add_vfs ~config ~vfs ~prefix server : unit =
@ -296,43 +345,38 @@ let add_dir_path ~config ~dir ~prefix server : unit =
add_vfs_ ~on_fs:true ~top:dir ~config ~prefix ~vfs:(vfs_of_dir dir) server
module Embedded_fs = struct
module Str_map = Map.Make(String)
module Str_map = Map.Make (String)
type t = {
mtime: float;
mutable entries: entry Str_map.t
}
type t = { mtime: float; mutable entries: entry Str_map.t }
and entry = File of { content: string; mtime: float } | Dir of t
and entry =
| File of {
content: string;
mtime: float;
}
| Dir of t
let create ?(mtime = Unix.gettimeofday ()) () : t =
{ mtime; entries = Str_map.empty }
let create ?(mtime=Unix.gettimeofday()) () : t = {
mtime;
entries=Str_map.empty;
}
let split_path_ (path:string) : string list * string =
let split_path_ (path : string) : string list * string =
let basename = Filename.basename path in
let dirname =
Filename.dirname path
|> String.split_on_char '/'
|> List.filter (function "" | "." -> false | _ -> true) in
Filename.dirname path |> String.split_on_char '/'
|> List.filter (function
| "" | "." -> false
| _ -> true)
in
dirname, basename
let add_file ?mtime (self:t) ~path content : unit =
let mtime = match mtime with Some t -> t | None -> self.mtime in
let add_file ?mtime (self : t) ~path content : unit =
let mtime =
match mtime with
| Some t -> t
| None -> self.mtime
in
let dir_path, basename = split_path_ path in
if List.mem ".." dir_path then (
invalid_arg "add_file: '..' is not allowed";
);
if List.mem ".." dir_path then invalid_arg "add_file: '..' is not allowed";
let rec loop self dir = match dir with
let rec loop self dir =
match dir with
| [] ->
self.entries <- Str_map.add basename (File {mtime; content}) self.entries
self.entries <-
Str_map.add basename (File { mtime; content }) self.entries
| d :: ds ->
let sub =
match Str_map.find d self.entries with
@ -352,49 +396,61 @@ module Embedded_fs = struct
(* find entry *)
let find_ self path : entry option =
let dir_path, basename = split_path_ path in
let rec loop self dir_name = match dir_name with
let rec loop self dir_name =
match dir_name with
| [] -> (try Some (Str_map.find basename self.entries) with _ -> None)
| d :: ds ->
match Str_map.find d self.entries with
(match Str_map.find d self.entries with
| exception Not_found -> None
| File _ -> None
| Dir sub -> loop sub ds
| Dir sub -> loop sub ds)
in
if path="" then Some (Dir self)
else loop self dir_path
if path = "" then
Some (Dir self)
else
loop self dir_path
let to_vfs self : vfs =
let module M = struct
let descr = "Embedded_fs"
let file_mtime p = match find_ self p with
| Some (File {mtime;_}) -> Some mtime
let file_mtime p =
match find_ self p with
| Some (File { mtime; _ }) -> Some mtime
| Some (Dir _) -> Some self.mtime
| _ -> None
let file_size p = match find_ self p with
| Some (File {content;_}) -> Some (String.length content)
let file_size p =
match find_ self p with
| Some (File { content; _ }) -> Some (String.length content)
| _ -> None
let contains p = S._debug (fun k->k "contains %S" p); match find_ self p with
let contains p =
S._debug (fun k -> k "contains %S" p);
match find_ self p with
| Some _ -> true
| None -> false
let is_directory p = match find_ self p with
let is_directory p =
match find_ self p with
| Some (Dir _) -> true
| _ -> false
let read_file_content p = match find_ self p with
| Some (File {content;_}) -> Tiny_httpd_stream.of_string content
let read_file_content p =
match find_ self p with
| Some (File { content; _ }) -> Tiny_httpd_stream.of_string content
| _ -> failwith (Printf.sprintf "no such file: %S" p)
let list_dir p = S._debug (fun k->k "list dir %S" p); match find_ self p with
let list_dir p =
S._debug (fun k -> k "list dir %S" p);
match find_ self p with
| Some (Dir sub) ->
Str_map.fold (fun sub _ acc -> sub::acc) sub.entries [] |> Array.of_list
Str_map.fold (fun sub _ acc -> sub :: acc) sub.entries []
|> Array.of_list
| _ -> failwith (Printf.sprintf "no such directory: %S" p)
let create _ = failwith "Embedded_fs is read-only"
let delete _ = failwith "Embedded_fs is read-only"
end in (module M)
end in
(module M)
end

53
src/Tiny_httpd_dir.mli
View file

@ -1,4 +1,3 @@
(** Serving static content from directories
This module provides the same functionality as the "http_of_dir" tool.
@ -12,44 +11,35 @@
This controls what happens when the user requests the path to
a directory rather than a file. *)
type dir_behavior =
| Index
(** Redirect to index.html if present, else fails. *)
| Index (** Redirect to index.html if present, else fails. *)
| Lists
(** Lists content of directory. Be careful of security implications. *)
(** Lists content of directory. Be careful of security implications. *)
| Index_or_lists
(** Redirect to index.html if present and lists content otherwise.
(** Redirect to index.html if present and lists content otherwise.
This is useful for tilde ("~") directories and other per-user behavior,
but be mindful of security implications *)
| Forbidden
(** Forbid access to directory. This is suited for serving assets, for example. *)
(** Forbid access to directory. This is suited for serving assets, for example. *)
type hidden
(** Type used to prevent users from building a config directly.
Use {!default_config} or {!config} instead. *)
type config = {
mutable download: bool; (** Is downloading files allowed? *)
mutable dir_behavior: dir_behavior;
(** Behavior when serving a directory and not a file *)
mutable delete: bool; (** Is deleting a file allowed? (with method DELETE) *)
mutable upload: bool; (** Is uploading a file allowed? (with method PUT) *)
mutable max_upload_size: int;
(** If {!upload} is true, this is the maximum size in bytes for
uploaded files. *)
_rest: hidden; (** Just ignore this field. *)
}
(** configuration for static file handlers. This might get
more fields over time. *)
type config = {
mutable download: bool;
(** Is downloading files allowed? *)
mutable dir_behavior: dir_behavior;
(** Behavior when serving a directory and not a file *)
mutable delete: bool;
(** Is deleting a file allowed? (with method DELETE) *)
mutable upload: bool;
(** Is uploading a file allowed? (with method PUT) *)
mutable max_upload_size: int;
(** If {!upload} is true, this is the maximum size in bytes for
uploaded files. *)
_rest: hidden;
(** Just ignore this field. *)
}
val default_config : unit -> config
(** default configuration: [
{ download=true
; dir_behavior=Forbidden
@ -57,7 +47,6 @@ type config = {
; upload=false
; max_upload_size = 10 * 1024 * 1024
}] *)
val default_config : unit -> config
val config :
?download:bool ->
@ -70,14 +59,11 @@ val config :
(** Build a config from {!default_config}.
@since 0.12 *)
val add_dir_path :
config:config -> dir:string -> prefix:string -> Tiny_httpd_server.t -> unit
(** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
[server] to serve static files in [dir] when url starts with [prefix],
using the given configuration [config]. *)
val add_dir_path :
config:config ->
dir:string ->
prefix:string ->
Tiny_httpd_server.t -> unit
(** Virtual file system.
@ -125,7 +111,8 @@ val add_vfs :
config:config ->
vfs:(module VFS) ->
prefix:string ->
Tiny_httpd_server.t -> unit
Tiny_httpd_server.t ->
unit
(** Similar to {!add_dir_path} but using a virtual file system instead.
@since 0.12
*)

15
src/Tiny_httpd_html.ml
View file

@ -1,4 +1,3 @@
(** HTML combinators.
This module provides combinators to produce html. It doesn't enforce
@ -7,13 +6,13 @@
@since 0.12
*)
(** @inline *)
include Tiny_httpd_html_
(** @inline *)
(** Convert a HTML element to a string.
@param top if true, add DOCTYPE at the beginning. The top element should then
be a "html" tag. *)
let to_string ?(top=false) (self:elt) : string =
let to_string ?(top = false) (self : elt) : string =
let out = Out.create () in
if top then Out.add_string out "<!DOCTYPE html>\n";
self out;
@ -23,14 +22,18 @@ let to_string ?(top=false) (self:elt) : string =
This is designed for fragments of HTML that are to be injected inside
a bigger context, as it's invalid to have multiple elements at the toplevel
of a HTML document. *)
let to_string_l (l:elt list) =
let to_string_l (l : elt list) =
let out = Out.create () in
List.iter (fun f -> f out; Out.add_format_nl out) l;
List.iter
(fun f ->
f out;
Out.add_format_nl out)
l;
Out.to_string out
let to_string_top = to_string ~top:true
(** Convert a HTML element to a stream. This might just convert
it to a string first, do not assume it to be more efficient. *)
let to_stream (self:elt) : Tiny_httpd_stream.t =
let to_stream (self : elt) : Tiny_httpd_stream.t =
Tiny_httpd_stream.of_string @@ to_string self

842
src/Tiny_httpd_server.ml
View file

File diff suppressed because it is too large Load diff

102
src/Tiny_httpd_server.mli
View file

@ -1,4 +1,3 @@
(** HTTP server.
This module implements a very simple, basic HTTP/1.1 server using blocking
@ -15,14 +14,7 @@ type byte_stream = Tiny_httpd_stream.t
(** {2 Methods} *)
module Meth : sig
type t = [
| `GET
| `PUT
| `POST
| `HEAD
| `DELETE
| `OPTIONS
]
type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ]
(** A HTTP method.
For now we only handle a subset of these.
@ -47,7 +39,7 @@ module Headers : sig
(** Empty list of headers
@since 0.5 *)
val get : ?f:(string->string) -> string -> t -> string option
val get : ?f:(string -> string) -> string -> t -> string option
(** [get k headers] looks for the header field with key [k].
@param f if provided, will transform the value before it is returned. *)
@ -74,13 +66,13 @@ module Request : sig
meth: Meth.t;
host: string;
headers: Headers.t;
http_version: int*int;
http_version: int * int;
path: string;
path_components: string list;
query: (string*string) list;
query: (string * string) list;
body: 'body;
start_time: float;
(** Obtained via [get_time_s] in {!create}
(** Obtained via [get_time_s] in {!create}
@since 0.11 *)
}
(** A request with method, path, host, headers, and a body, sent by a client.
@ -105,8 +97,7 @@ module Request : sig
val headers : _ t -> Headers.t
(** List of headers of the request, including ["Host"] *)
val get_header : ?f:(string->string) -> _ t -> string -> string option
val get_header : ?f:(string -> string) -> _ t -> string -> string option
val get_header_int : _ t -> string -> int option
val set_header : string -> string -> 'a t -> 'a t
@ -129,7 +120,7 @@ module Request : sig
val path : _ t -> string
(** Request path. *)
val query : _ t -> (string*string) list
val query : _ t -> (string * string) list
(** Decode the query part of the {!path} field
@since 0.4 *)
@ -152,11 +143,15 @@ module Request : sig
@param buf_size initial size of underlying buffer (since 0.11) *)
(**/**)
(* for testing purpose, do not use *)
module Internal_ : sig
val parse_req_start : ?buf:buf -> get_time_s:(unit -> float) -> byte_stream -> unit t option
val parse_req_start :
?buf:buf -> get_time_s:(unit -> float) -> byte_stream -> unit t option
val parse_body : ?buf:buf -> unit t -> byte_stream -> byte_stream t
end
(**/**)
end
@ -185,14 +180,15 @@ end
the client to answer a {!Request.t}*)
module Response : sig
type body = [`String of string | `Stream of byte_stream | `Void]
type body = [ `String of string | `Stream of byte_stream | `Void ]
(** Body of a response, either as a simple string,
or a stream of bytes, or nothing (for server-sent events). *)
type t = private {
code: Response_code.t; (** HTTP response code. See {!Response_code}. *)
headers: Headers.t; (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
body: body; (** Body of the response. Can be empty. *)
code: Response_code.t; (** HTTP response code. See {!Response_code}. *)
headers: Headers.t;
(** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *)
body: body; (** Body of the response. Can be empty. *)
}
(** A response to send back to a client. *)
@ -216,19 +212,12 @@ module Response : sig
(** Set the response code.
@since 0.11 *)
val make_raw :
?headers:Headers.t ->
code:Response_code.t ->
string ->
t
val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t
(** Make a response from its raw components, with a string body.
Use [""] to not send a body at all. *)
val make_raw_stream :
?headers:Headers.t ->
code:Response_code.t ->
byte_stream ->
t
?headers:Headers.t -> code:Response_code.t -> byte_stream -> t
(** Same as {!make_raw} but with a stream body. The body will be sent with
the chunked transfer-encoding. *)
@ -236,9 +225,7 @@ module Response : sig
(** Return a response without a body at all.
@since NEXT_RELEASE *)
val make :
?headers:Headers.t ->
(body, Response_code.t * string) result -> t
val make : ?headers:Headers.t -> (body, Response_code.t * string) result -> t
(** [make r] turns a result into a response.
- [make (Ok body)] replies with [200] and the body.
@ -247,17 +234,15 @@ module Response : sig
*)
val make_string :
?headers:Headers.t ->
(string, Response_code.t * string) result -> t
?headers:Headers.t -> (string, Response_code.t * string) result -> t
(** Same as {!make} but with a string body. *)
val make_stream :
?headers:Headers.t ->
(byte_stream, Response_code.t * string) result -> t
?headers:Headers.t -> (byte_stream, Response_code.t * string) result -> t
(** Same as {!make} but with a stream body. *)
val fail : ?headers:Headers.t -> code:int ->
('a, unit, string, t) format4 -> 'a
val fail :
?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a
(** Make the current request fail with the given code and message.
Example: [fail ~code:404 "oh noes, %s not found" "waldo"].
*)
@ -308,11 +293,11 @@ module Route : sig
This will match the entirety of the remaining route.
@since 0.7 *)
val (@/) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
and [route] matches ["bar/…"]. *)
val exact_path : string -> ('a,'b) t -> ('a,'b) t
val exact_path : string -> ('a, 'b) t -> ('a, 'b) t
(** [exact_path "foo/bar/..." r] is equivalent to
[exact "foo" @/ exact "bar" @/ ... @/ r]
@since 0.11 **)
@ -366,7 +351,7 @@ val create :
?addr:string ->
?port:int ->
?sock:Unix.file_descr ->
?middlewares:([`Encoding | `Stage of int] * Middleware.t) list ->
?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list ->
unit ->
t
(** Create a new webserver.
@ -416,8 +401,9 @@ val active_connections : t -> int
val add_decode_request_cb :
t ->
(unit Request.t -> (unit Request.t * (byte_stream -> byte_stream)) option) -> unit
[@@deprecated "use add_middleware"]
(unit Request.t -> (unit Request.t * (byte_stream -> byte_stream)) option) ->
unit
[@@deprecated "use add_middleware"]
(** Add a callback for every request.
The callback can provide a stream transformer and a new request (with
modified headers, typically).
@ -427,9 +413,9 @@ val add_decode_request_cb :
@deprecated use {!add_middleware} instead
*)
val add_encode_response_cb:
val add_encode_response_cb :
t -> (unit Request.t -> Response.t -> Response.t option) -> unit
[@@deprecated "use add_middleware"]
[@@deprecated "use add_middleware"]
(** Add a callback for every request/response pair.
Similarly to {!add_encode_response_cb} the callback can return a new
response, for example to compress it.
@ -440,8 +426,7 @@ val add_encode_response_cb:
*)
val add_middleware :
stage:[`Encoding | `Stage of int] ->
t -> Middleware.t -> unit
stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit
(** Add a middleware to every request/response pair.
@param stage specify when middleware applies.
Encoding comes first (outermost layer), then stages in increasing order.
@ -463,7 +448,8 @@ val add_route_handler :
?middlewares:Middleware.t list ->
?meth:Meth.t ->
t ->
('a, string Request.t -> Response.t) Route.t -> 'a ->
('a, string Request.t -> Response.t) Route.t ->
'a ->
unit
(** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f]
calls [f "foo" 42 request] when a [request] with path "path/foo/42/"
@ -489,7 +475,8 @@ val add_route_handler_stream :
?middlewares:Middleware.t list ->
?meth:Meth.t ->
t ->
('a, byte_stream Request.t -> Response.t) Route.t -> 'a ->
('a, byte_stream Request.t -> Response.t) Route.t ->
'a ->
unit
(** Similar to {!add_route_handler}, but where the body of the request
is a stream of bytes that has not been read yet.
@ -517,11 +504,7 @@ module type SERVER_SENT_GENERATOR = sig
already sent too). *)
val send_event :
?event:string ->
?id:string ->
?retry:string ->
data:string ->
unit -> unit
?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit
(** Send an event from the server.
If data is a multiline string, it will be sent on separate "data:" lines. *)
@ -537,7 +520,8 @@ type server_sent_generator = (module SERVER_SENT_GENERATOR)
val add_route_server_sent_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
t ->
('a, string Request.t -> server_sent_generator -> unit) Route.t -> 'a ->
('a, string Request.t -> server_sent_generator -> unit) Route.t ->
'a ->
unit
(** Add a handler on an endpoint, that serves server-sent events.
@ -568,7 +552,9 @@ val run : t -> (unit, exn) result
(**/**)
val _debug : ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit
val _enable_debug: bool -> unit
val _debug :
((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit
val _enable_debug : bool -> unit
(**/**)

338
src/Tiny_httpd_stream.ml
View file

@ -1,98 +1,96 @@
module Buf = Tiny_httpd_buf
let spf = Printf.sprintf
type hidden = unit
type t = {
mutable bs: bytes;
mutable off : int;
mutable len : int;
mutable off: int;
mutable len: int;
fill_buf: unit -> unit;
consume: int -> unit;
close: unit -> unit;
_rest: hidden;
}
let[@inline] close self = self.close()
let[@inline] close self = self.close ()
let empty = {
bs=Bytes.empty;
off=0;
len=0;
fill_buf=ignore;
consume=ignore;
close=ignore;
_rest=();
}
let empty =
{
bs = Bytes.empty;
off = 0;
len = 0;
fill_buf = ignore;
consume = ignore;
close = ignore;
_rest = ();
}
let make ?(bs=Bytes.create @@ 16 * 1024) ?(close=ignore) ~consume ~fill () : t =
let rec self = {
bs;
off=0;
len=0;
close=(fun () -> close self);
fill_buf=(fun () ->
if self.len = 0 then fill self);
consume=
(fun n ->
assert (n <= self.len);
consume self n
);
_rest=();
} in
let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill ()
: t =
let rec self =
{
bs;
off = 0;
len = 0;
close = (fun () -> close self);
fill_buf = (fun () -> if self.len = 0 then fill self);
consume =
(fun n ->
assert (n <= self.len);
consume self n);
_rest = ();
}
in
self
let of_chan_ ?(buf_size=16 * 1024) ~close ic : t =
make
~bs:(Bytes.create buf_size)
let of_chan_ ?(buf_size = 16 * 1024) ~close ic : t =
make ~bs:(Bytes.create buf_size)
~close:(fun _ -> close ic)
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n)
self.off <- self.off + n;
self.len <- self.len - n)
~fill:(fun self ->
if self.off >= self.len then (
self.off <- 0;
self.len <- input ic self.bs 0 (Bytes.length self.bs);
)
)
if self.off >= self.len then (
self.off <- 0;
self.len <- input ic self.bs 0 (Bytes.length self.bs)
))
()
let of_chan = of_chan_ ~close:close_in
let of_chan_close_noerr = of_chan_ ~close:close_in_noerr
let of_fd_ ?(buf_size=16 * 1024) ~close ic : t =
make
~bs:(Bytes.create buf_size)
let of_fd_ ?(buf_size = 16 * 1024) ~close ic : t =
make ~bs:(Bytes.create buf_size)
~close:(fun _ -> close ic)
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n)
self.off <- self.off + n;
self.len <- self.len - n)
~fill:(fun self ->
if self.off >= self.len then (
self.off <- 0;
self.len <- Unix.read ic self.bs 0 (Bytes.length self.bs);
)
)
if self.off >= self.len then (
self.off <- 0;
self.len <- Unix.read ic self.bs 0 (Bytes.length self.bs)
))
()
let of_fd = of_fd_ ~close:Unix.close
let of_fd_close_noerr = of_fd_ ~close:(fun f -> try Unix.close f with _ -> ())
let rec iter f (self:t) : unit =
self.fill_buf();
if self.len=0 then (
self.close();
) else (
let rec iter f (self : t) : unit =
self.fill_buf ();
if self.len = 0 then
self.close ()
else (
f self.bs self.off self.len;
self.consume self.len;
(iter [@tailcall]) f self
)
let to_chan (oc:out_channel) (self:t) =
let to_chan (oc : out_channel) (self : t) =
iter (fun s i len -> output oc s i len) self
let of_bytes ?(i=0) ?len (bs:bytes) : t =
let of_bytes ?(i = 0) ?len (bs : bytes) : t =
(* invariant: !i+!len is constant *)
let len =
match len with
@ -102,25 +100,22 @@ let of_bytes ?(i=0) ?len (bs:bytes) : t =
| None -> Bytes.length bs - i
in
let self =
make
~bs ~fill:ignore
make ~bs ~fill:ignore
~close:(fun self -> self.len <- 0)
~consume:(fun self n ->
assert (n>=0 && n<= self.len);
self.off <- n + self.off;
self.len <- self.len - n
)
assert (n >= 0 && n <= self.len);
self.off <- n + self.off;
self.len <- self.len - n)
()
in
self.off <- i;
self.len <- len;
self
let of_string s : t =
of_bytes (Bytes.unsafe_of_string s)
let of_string s : t = of_bytes (Bytes.unsafe_of_string s)
let with_file ?buf_size file f =
let ic = Unix.(openfile file [O_RDONLY] 0) in
let ic = Unix.(openfile file [ O_RDONLY ] 0) in
try
let x = f (of_fd ?buf_size ic) in
Unix.close ic;
@ -129,152 +124,148 @@ let with_file ?buf_size file f =
Unix.close ic;
raise e
let read_all ?(buf=Buf.create()) (self:t) : string =
let read_all ?(buf = Buf.create ()) (self : t) : string =
let continue = ref true in
while !continue do
self.fill_buf();
self.fill_buf ();
if self.len > 0 then (
Buf.add_bytes buf self.bs self.off self.len;
self.consume self.len;
self.consume self.len
);
assert (self.len >= 0);
if self.len = 0 then (
continue := false
)
if self.len = 0 then continue := false
done;
Buf.contents_and_clear buf
(* put [n] bytes from the input into bytes *)
let read_exactly_ ~too_short (self:t) (bytes:bytes) (n:int) : unit =
let read_exactly_ ~too_short (self : t) (bytes : bytes) (n : int) : unit =
assert (Bytes.length bytes >= n);
let offset = ref 0 in
while !offset < n do
self.fill_buf();
self.fill_buf ();
let n_read = min self.len (n - !offset) in
Bytes.blit self.bs self.off bytes !offset n_read;
offset := !offset + n_read;
self.consume n_read;
if n_read=0 then too_short();
if n_read = 0 then too_short ()
done
(* read a line into the buffer, after clearing it. *)
let read_line_into (self:t) ~buf : unit =
let read_line_into (self : t) ~buf : unit =
Buf.clear buf;
let continue = ref true in
while !continue do
self.fill_buf();
if self.len=0 then (
self.fill_buf ();
if self.len = 0 then (
continue := false;
if Buf.size buf = 0 then raise End_of_file;
if Buf.size buf = 0 then raise End_of_file
);
let j = ref self.off in
while !j < self.off + self.len && Bytes.get self.bs !j <> '\n' do
incr j
done;
if !j-self.off < self.len then (
if !j - self.off < self.len then (
assert (Bytes.get self.bs !j = '\n');
Buf.add_bytes buf self.bs self.off (!j-self.off); (* without \n *)
self.consume (!j-self.off+1); (* remove \n *)
Buf.add_bytes buf self.bs self.off (!j - self.off);
(* without \n *)
self.consume (!j - self.off + 1);
(* remove \n *)
continue := false
) else (
Buf.add_bytes buf self.bs self.off self.len;
self.consume self.len;
self.consume self.len
)
done
(* new stream with maximum size [max_size].
@param close_rec if true, closing this will also close the input stream
@param too_big called with read size if the max size is reached *)
let limit_size_to ~close_rec ~max_size ~too_big (arg:t) : t =
let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t =
let size = ref 0 in
let continue = ref true in
make
~bs:Bytes.empty
~close:(fun _ ->
if close_rec then arg.close ())
make ~bs:Bytes.empty
~close:(fun _ -> if close_rec then arg.close ())
~fill:(fun res ->
if res.len = 0 && !continue then (
arg.fill_buf();
res.bs <- arg.bs;
res.off <- arg.off;
res.len <- arg.len;
) else (
arg.bs <- Bytes.empty;
arg.off <- 0;
arg.len <- 0;
)
)
if res.len = 0 && !continue then (
arg.fill_buf ();
res.bs <- arg.bs;
res.off <- arg.off;
res.len <- arg.len
) else (
arg.bs <- Bytes.empty;
arg.off <- 0;
arg.len <- 0
))
~consume:(fun res n ->
size := !size + n;
if !size > max_size then (
continue := false;
too_big !size
) else (
arg.consume n;
res.off <- res.off + n;
res.len <- res.len - n;
))
size := !size + n;
if !size > max_size then (
continue := false;
too_big !size
) else (
arg.consume n;
res.off <- res.off + n;
res.len <- res.len - n
))
()
(* read exactly [size] bytes from the stream *)
let read_exactly ~close_rec ~size ~too_short (arg:t) : t =
if size=0 then (
let read_exactly ~close_rec ~size ~too_short (arg : t) : t =
if size = 0 then
empty
) else (
else (
let size = ref size in
make ~bs:Bytes.empty
~fill:(fun res ->
(* must not block on [arg] if we're done *)
if !size = 0 then (
res.bs <- Bytes.empty;
res.off <- 0;
res.len <- 0;
) else (
arg.fill_buf();
res.bs <- arg.bs;
res.off <- arg.off;
let len = min arg.len !size in
if len = 0 && !size > 0 then (
too_short !size;
);
res.len <- len;
))
(* must not block on [arg] if we're done *)
if !size = 0 then (
res.bs <- Bytes.empty;
res.off <- 0;
res.len <- 0
) else (
arg.fill_buf ();
res.bs <- arg.bs;
res.off <- arg.off;
let len = min arg.len !size in
if len = 0 && !size > 0 then too_short !size;
res.len <- len
))
~close:(fun _res ->
(* close underlying stream if [close_rec] *)
if close_rec then arg.close();
size := 0
)
(* close underlying stream if [close_rec] *)
if close_rec then arg.close ();
size := 0)
~consume:(fun res n ->
let n = min n !size in
size := !size - n;
arg.consume n;
res.off <- res.off + n;
res.len <- res.len - n;
)
let n = min n !size in
size := !size - n;
arg.consume n;
res.off <- res.off + n;
res.len <- res.len - n)
()
)
let read_line ?(buf=Buf.create()) self : string =
let read_line ?(buf = Buf.create ()) self : string =
read_line_into self ~buf;
Buf.contents buf
let read_chunked ?(buf=Buf.create()) ~fail (bs:t) : t=
let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t =
let first = ref true in
let read_next_chunk_len () : int =
if !first then (
if !first then
first := false
) else (
else (
let line = read_line ~buf bs in
if String.trim line <> "" then raise (fail "expected crlf between chunks";)
if String.trim line <> "" then raise (fail "expected crlf between chunks")
);
let line = read_line ~buf bs in
(* parse chunk length, ignore extensions *)
let chunk_size = (
if String.trim line = "" then 0
else
let chunk_size =
if String.trim line = "" then
0
else (
try Scanf.sscanf line "%x %s@\r" (fun n _ext -> n)
with _ -> raise (fail (spf "cannot read chunk size from line %S" line))
) in
with _ ->
raise (fail (spf "cannot read chunk size from line %S" line))
)
in
chunk_size
in
let refill = ref true in
@ -282,50 +273,43 @@ let read_chunked ?(buf=Buf.create()) ~fail (bs:t) : t=
make
~bs:(Bytes.create (16 * 4096))
~fill:(fun self ->
(* do we need to refill? *)
if self.off >= self.len then (
if !chunk_size = 0 && !refill then (
chunk_size := read_next_chunk_len();
);
self.off <- 0;
self.len <- 0;
if !chunk_size > 0 then (
(* read the whole chunk, or [Bytes.length bytes] of it *)
let to_read = min !chunk_size (Bytes.length self.bs) in
read_exactly_
~too_short:(fun () -> raise (fail "chunk is too short"))
bs self.bs to_read;
self.len <- to_read;
chunk_size := !chunk_size - to_read;
) else (
refill := false; (* stream is finished *)
)
);
)
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n)
~close:(fun self ->
(* close this overlay, do not close underlying stream *)
(* do we need to refill? *)
if self.off >= self.len then (
if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len ();
self.off <- 0;
self.len <- 0;
refill:= false
)
if !chunk_size > 0 then (
(* read the whole chunk, or [Bytes.length bytes] of it *)
let to_read = min !chunk_size (Bytes.length self.bs) in
read_exactly_
~too_short:(fun () -> raise (fail "chunk is too short"))
bs self.bs to_read;
self.len <- to_read;
chunk_size := !chunk_size - to_read
) else
refill := false (* stream is finished *)
))
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n)
~close:(fun self ->
(* close this overlay, do not close underlying stream *)
self.len <- 0;
refill := false)
()
(* print a stream as a series of chunks *)
let output_chunked (oc:out_channel) (self:t) : unit =
let output_chunked (oc : out_channel) (self : t) : unit =
let continue = ref true in
while !continue do
(* next chunk *)
self.fill_buf();
self.fill_buf ();
let n = self.len in
Printf.fprintf oc "%x\r\n" n;
output oc self.bs self.off n;
self.consume n;
if n = 0 then (
continue := false;
);
output_string oc "\r\n";
if n = 0 then continue := false;
output_string oc "\r\n"
done;
(* write another crlf after the stream (see #56) *)
output_string oc "\r\n";

43
src/Tiny_httpd_stream.mli
View file

@ -1,4 +1,3 @@
(** Byte streams.
These used to live in {!Tiny_httpd} but are now in their own module.
@ -8,31 +7,21 @@ type hidden
(** Type used to make {!t} unbuildable via a record literal. Use {!make} instead. *)
type t = {
mutable bs: bytes;
(** The bytes *)
mutable off : int;
(** Beginning of valid slice in {!bs} *)
mutable len : int;
(** Length of valid slice in {!bs}. If [len = 0] after
mutable bs: bytes; (** The bytes *)
mutable off: int; (** Beginning of valid slice in {!bs} *)
mutable len: int;
(** Length of valid slice in {!bs}. If [len = 0] after
a call to {!fill}, then the stream is finished. *)
fill_buf: unit -> unit;
(** See the current slice of the internal buffer as [bytes, i, len],
(** See the current slice of the internal buffer as [bytes, i, len],
where the slice is [bytes[i] .. [bytes[i+len-1]]].
Can block to refill the buffer if there is currently no content.
If [len=0] then there is no more data. *)
consume: int -> unit;
(** Consume [n] bytes from the buffer.
(** Consume [n] bytes from the buffer.
This should only be called with [n <= len]. *)
close: unit -> unit;
(** Close the stream. *)
_rest: hidden;
(** Use {!make} to build a stream. *)
close: unit -> unit; (** Close the stream. *)
_rest: hidden; (** Use {!make} to build a stream. *)
}
(** A buffered stream, with a view into the current buffer (or refill if empty),
and a function to consume [n] bytes.
@ -75,7 +64,8 @@ val make :
?close:(t -> unit) ->
consume:(t -> int -> unit) ->
fill:(t -> unit) ->
unit -> t
unit ->
t
(** [make ~fill ()] creates a byte stream.
@param fill is used to refill the buffer, and is called initially.
@param close optional closing.
@ -95,18 +85,12 @@ val read_all : ?buf:Tiny_httpd_buf.t -> t -> string
@param buf a buffer to (re)use. Its content will be cleared. *)
val limit_size_to :
close_rec:bool ->
max_size:int ->
too_big:(int -> unit) ->
t -> t
close_rec:bool -> max_size:int -> too_big:(int -> unit) -> t -> t
(* New stream with maximum size [max_size].
@param close_rec if true, closing this will also close the input stream
@param too_big called with read size if the max size is reached *)
val read_chunked :
?buf:Tiny_httpd_buf.t ->
fail:(string -> exn) ->
t -> t
val read_chunked : ?buf:Tiny_httpd_buf.t -> fail:(string -> exn) -> t -> t
(** Convert a stream into a stream of byte chunks using
the chunked encoding. The size of chunks is not specified.
@param buf buffer used for intermediate storage.
@ -114,8 +98,7 @@ val read_chunked :
*)
val read_exactly :
close_rec:bool -> size:int -> too_short:(int -> unit) ->
t -> t
close_rec:bool -> size:int -> too_short:(int -> unit) -> t -> t
(** [read_exactly ~size bs] returns a new stream that reads exactly
[size] bytes from [bs], and then closes.
@param close_rec if true, closing the resulting stream also closes

81
src/Tiny_httpd_util.ml
View file

@ -1,4 +1,3 @@
(* test utils *)
(*$inject
let pp_res f = function Ok x -> f x | Error e -> e
@ -9,17 +8,15 @@
let is_ascii_char c = Char.code c < 128
*)
let percent_encode ?(skip=fun _->false) s =
let percent_encode ?(skip = fun _ -> false) s =
let buf = Buffer.create (String.length s) in
String.iter
(function
| c when skip c -> Buffer.add_char buf c
| (' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+'
| ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~')
as c ->
Printf.bprintf buf "%%%X" (Char.code c)
| c when Char.code c > 127 ->
| ( ' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+'
| ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~' ) as c ->
Printf.bprintf buf "%%%X" (Char.code c)
| c when Char.code c > 127 -> Printf.bprintf buf "%%%X" (Char.code c)
| c -> Buffer.add_char buf c)
s;
Buffer.contents buf
@ -34,26 +31,28 @@ let percent_encode ?(skip=fun _->false) s =
(Some "?") (percent_decode @@ percent_encode "?")
*)
let hex_int (s:string) : int = Scanf.sscanf s "%x" (fun x->x)
let hex_int (s : string) : int = Scanf.sscanf s "%x" (fun x -> x)
let percent_decode (s:string) : _ option =
let percent_decode (s : string) : _ option =
let buf = Buffer.create (String.length s) in
let i = ref 0 in
try
while !i < String.length s do
match String.get s !i with
| '%' ->
if !i+2 < String.length s then (
begin match hex_int @@ String.sub s (!i+1) 2 with
| n -> Buffer.add_char buf (Char.chr n)
| exception _ -> raise Exit
end;
i := !i + 3;
) else (
if !i + 2 < String.length s then (
(match hex_int @@ String.sub s (!i + 1) 2 with
| n -> Buffer.add_char buf (Char.chr n)
| exception _ -> raise Exit);
i := !i + 3
) else
raise Exit (* truncated *)
)
| '+' -> Buffer.add_char buf ' '; incr i (* for query strings *)
| c -> Buffer.add_char buf c; incr i
| '+' ->
Buffer.add_char buf ' ';
incr i (* for query strings *)
| c ->
Buffer.add_char buf c;
incr i
done;
Some (Buffer.contents buf)
with Exit -> None
@ -77,7 +76,7 @@ let get_non_query_path s =
let get_query s : string =
match find_q_index_ s with
| i -> String.sub s (i+1) (String.length s-i-1)
| i -> String.sub s (i + 1) (String.length s - i - 1)
| exception Not_found -> ""
let split_query s = get_non_query_path s, get_query s
@ -89,16 +88,11 @@ let split_on_slash s : _ list =
while !i < n do
match String.index_from s !i '/' with
| exception Not_found ->
if !i < n then (
(* last component *)
l := String.sub s !i (n - !i) :: !l;
);
if !i < n then (* last component *) l := String.sub s !i (n - !i) :: !l;
i := n (* done *)
| j ->
if j > !i then (
l := String.sub s !i (j - !i) :: !l;
);
i := j+1;
if j > !i then l := String.sub s !i (j - !i) :: !l;
i := j + 1
done;
List.rev !l
@ -112,31 +106,38 @@ let split_on_slash s : _ list =
[] (split_on_slash "//")
*)
let parse_query s : (_ list, string) result=
let parse_query s : (_ list, string) result =
let pairs = ref [] in
let is_sep_ = function '&' | ';' -> true | _ -> false in
let is_sep_ = function
| '&' | ';' -> true
| _ -> false
in
let i = ref 0 in
let j = ref 0 in
try
let percent_decode s =
match percent_decode s with Some x -> x | None -> raise Invalid_query
match percent_decode s with
| Some x -> x
| None -> raise Invalid_query
in
let parse_pair () =
let eq = String.index_from s !i '=' in
let k = percent_decode @@ String.sub s !i (eq- !i) in
let v = percent_decode @@ String.sub s (eq+1) (!j-eq-1) in
pairs := (k,v) :: !pairs;
let k = percent_decode @@ String.sub s !i (eq - !i) in
let v = percent_decode @@ String.sub s (eq + 1) (!j - eq - 1) in
pairs := (k, v) :: !pairs
in
while !i < String.length s do
while !j < String.length s && not (is_sep_ (String.get s !j)) do incr j done;
while !j < String.length s && not (is_sep_ (String.get s !j)) do
incr j
done;
if !j < String.length s then (
assert (is_sep_ (String.get s !j));
parse_pair();
i := !j+1;
j := !i;
parse_pair ();
i := !j + 1;
j := !i
) else (
parse_pair();
i := String.length s; (* done *)
parse_pair ();
i := String.length s (* done *)
)
done;
Ok !pairs

2
src/Tiny_httpd_util.mli
View file

@ -29,7 +29,7 @@ val get_query : string -> string
(** Obtain the query part of a path.
@since 0.4 *)
val parse_query : string -> ((string*string) list, string) result
val parse_query : string -> ((string * string) list, string) result
(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs.
The order might not be preserved.
@since 0.3

167
src/bin/curly.ml
View file

@ -1,11 +1,12 @@
module Result = struct
include Result
let (>>=)
: type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result
= fun r f ->
match r with
| Ok x -> f x
| (Error _) as e -> e
let ( >>= ) :
type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result =
fun r f ->
match r with
| Ok x -> f x
| Error _ as e -> e
end
open Result
@ -21,8 +22,7 @@ module Meth = struct
| `TRACE
| `CONNECT
| `PATCH
| `Other of string
]
| `Other of string ]
let to_string = function
| `GET -> "GET"
@ -46,44 +46,31 @@ module Header = struct
let to_cmd t =
t
|> List.map (fun (k, v) -> ["-H"; Printf.sprintf "%s: %s" k v])
|> List.map (fun (k, v) -> [ "-H"; Printf.sprintf "%s: %s" k v ])
|> List.concat
let pp fmt t =
Format.pp_print_list
~pp_sep:Format.pp_print_newline
(fun fmt (k ,v) -> Format.fprintf fmt "%s: %s\n" k v)
Format.pp_print_list ~pp_sep:Format.pp_print_newline
(fun fmt (k, v) -> Format.fprintf fmt "%s: %s\n" k v)
fmt t
end
module Response = struct
type t = Http.response =
{ code: int
; headers: Header.t
; body: string
}
type t = Http.response = { code: int; headers: Header.t; body: string }
let default =
{ code = 0
; headers = []
; body = "" }
let default = { code = 0; headers = []; body = "" }
let of_stdout s =
let lexbuf = Lexing.from_string s in
try Ok (Http.response default lexbuf)
with e -> Error e
try Ok (Http.response default lexbuf) with e -> Error e
let pp fmt t =
Format.fprintf fmt "{code=%d;@ headers=%a;@ body=\"%s\"}"
t.code Header.pp t.headers t.body
Format.fprintf fmt "{code=%d;@ headers=%a;@ body=\"%s\"}" t.code Header.pp
t.headers t.body
end
module Process_result = struct
type t =
{ status: Unix.process_status
; stderr: string
; stdout: string
}
type t = { status: Unix.process_status; stderr: string; stdout: string }
let pp_process_status fmt = function
| Unix.WEXITED n -> Format.fprintf fmt "Exit code %d" n
@ -107,118 +94,102 @@ module Error = struct
Format.fprintf fmt "Non 0 exit code %a@.%a"
Process_result.pp_process_status p.Process_result.status
Process_result.pp p
| Failed_to_read_response (e, _) ->
| Failed_to_read_response (e, _) ->
Format.fprintf fmt "Couldn't read response:@ %s" (Printexc.to_string e)
| Invalid_request r -> Format.fprintf fmt "Invalid request: %s" r
| Exn e -> Format.fprintf fmt "Exception: %s" (Printexc.to_string e)
end
module Request = struct
type t =
{ meth: Meth.t
; url: string
; headers: Header.t
; body: string
}
type t = { meth: Meth.t; url: string; headers: Header.t; body: string }
let make ?(headers=Header.empty) ?(body="") ~url ~meth () =
{ meth
; url
; headers
; body }
let make ?(headers = Header.empty) ?(body = "") ~url ~meth () =
{ meth; url; headers; body }
let has_body t = String.length t.body > 0
let validate t =
if has_body t && List.mem t.meth [`GET; `HEAD] then
if has_body t && List.mem t.meth [ `GET; `HEAD ] then
Error (Error.Invalid_request "No body is allowed with GET/HEAD methods")
else
Ok t
let to_cmd_args t =
List.concat
[ ["-X"; Meth.to_string t.meth]
; Header.to_cmd t.headers
; [t.url]
; (if has_body t then
["--data-binary"; "@-"]
else
[])
[
[ "-X"; Meth.to_string t.meth ];
Header.to_cmd t.headers;
[ t.url ];
(if has_body t then
[ "--data-binary"; "@-" ]
else
[]);
]
let pp fmt t =
Format.fprintf fmt
"{@ meth=%a;@ url=\"%s\";@ headers=\"%a\";@ body=\"%s\"@ }"
Meth.pp t.meth t.url Header.pp t.headers t.body
"{@ meth=%a;@ url=\"%s\";@ headers=\"%a\";@ body=\"%s\"@ }" Meth.pp t.meth
t.url Header.pp t.headers t.body
end
let result_of_process_result t =
match t.Process_result.status with
| Unix.WEXITED 0 -> Ok t
| _ -> Error (Error.Bad_exit t)
| _ -> Error (Error.Bad_exit t)
let run prog args stdin_str =
let (stdout, stdin, stderr) =
let prog =
prog :: (List.map Filename.quote args)
|> String.concat " " in
Unix.open_process_full prog [||] in
if String.length stdin_str > 0 then (
output_string stdin stdin_str
);
begin
try close_out stdin;
with _ -> ()
end;
let stdout, stdin, stderr =
let prog = prog :: List.map Filename.quote args |> String.concat " " in
Unix.open_process_full prog [||]
in
if String.length stdin_str > 0 then output_string stdin stdin_str;
(try close_out stdin with _ -> ());
let stdout_fd = Unix.descr_of_in_channel stdout in
let stderr_fd = Unix.descr_of_in_channel stderr in
let (in_buf, err_buf) = Buffer.(create 128, create 128) in
let in_buf, err_buf = Buffer.(create 128, create 128) in
let read_buf_len = 512 in
let read_buf = Bytes.create read_buf_len in
let input ch =
match input ch read_buf 0 read_buf_len with
| 0 -> Error `Eof
| s -> Ok s in
| s -> Ok s
in
let rec loop = function
| [] -> ()
| read_list ->
let can_read, _, _ = Unix.select read_list [] [] 1.0 in
let to_remove =
List.fold_left (fun to_remove fh ->
let (rr, buf) =
if fh = stderr_fd then (
(input stderr, err_buf)
) else (
(input stdout, in_buf)
) in
begin match rr with
| Ok len ->
Buffer.add_subbytes buf read_buf 0 len;
to_remove
| Error `Eof ->
fh :: to_remove
end
) [] can_read in
read_list
|> List.filter (fun fh -> not (List.mem fh to_remove))
|> loop
List.fold_left
(fun to_remove fh ->
let rr, buf =
if fh = stderr_fd then
input stderr, err_buf
else
input stdout, in_buf
in
match rr with
| Ok len ->
Buffer.add_subbytes buf read_buf 0 len;
to_remove
| Error `Eof -> fh :: to_remove)
[] can_read
in
read_list |> List.filter (fun fh -> not (List.mem fh to_remove)) |> loop
in
ignore (loop [ stdout_fd ; stderr_fd ]);
ignore (loop [ stdout_fd; stderr_fd ]);
let status = Unix.close_process_full (stdout, stdin, stderr) in
{ Process_result.
status
; stdout = Buffer.contents in_buf
; stderr = Buffer.contents err_buf
{
Process_result.status;
stdout = Buffer.contents in_buf;
stderr = Buffer.contents err_buf;
}
let run ?(exe="curl") ?(args=[]) req =
let run ?(exe = "curl") ?(args = []) req =
Request.validate req >>= fun req ->
let args = "-si" :: (Request.to_cmd_args req) @ args in
let args = ("-si" :: Request.to_cmd_args req) @ args in
let res =
try
result_of_process_result (run exe args req.Request.body)
with e ->
Error (Error.Exn e)
try result_of_process_result (run exe args req.Request.body)
with e -> Error (Error.Exn e)
in
res >>= fun res ->
match Response.of_stdout res.Process_result.stdout with
@ -227,11 +198,15 @@ let run ?(exe="curl") ?(args=[]) req =
let get ?exe ?args ?headers url =
run ?exe ?args (Request.make ?headers ~url ~meth:`GET ())
let head ?exe ?args ?headers url =
run ?exe ?args (Request.make ?headers ~url ~meth:`HEAD ())
let delete ?exe ?args ?headers url =
run ?exe ?args (Request.make ?headers ~url ~meth:`DELETE ())
let post ?exe ?args ?headers ?body url =
run ?exe ?args (Request.make ?body ?headers ~url ~meth:`POST ())
let put ?exe ?args ?headers ?body url =
run ?exe ?args (Request.make ?body ?headers ~url ~meth:`PUT ())

103
src/bin/curly.mli
View file

@ -21,42 +21,23 @@ module Header : sig
end
module Response : sig
type t =
{ code: int
; headers: Header.t
; body:string
}
type t = { code: int; headers: Header.t; body: string }
val pp : Format.formatter -> t -> unit
end
module Request : sig
type t =
{ meth: Meth.t
; url:string
; headers: Header.t
; body:string
}
type t = { meth: Meth.t; url: string; headers: Header.t; body: string }
val make
: ?headers:Header.t
-> ?body:string
-> url:string
-> meth:Meth.t
-> unit
-> t
val make :
?headers:Header.t -> ?body:string -> url:string -> meth:Meth.t -> unit -> t
val to_cmd_args : t -> string list
val pp : Format.formatter -> t -> unit
end
module Process_result : sig
type t =
{ status: Unix.process_status
; stderr:string
; stdout:string
}
type t = { status: Unix.process_status; stderr: string; stdout: string }
val pp : Format.formatter -> t -> unit
end
@ -71,55 +52,55 @@ module Error : sig
val pp : Format.formatter -> t -> unit
end
val run
: ?exe:string
-> ?args:string list
-> Request.t
-> (Response.t, Error.t) Result.result
val run :
?exe:string ->
?args:string list ->
Request.t ->
(Response.t, Error.t) Result.result
val get
: ?exe:string
-> ?args:string list
-> ?headers:Header.t
-> string
-> (Response.t, Error.t) Result.result
val get :
?exe:string ->
?args:string list ->
?headers:Header.t ->
string ->
(Response.t, Error.t) Result.result
(** Specialized version of {!run} for method [`GET]
@since 0.2.0 *)
val head
: ?exe:string
-> ?args:string list
-> ?headers:Header.t
-> string
-> (Response.t, Error.t) Result.result
val head :
?exe:string ->
?args:string list ->
?headers:Header.t ->
string ->
(Response.t, Error.t) Result.result
(** Specialized version of {!run} for method [`HEAD]
@since 0.2.0 *)
val delete
: ?exe:string
-> ?args:string list
-> ?headers:Header.t
-> string
-> (Response.t, Error.t) Result.result
val delete :
?exe:string ->
?args:string list ->
?headers:Header.t ->
string ->
(Response.t, Error.t) Result.result
(** Specialized version of {!run} for method [`DELETE]
@since 0.2.0 *)
val post
: ?exe:string
-> ?args:string list
-> ?headers:Header.t
-> ?body:string
-> string
-> (Response.t, Error.t) Result.result
val post :
?exe:string ->
?args:string list ->
?headers:Header.t ->
?body:string ->
string ->
(Response.t, Error.t) Result.result
(** Specialized version of {!run} for method [`POST]
@since 0.2.0 *)
val put
: ?exe:string
-> ?args:string list
-> ?headers:Header.t
-> ?body:string
-> string
-> (Response.t, Error.t) Result.result
val put :
?exe:string ->
?args:string list ->
?headers:Header.t ->
?body:string ->
string ->
(Response.t, Error.t) Result.result
(** Specialized version of {!run} for method [`PUT]
@since 0.2.0 *)

27
src/bin/dune
View file

@ -1,18 +1,17 @@
(executable
(name http_of_dir)
(public_name http_of_dir)
(package tiny_httpd)
(modules http_of_dir)
(flags :standard -warn-error -3)
(libraries tiny_httpd))
(executable
(name http_of_dir)
(public_name http_of_dir)
(package tiny_httpd)
(modules http_of_dir)
(flags :standard -warn-error -3)
(libraries tiny_httpd))
(executable
(name vfs_pack)
(public_name tiny-httpd-vfs-pack)
(package tiny_httpd)
(modules vfs_pack curly http)
(libraries result unix)
(flags :standard -warn-error -3))
(name vfs_pack)
(public_name tiny-httpd-vfs-pack)
(package tiny_httpd)
(modules vfs_pack curly http)
(libraries result unix)
(flags :standard -warn-error -3))
(ocamllex http)

6
src/bin/http.mli
View file

@ -1,9 +1,5 @@
(* The purpose of this module isn't to be a full blown http parser but rather to
only parse whatever curl otputs *)
type response =
{ code: int
; headers: (string * string) list
; body: string
}
type response = { code: int; headers: (string * string) list; body: string }
val response : response -> Lexing.lexbuf -> response

91
src/bin/http_of_dir.ml
View file

@ -3,10 +3,14 @@ module U = Tiny_httpd_util
module D = Tiny_httpd_dir
module Pf = Printf
let serve ~config (dir:string) addr port j : _ result =
let serve ~config (dir : string) addr port j : _ result =
let server = S.create ~max_connections:j ~addr ~port () in
Printf.printf "serve directory %s on http://%(%s%):%d\n%!"
dir (if S.is_ipv6 server then "[%s]" else "%s") addr port;
Printf.printf "serve directory %s on http://%(%s%):%d\n%!" dir
(if S.is_ipv6 server then
"[%s]"
else
"%s")
addr port;
D.add_dir_path ~config ~dir ~prefix:"" server;
S.run server
@ -14,43 +18,62 @@ let serve ~config (dir:string) addr port j : _ result =
let parse_size s : int =
try Scanf.sscanf s "%dM" (fun n -> n * 1_024 * 1_024)
with _ ->
try Scanf.sscanf s "%dk" (fun n -> n * 1_024)
with _ ->
try int_of_string s
with _ -> raise (Arg.Bad "invalid size (expected <int>[kM]?)")
(try Scanf.sscanf s "%dk" (fun n -> n * 1_024)
with _ ->
(try int_of_string s
with _ -> raise (Arg.Bad "invalid size (expected <int>[kM]?)")))
let main () =
let config =
D.config ~dir_behavior:Index_or_lists ()
in
let config = D.config ~dir_behavior:Index_or_lists () in
let dir_ = ref "." in
let addr = ref "127.0.0.1" in
let port = ref 8080 in
let j = ref 32 in
Arg.parse (Arg.align [
"--addr", Set_string addr, " address to listen on";
"-a", Set_string addr, " alias to --listen";
"--port", Set_int port, " port to listen on";
"-p", Set_int port, " alias to --port";
"--dir", Set_string dir_, " directory to serve (default: \".\")";
"--debug", Unit (fun () -> S._enable_debug true), " debug mode";
"--upload", Unit (fun () -> config.upload <- true), " enable file uploading";
"--no-upload", Unit (fun () -> config.upload <- false), " disable file uploading";
"--download", Unit (fun () -> config.download <- true), " enable file downloading";
"--no-download", Unit (fun () -> config.download <- false), " disable file downloading";
"--max-upload", String (fun i -> config.max_upload_size <- parse_size i),
" maximum size of files that can be uploaded";
"--auto-index",
Bool (fun b -> config.dir_behavior <-
(if b then Index_or_lists else Lists)),
" <bool> automatically redirect to index.html if present";
"--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files";
"--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files";
"-j", Set_int j, " maximum number of simultaneous connections";
]) (fun s -> dir_ := s) "http_of_dir [options] [dir]";
let j = ref 32 in
Arg.parse
(Arg.align
[
"--addr", Set_string addr, " address to listen on";
"-a", Set_string addr, " alias to --listen";
"--port", Set_int port, " port to listen on";
"-p", Set_int port, " alias to --port";
"--dir", Set_string dir_, " directory to serve (default: \".\")";
"--debug", Unit (fun () -> S._enable_debug true), " debug mode";
( "--upload",
Unit (fun () -> config.upload <- true),
" enable file uploading" );
( "--no-upload",
Unit (fun () -> config.upload <- false),
" disable file uploading" );
( "--download",
Unit (fun () -> config.download <- true),
" enable file downloading" );
( "--no-download",
Unit (fun () -> config.download <- false),
" disable file downloading" );
( "--max-upload",
String (fun i -> config.max_upload_size <- parse_size i),
" maximum size of files that can be uploaded" );
( "--auto-index",
Bool
(fun b ->
config.dir_behavior <-
(if b then
Index_or_lists
else
Lists)),
" <bool> automatically redirect to index.html if present" );
( "--delete",
Unit (fun () -> config.delete <- true),
" enable `delete` on files" );
( "--no-delete",
Unit (fun () -> config.delete <- false),
" disable `delete` on files" );
"-j", Set_int j, " maximum number of simultaneous connections";
])
(fun s -> dir_ := s)
"http_of_dir [options] [dir]";
match serve ~config !dir_ !addr !port !j with
| Ok () -> ()
| Error e ->
raise e
| Error e -> raise e
let () = main ()

119
src/bin/vfs_pack.ml
View file

@ -1,7 +1,6 @@
let spf = Printf.sprintf
let fpf = Printf.fprintf
let now_ = Unix.gettimeofday()
let now_ = Unix.gettimeofday ()
let verbose = ref false
type entry =
@ -15,83 +14,85 @@ let read_file filename =
let buf = Buffer.create 32 in
let b = Bytes.create 1024 in
while
let n=input ic b 0 (Bytes.length b) in
let n = input ic b 0 (Bytes.length b) in
Buffer.add_subbytes buf b 0 n;
n > 0
do () done;
do
()
done;
close_in ic;
Buffer.contents buf
let split_comma s = Scanf.sscanf s "%s@,%s" (fun x y -> x,y)
let split_comma s = Scanf.sscanf s "%s@,%s" (fun x y -> x, y)
let is_url s =
let is_prefix pre s =
String.length s > String.length pre &&
String.sub s 0 (String.length pre) = pre
String.length s > String.length pre
&& String.sub s 0 (String.length pre) = pre
in
is_prefix "http://" s || is_prefix "https://" s
let emit oc (l:entry list) : unit =
fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n" now_;
let emit oc (l : entry list) : unit =
fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n"
now_;
let add_vfs ~mtime vfs_path content =
fpf oc
"let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n \
~mtime:%h ~path:%S\n \
%S\n"
"let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n\
\ ~mtime:%h ~path:%S\n\
\ %S\n"
mtime vfs_path content
in
let rec add_entry = function
| File (vfs_path, actual_path) ->
if !verbose then Printf.eprintf "add file %S = %S\n%!" vfs_path actual_path;
if !verbose then
Printf.eprintf "add file %S = %S\n%!" vfs_path actual_path;
let content = read_file actual_path in
let mtime = (Unix.stat actual_path).Unix.st_mtime in
add_vfs ~mtime vfs_path content
| Url (vfs_path, url) ->
if !verbose then Printf.eprintf "add url %S = %S\n%!" vfs_path url;
begin match Curly.get ~args:["-L"] url with
| Ok b ->
let code = b.Curly.Response.code in
if code >= 200 && code < 300 then (
add_vfs ~mtime:now_ vfs_path b.Curly.Response.body
) else (
failwith (Printf.sprintf "download of %S failed with code: %d" url code)
)
| Error err ->
failwith (Format.asprintf "download of %S failed: %a" url Curly.Error.pp err)
end
(match Curly.get ~args:[ "-L" ] url with
| Ok b ->
let code = b.Curly.Response.code in
if code >= 200 && code < 300 then
add_vfs ~mtime:now_ vfs_path b.Curly.Response.body
else
failwith
(Printf.sprintf "download of %S failed with code: %d" url code)
| Error err ->
failwith
(Format.asprintf "download of %S failed: %a" url Curly.Error.pp err))
| Mirror (vfs_path, dir) ->
if !verbose then Printf.eprintf "mirror directory %S as %S\n%!" dir vfs_path;
if !verbose then
Printf.eprintf "mirror directory %S as %S\n%!" dir vfs_path;
let rec traverse rpath =
let real_path = Filename.concat dir rpath in
if Sys.is_directory real_path then (
let arr = Sys.readdir real_path in
Array.iter (fun e -> traverse (Filename.concat rpath e)) arr
) else (
) else
add_entry (File (Filename.concat vfs_path rpath, real_path))
)
in
traverse "."
| Source_file f ->
if !verbose then Printf.eprintf "read source file %S\n%!" f;
let lines =
read_file f |> String.split_on_char '\n'
|> List.map String.trim
|> List.filter ((<>) "")
read_file f |> String.split_on_char '\n' |> List.map String.trim
|> List.filter (( <> ) "")
in
let process_line line =
let vfs_path, path = split_comma line in
if is_url path then add_entry (Url(vfs_path, path))
else add_entry (File (vfs_path, path))
if is_url path then
add_entry (Url (vfs_path, path))
else
add_entry (File (vfs_path, path))
in
List.iter process_line lines
@ -101,8 +102,8 @@ let emit oc (l:entry list) : unit =
fpf oc "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs\n";
()
let help = {|vfs-pack [opt]+
let help =
{|vfs-pack [opt]+
Builds an OCaml module containing a `Tiny_httpd_dir.Embedded_fs.t`
virtual file system. This is useful to pack assets into an OCaml binary,
@ -121,7 +122,6 @@ and is processed as previously. If actual_path looks like an http(s) URL
it is treated as such.
|}
let () =
let entries = ref [] in
let out = ref "" in
@ -133,30 +133,45 @@ let () =
add_entry (File (vfs_path, path))
and add_mirror s =
let vfs_path, path = split_comma s in
let vfs_path, path = if path="" then "", vfs_path else vfs_path, path in
let vfs_path, path =
if path = "" then
"", vfs_path
else
vfs_path, path
in
add_entry (Mirror (vfs_path, path))
and add_source f = add_entry (Source_file f)
and add_url s =
let vfs_path, path = split_comma s in
if is_url path then add_entry (Url(vfs_path, path))
else invalid_arg (spf "--url: invalid URL %S" path)
if is_url path then
add_entry (Url (vfs_path, path))
else
invalid_arg (spf "--url: invalid URL %S" path)
in
let opts = [
"-v", Arg.Set verbose, " verbose mode";
"-o", Arg.Set_string out, " set output file";
"--file", Arg.String add_file, " <name,file> adds name=file to the VFS";
"--url", Arg.String add_url, " <name,url> adds name=url to the VFS";
"--mirror", Arg.String add_mirror, " <prefix,dir> copies directory dir into the VFS under prefix";
"-F", Arg.String add_source, " <file> reads entries from the file, on per line";
] |> Arg.align in
let opts =
[
"-v", Arg.Set verbose, " verbose mode";
"-o", Arg.Set_string out, " set output file";
"--file", Arg.String add_file, " <name,file> adds name=file to the VFS";
"--url", Arg.String add_url, " <name,url> adds name=url to the VFS";
( "--mirror",
Arg.String add_mirror,
" <prefix,dir> copies directory dir into the VFS under prefix" );
( "-F",
Arg.String add_source,
" <file> reads entries from the file, on per line" );
]
|> Arg.align
in
Arg.parse opts (fun _ -> raise (Arg.Help "no positional arg")) help;
let out, close =
if !out="" then stdout,ignore
else open_out !out, close_out
if !out = "" then
stdout, ignore
else
open_out !out, close_out
in
emit out !entries;
close out;
exit 0

273
src/camlzip/Tiny_httpd_camlzip.ml
View file

@ -1,171 +1,152 @@
module S = Tiny_httpd_server
module BS = Tiny_httpd_stream
let decode_deflate_stream_ ~buf_size (is:S.byte_stream) : S.byte_stream =
S._debug (fun k->k "wrap stream with deflate.decode");
let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream =
S._debug (fun k -> k "wrap stream with deflate.decode");
let zlib_str = Zlib.inflate_init false in
let is_done = ref false in
BS.make
~bs:(Bytes.create buf_size)
BS.make ~bs:(Bytes.create buf_size)
~close:(fun _ ->
Zlib.inflate_end zlib_str;
BS.close is
)
Zlib.inflate_end zlib_str;
BS.close is)
~consume:(fun self len ->
if len > self.len then (
S.Response.fail_raise ~code:400
"inflate: error during decompression: invalid consume len %d (max %d)"
len self.len
);
self.off <- self.off + len;
self.len <- self.len - len;
)
if len > self.len then
S.Response.fail_raise ~code:400
"inflate: error during decompression: invalid consume len %d (max %d)"
len self.len;
self.off <- self.off + len;
self.len <- self.len - len)
~fill:(fun self ->
(* refill [buf] if needed *)
if self.len = 0 && not !is_done then (
is.fill_buf();
begin
try
let finished, used_in, used_out =
Zlib.inflate zlib_str
self.bs 0 (Bytes.length self.bs)
is.bs is.off is.len Zlib.Z_SYNC_FLUSH
in
is.consume used_in;
self.off <- 0;
self.len <- used_out;
if finished then is_done := true;
S._debug (fun k->k "decode %d bytes as %d bytes from inflate (finished: %b)"
used_in used_out finished);
with Zlib.Error (e1,e2) ->
S.Response.fail_raise ~code:400
"inflate: error during decompression:\n%s %s" e1 e2
end;
S._debug (fun k->k "inflate: refill %d bytes into internal buf" self.len);
);
)
(* refill [buf] if needed *)
if self.len = 0 && not !is_done then (
is.fill_buf ();
(try
let finished, used_in, used_out =
Zlib.inflate zlib_str self.bs 0 (Bytes.length self.bs) is.bs is.off
is.len Zlib.Z_SYNC_FLUSH
in
is.consume used_in;
self.off <- 0;
self.len <- used_out;
if finished then is_done := true;
S._debug (fun k ->
k "decode %d bytes as %d bytes from inflate (finished: %b)"
used_in used_out finished)
with Zlib.Error (e1, e2) ->
S.Response.fail_raise ~code:400
"inflate: error during decompression:\n%s %s" e1 e2);
S._debug (fun k ->
k "inflate: refill %d bytes into internal buf" self.len)
))
()
let encode_deflate_stream_ ~buf_size (is:S.byte_stream) : S.byte_stream =
S._debug (fun k->k "wrap stream with deflate.encode");
let encode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream =
S._debug (fun k -> k "wrap stream with deflate.encode");
let refill = ref true in
let zlib_str = Zlib.deflate_init 4 false in
BS.make
~bs:(Bytes.create buf_size)
BS.make ~bs:(Bytes.create buf_size)
~close:(fun _self ->
S._debug (fun k->k "deflate: close");
Zlib.deflate_end zlib_str;
BS.close is
)
S._debug (fun k -> k "deflate: close");
Zlib.deflate_end zlib_str;
BS.close is)
~consume:(fun self n ->
self.off <- self.off + n;
self.len <- self.len - n
)
self.off <- self.off + n;
self.len <- self.len - n)
~fill:(fun self ->
let rec loop() =
S._debug (fun k->k "deflate.fill.iter out_off=%d out_len=%d"
self.off self.len);
if self.len > 0 then (
() (* still the same slice, not consumed entirely by output *)
) else if not !refill then (
() (* empty slice, no refill *)
let rec loop () =
S._debug (fun k ->
k "deflate.fill.iter out_off=%d out_len=%d" self.off self.len);
if self.len > 0 then
()
(* still the same slice, not consumed entirely by output *)
else if not !refill then
()
(* empty slice, no refill *)
else (
(* the output was entirely consumed, we need to do more work *)
is.BS.fill_buf ();
if is.len > 0 then (
(* try to decompress from input buffer *)
let _finished, used_in, used_out =
Zlib.deflate zlib_str is.bs is.off is.len self.bs 0
(Bytes.length self.bs) Zlib.Z_NO_FLUSH
in
self.off <- 0;
self.len <- used_out;
is.consume used_in;
S._debug (fun k ->
k "encode %d bytes as %d bytes using deflate (finished: %b)"
used_in used_out _finished);
if _finished then (
S._debug (fun k -> k "deflate: finished");
refill := false
);
loop ()
) else (
(* the output was entirely consumed, we need to do more work *)
is.BS.fill_buf();
if is.len > 0 then (
(* try to decompress from input buffer *)
let _finished, used_in, used_out =
Zlib.deflate zlib_str
is.bs is.off is.len
self.bs 0 (Bytes.length self.bs)
Zlib.Z_NO_FLUSH
in
self.off <- 0;
self.len <- used_out;
is.consume used_in;
S._debug
(fun k->k "encode %d bytes as %d bytes using deflate (finished: %b)"
used_in used_out _finished);
if _finished then (
S._debug (fun k->k "deflate: finished");
refill := false;
);
loop()
) else (
(* [is] is done, finish sending the data in current buffer *)
let _finished, used_in, used_out =
Zlib.deflate zlib_str
is.bs is.off is.len
self.bs 0 (Bytes.length self.bs)
Zlib.Z_FULL_FLUSH
in
assert (used_in = 0);
self.off <- 0;
self.len <- used_out;
if used_out = 0 then (
refill := false;
);
loop()
)
(* [is] is done, finish sending the data in current buffer *)
let _finished, used_in, used_out =
Zlib.deflate zlib_str is.bs is.off is.len self.bs 0
(Bytes.length self.bs) Zlib.Z_FULL_FLUSH
in
assert (used_in = 0);
self.off <- 0;
self.len <- used_out;
if used_out = 0 then refill := false;
loop ()
)
in
try loop()
with Zlib.Error (e1,e2) ->
S.Response.fail_raise ~code:400
"deflate: error during compression:\n%s %s" e1 e2
)
)
in
try loop ()
with Zlib.Error (e1, e2) ->
S.Response.fail_raise ~code:400
"deflate: error during compression:\n%s %s" e1 e2)
()
let split_on_char ?(f=fun x->x) c s : string list =
let split_on_char ?(f = fun x -> x) c s : string list =
let rec loop acc i =
match String.index_from s i c with
| exception Not_found ->
let acc =
if i=String.length s then acc
else f (String.sub s i (String.length s-i)) :: acc
in List.rev acc
if i = String.length s then
acc
else
f (String.sub s i (String.length s - i)) :: acc
in
List.rev acc
| j ->
let acc = f (String.sub s i (j-i)) :: acc in
loop acc (j+1)
let acc = f (String.sub s i (j - i)) :: acc in
loop acc (j + 1)
in
loop [] 0
let accept_deflate (req:_ S.Request.t) =
match
S.Request.get_header req "Accept-Encoding"
with
let accept_deflate (req : _ S.Request.t) =
match S.Request.get_header req "Accept-Encoding" with
| Some s -> List.mem "deflate" @@ split_on_char ~f:String.trim ',' s
| None -> false
let has_deflate s =
try Scanf.sscanf s "deflate, %s" (fun _ -> true)
with _ -> false
try Scanf.sscanf s "deflate, %s" (fun _ -> true) with _ -> false
(* decompress [req]'s body if needed *)
let decompress_req_stream_ ~buf_size (req:BS.t S.Request.t) : _ S.Request.t =
let decompress_req_stream_ ~buf_size (req : BS.t S.Request.t) : _ S.Request.t =
match S.Request.get_header ~f:String.trim req "Transfer-Encoding" with
(* TODO
| Some "gzip" ->
let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
Some (req', decode_gzip_stream_)
| Some "gzip" ->
let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in
Some (req', decode_gzip_stream_)
*)
| Some s when has_deflate s ->
begin match Scanf.sscanf s "deflate, %s" (fun s -> s) with
| tr' ->
let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
req
|> S.Request.set_header "Transfer-Encoding" tr'
|> S.Request.set_body body'
| exception _ -> req
end
(match Scanf.sscanf s "deflate, %s" (fun s -> s) with
| tr' ->
let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in
req
|> S.Request.set_header "Transfer-Encoding" tr'
|> S.Request.set_body body'
| exception _ -> req)
| _ -> req
let compress_resp_stream_
~compress_above
~buf_size
(req:_ S.Request.t) (resp:S.Response.t) : S.Response.t =
let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t)
(resp : S.Response.t) : S.Response.t =
(* headers for compressed stream *)
let update_headers h =
h
@ -177,39 +158,31 @@ let compress_resp_stream_
match resp.body with
| `String s when String.length s > compress_above ->
(* big string, we compress *)
S._debug
(fun k->k "encode str response with deflate (size %d, threshold %d)"
(String.length s) compress_above);
let body =
encode_deflate_stream_ ~buf_size @@ BS.of_string s
in
S._debug (fun k ->
k "encode str response with deflate (size %d, threshold %d)"
(String.length s) compress_above);
let body = encode_deflate_stream_ ~buf_size @@ BS.of_string s in
resp
|> S.Response.update_headers update_headers
|> S.Response.set_body (`Stream body)
| `Stream str ->
S._debug (fun k->k "encode stream response with deflate");
S._debug (fun k -> k "encode stream response with deflate");
resp
|> S.Response.update_headers update_headers
|> S.Response.set_body (`Stream (encode_deflate_stream_ ~buf_size str))
| `String _ | `Void -> resp
) else resp
) else
resp
let middleware
?(compress_above=16 * 1024)
?(buf_size=16 * 1_024)
() : S.Middleware.t =
let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () :
S.Middleware.t =
let buf_size = max buf_size 1_024 in
fun h req ~resp ->
let req = decompress_req_stream_ ~buf_size req in
h req
~resp:(fun response ->
resp @@ compress_resp_stream_ ~buf_size ~compress_above req response)
h req ~resp:(fun response ->
resp @@ compress_resp_stream_ ~buf_size ~compress_above req response)
let setup
?compress_above ?buf_size server =
let setup ?compress_above ?buf_size server =
let m = middleware ?compress_above ?buf_size () in
S._debug (fun k->k "setup gzip support");
S._debug (fun k -> k "setup gzip support");
S.add_middleware ~stage:`Encoding server m

9
src/camlzip/Tiny_httpd_camlzip.mli
View file

@ -1,14 +1,9 @@
val middleware :
?compress_above:int ->
?buf_size:int -> unit ->
Tiny_httpd_server.Middleware.t
?compress_above:int -> ?buf_size:int -> unit -> Tiny_httpd_server.Middleware.t
(** Middleware responsible for deflate compression/decompression.
@since 0.11 *)
val setup :
?compress_above:int ->
?buf_size:int -> Tiny_httpd_server.t -> unit
val setup : ?compress_above:int -> ?buf_size:int -> Tiny_httpd_server.t -> unit
(** Install middleware for tiny_httpd to be able to encode/decode
compressed streams
@param compress_above threshold above with string responses are compressed

11
src/camlzip/dune
View file

@ -1,7 +1,6 @@
(library
(name tiny_httpd_camlzip)
(public_name tiny_httpd_camlzip)
(synopsis "A wrapper around camlzip to bring compression to Tiny_httpd")
(flags :standard -safe-string -warn-error -a+8)
(libraries tiny_httpd camlzip))
(name tiny_httpd_camlzip)
(public_name tiny_httpd_camlzip)
(synopsis "A wrapper around camlzip to bring compression to Tiny_httpd")
(flags :standard -safe-string -warn-error -a+8)
(libraries tiny_httpd camlzip))

21
src/dune
View file

@ -1,12 +1,15 @@
(library
(name tiny_httpd)
(public_name tiny_httpd)
(libraries threads seq)
(flags :standard -safe-string -warn-error -a+8)
(wrapped false))
(name tiny_httpd)
(public_name tiny_httpd)
(libraries threads seq)
(flags :standard -safe-string -warn-error -a+8)
(wrapped false))
(rule
(targets Tiny_httpd_html_.ml)
(deps (:bin ./gen/gentags.exe))
(action (with-stdout-to %{targets} (run %{bin}))))
(targets Tiny_httpd_html_.ml)
(deps
(:bin ./gen/gentags.exe))
(action
(with-stdout-to
%{targets}
(run %{bin}))))

4
src/gen/dune
View file

@ -1,4 +1,2 @@
(executable
(name gentags))
(name gentags))

559
src/gen/gentags.ml
View file

@ -1,146 +1,148 @@
(* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
let pf = Printf.printf
let spf = Printf.sprintf
let void = [
"area";
"base";
"br";
"col";
"embed";
"hr";
"img";
"input";
"link";
"menuitem";
"meta";
"param";
"source";
"track";
"wbr";
]
let void =
[
"area";
"base";
"br";
"col";
"embed";
"hr";
"img";
"input";
"link";
"menuitem";
"meta";
"param";
"source";
"track";
"wbr";
]
let normal = [
"a";
"abbr";
"address";
"area";
"article";
"aside";
"audio";
"b";
"base";
"bdi";
"bdo";
"blockquote";
"body";
"br";
"button";
"canvas";
"caption";
"cite";
"code";
"col";
"colgroup";
"data";
"datalist";
"dd";
"del";
"details";
"dfn";
"dialog";
"div";
"dl";
"dt";
"em";
"embed";
"fieldset";
"figcaption";
"figure";
"footer";
"form";
"h1";
"h2";
"h3";
"h4";
"h5";
"h6";
"head";
"header";
"hgroup";
"hr";
"html";
"i";
"iframe";
"img";
"input";
"ins";
"kbd";
"label";
"legend";
"li";
"link";
"main";
"map";
"mark";
"math";
"menu";
"menuitem";
"meta";
"meter";
"nav";
"noscript";
"object";
"ol";
"optgroup";
"option";
"output";
"p";
"param";
"picture";
"pre";
"progress";
"q";
"rb";
"rp";
"rt";
"rtc";
"ruby";
"s";
"samp";
"script";
"section";
"select";
"slot";
"small";
"source";
"span";
"strong";
"style";
"sub";
"summary";
"sup";
"svg";
"table";
"tbody";
"td";
"template";
"textarea";
"tfoot";
"th";
"thead";
"time";
"title";
"tr";
"track";
"u";
"ul";
"var";
"video";
"wbr";
] |> List.filter (fun s -> not (List.mem s void))
let normal =
[
"a";
"abbr";
"address";
"area";
"article";
"aside";
"audio";
"b";
"base";
"bdi";
"bdo";
"blockquote";
"body";
"br";
"button";
"canvas";
"caption";
"cite";
"code";
"col";
"colgroup";
"data";
"datalist";
"dd";
"del";
"details";
"dfn";
"dialog";
"div";
"dl";
"dt";
"em";
"embed";
"fieldset";
"figcaption";
"figure";
"footer";
"form";
"h1";
"h2";
"h3";
"h4";
"h5";
"h6";
"head";
"header";
"hgroup";
"hr";
"html";
"i";
"iframe";
"img";
"input";
"ins";
"kbd";
"label";
"legend";
"li";
"link";
"main";
"map";
"mark";
"math";
"menu";
"menuitem";
"meta";
"meter";
"nav";
"noscript";
"object";
"ol";
"optgroup";
"option";
"output";
"p";
"param";
"picture";
"pre";
"progress";
"q";
"rb";
"rp";
"rt";
"rtc";
"ruby";
"s";
"samp";
"script";
"section";
"select";
"slot";
"small";
"source";
"span";
"strong";
"style";
"sub";
"summary";
"sup";
"svg";
"table";
"tbody";
"td";
"template";
"textarea";
"tfoot";
"th";
"thead";
"time";
"title";
"tr";
"track";
"u";
"ul";
"var";
"video";
"wbr";
]
|> List.filter (fun s -> not (List.mem s void))
(* obtained via:
{[
@ -150,134 +152,136 @@ let normal = [
]}
on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes
*)
let attrs = [
"accept";
"accept-charset";
"accesskey";
"action";
"align";
"allow";
"alt";
"async";
"autocapitalize";
"autocomplete";
"autofocus";
"autoplay";
"buffered";
"capture";
"challenge";
"charset";
"checked";
"cite";
"class";
"code";
"codebase";
"cols";
"colspan";
"content";
"contenteditable";
"contextmenu";
"controls";
"coords";
"crossorigin";
"csp";
"data";
"data-*";
"datetime";
"decoding";
"default";
"defer";
"dir";
"dirname";
"disabled";
"download";
"draggable";
"enctype";
"enterkeyhint";
"for";
"form";
"formaction";
"formenctype";
"formmethod";
"formnovalidate";
"formtarget";
"headers";
"hidden";
"high";
"href";
"hreflang";
"http-equiv";
"icon";
"id";
"importance";
"integrity";
"ismap";
"itemprop";
"keytype";
"kind";
"label";
"lang";
"language";
"list";
"loop";
"low";
"manifest";
"max";
"maxlength";
"minlength";
"media";
"method";
"min";
"multiple";
"muted";
"name";
"novalidate";
"open";
"optimum";
"pattern";
"ping";
"placeholder";
"poster";
"preload";
"radiogroup";
"readonly";
"referrerpolicy";
"rel";
"required";
"reversed";
"rows";
"rowspan";
"sandbox";
"scope";
"scoped";
"selected";
"shape";
"size";
"sizes";
"slot";
"span";
"spellcheck";
"src";
"srcdoc";
"srclang";
"srcset";
"start";
"step";
"style";
"summary";
"tabindex";
"target";
"title";
"translate";
"Text";
"type";
"usemap";
"value";
"width";
"wrap";
]
let attrs =
[
"accept";
"accept-charset";
"accesskey";
"action";
"align";
"allow";
"alt";
"async";
"autocapitalize";
"autocomplete";
"autofocus";
"autoplay";
"buffered";
"capture";
"challenge";
"charset";
"checked";
"cite";
"class";
"code";
"codebase";
"cols";
"colspan";
"content";
"contenteditable";
"contextmenu";
"controls";
"coords";
"crossorigin";
"csp";
"data";
"data-*";
"datetime";
"decoding";
"default";
"defer";
"dir";
"dirname";
"disabled";
"download";
"draggable";
"enctype";
"enterkeyhint";
"for";
"form";
"formaction";
"formenctype";
"formmethod";
"formnovalidate";
"formtarget";
"headers";
"hidden";
"high";
"href";
"hreflang";
"http-equiv";
"icon";
"id";
"importance";
"integrity";
"ismap";
"itemprop";
"keytype";
"kind";
"label";
"lang";
"language";
"list";
"loop";
"low";
"manifest";
"max";
"maxlength";
"minlength";
"media";
"method";
"min";
"multiple";
"muted";
"name";
"novalidate";
"open";
"optimum";
"pattern";
"ping";
"placeholder";
"poster";
"preload";
"radiogroup";
"readonly";
"referrerpolicy";
"rel";
"required";
"reversed";
"rows";
"rowspan";
"sandbox";
"scope";
"scoped";
"selected";
"shape";
"size";
"sizes";
"slot";
"span";
"spellcheck";
"src";
"srcdoc";
"srclang";
"srcset";
"start";
"step";
"style";
"summary";
"tabindex";
"target";
"title";
"translate";
"Text";
"type";
"usemap";
"value";
"width";
"wrap";
]
let prelude = {|
let prelude =
{|
(** Output for HTML combinators.
This output type is used to produce a string reasonably efficiently from
@ -431,11 +435,17 @@ let oname = function
| "Text" -> "text"
| "type" -> "type_"
| name ->
String.map (function '-' -> '_' | c -> c) name
String.map
(function
| '-' -> '_'
| c -> c)
name
let emit_void name =
let oname = oname name in
pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
pf
"(** tag %S, see \
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
name name;
pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname;
pf " if if_ then (\n";
@ -447,12 +457,14 @@ let emit_void name =
let emit_normal name =
let oname = oname name in
pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
pf
"(** tag %S, see \
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
name name;
pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname;
pf " if if_ then (\n";
(* for <pre>, newlines actually matter *)
if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
if name = "pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
pf " List.iter (fun sub -> Out.add_format_nl out; sub out) sub;\n";
pf " if sub <> [] then Out.add_format_nl out;\n";
@ -461,21 +473,23 @@ let emit_normal name =
(* block version *)
let oname = oname ^ "'" in
pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
pf
"(** tag %S, see \
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
name name;
pf "let %s : nary' = fun ?(if_=true) attrs l out ->\n" oname;
pf " if if_ then (\n";
if name="pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
if name = "pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
pf " let has_sub = _write_subs out l in\n";
pf " if has_sub then Out.add_format_nl out;\n";
pf " Out.add_string out \"</%s>\")" name;
pf "\n\n";
()
let doc_attrs = {|Attributes.
let doc_attrs =
{|Attributes.
This module contains combinator for the standard attributes.
One can also just use a pair of strings. |}
@ -498,4 +512,3 @@ let () =
List.iter emit_attr attrs;
pf "end\n";
()

24
src/qtest/dune
View file

@ -1,18 +1,18 @@
(executable
(name qtest)
(modes native)
(flags :standard -warn-error -a+8 -w -33)
(libraries qcheck-core qcheck ounit2
threads threads.posix tiny_httpd))
(name qtest)
(modes native)
(flags :standard -warn-error -a+8 -w -33)
(libraries qcheck-core qcheck ounit2 threads threads.posix tiny_httpd))
(rule
(deps (glob_files ../*.ml{,i}))
(deps
(glob_files ../*.ml{,i}))
(targets qtest.ml)
(action (run qtest extract --quiet %{deps} -o %{targets})))
(action
(run qtest extract --quiet %{deps} -o %{targets})))
(rule
(alias runtest)
(package tiny_httpd)
(action (run ./qtest.exe)))
(alias runtest)
(package tiny_httpd)
(action
(run ./qtest.exe)))

124
tests/dune
View file

@ -1,64 +1,92 @@
(rule
(targets echo1.out)
(deps
(:bin ../examples/echo.exe))
(locks /port)
(enabled_if
(= %{system} "linux"))
(package tiny_httpd_camlzip)
(action
(with-stdout-to
%{targets}
(run ./echo1.sh %{bin}))))
(rule
(targets echo1.out)
(deps (:bin ../examples/echo.exe))
(locks /port)
(enabled_if (= %{system} "linux"))
(package tiny_httpd_camlzip)
(action (with-stdout-to %{targets} (run ./echo1.sh %{bin}))))
(alias runtest)
(package tiny_httpd_camlzip)
(enabled_if
(= %{system} "linux"))
(action
(diff echo1.expect echo1.out)))
(rule
(alias runtest)
(package tiny_httpd_camlzip)
(enabled_if (= %{system} "linux"))
(action (diff echo1.expect echo1.out)))
(targets sse_count.out)
(deps
(:bin ../examples/sse_server.exe))
(locks /port)
(enabled_if
(= %{system} "linux"))
(package tiny_httpd)
(action
(with-stdout-to
%{targets}
(run ./sse_count.sh %{bin}))))
(rule
(targets sse_count.out)
(deps (:bin ../examples/sse_server.exe))
(locks /port)
(enabled_if (= %{system} "linux"))
(package tiny_httpd)
(action (with-stdout-to %{targets} (run ./sse_count.sh %{bin}))))
(alias runtest)
(package tiny_httpd)
(enabled_if
(= %{system} "linux"))
(action
(diff sse_count.expect sse_count.out)))
(rule
(alias runtest)
(package tiny_httpd)
(enabled_if (= %{system} "linux"))
(action (diff sse_count.expect sse_count.out)))
(targets upload-out)
(deps
(:bin ../src/bin/http_of_dir.exe)
foo_50)
(locks /port)
(package tiny_httpd)
(enabled_if
(= %{system} "linux"))
(action
(with-stdout-to
%{targets}
(run ./upload_chunked.sh %{bin}))))
(rule
(targets upload-out)
(deps (:bin ../src/bin/http_of_dir.exe) foo_50)
(locks /port)
(package tiny_httpd)
(enabled_if (= %{system} "linux"))
(action (with-stdout-to %{targets}
(run ./upload_chunked.sh %{bin}))))
(alias runtest)
(package tiny_httpd)
(enabled_if
(= %{system} "linux"))
(action
(diff upload-out.expect upload-out)))
(rule
(alias runtest)
(package tiny_httpd)
(enabled_if (= %{system} "linux"))
(action (diff upload-out.expect upload-out)))
(targets dl-out)
(deps
(:bin ../src/bin/http_of_dir.exe)
foo_50)
(locks /port)
(package tiny_httpd)
(enabled_if
(= %{system} "linux"))
(action
(with-stdout-to
%{targets}
(run ./download_chunked.sh %{bin}))))
(rule
(targets dl-out)
(deps (:bin ../src/bin/http_of_dir.exe) foo_50)
(locks /port)
(package tiny_httpd)
(enabled_if (= %{system} "linux"))
(action (with-stdout-to %{targets}
(run ./download_chunked.sh %{bin}))))
(alias runtest)
(package tiny_httpd)
(enabled_if
(= %{system} "linux"))
(action
(diff dl-out.expect dl-out)))
(rule
(alias runtest)
(package tiny_httpd)
(enabled_if (= %{system} "linux"))
(action (diff dl-out.expect dl-out)))
(rule
(targets foo_50)
(enabled_if (= %{system} "linux"))
(action
(bash "dd if=/dev/zero of=%{targets} bs=1M count=50")))
(targets foo_50)
(enabled_if
(= %{system} "linux"))
(action
(bash "dd if=/dev/zero of=%{targets} bs=1M count=50")))

35
tests/html/dune
View file

@ -1,22 +1,31 @@
(executable
(libraries tiny_httpd)
(name makehtml))
(libraries tiny_httpd)
(name makehtml))
(rule
(targets t1.out.html)
(deps (:bin ./makehtml.exe))
(action (with-stdout-to %{targets} (run %{bin} 1))))
(targets t1.out.html)
(deps
(:bin ./makehtml.exe))
(action
(with-stdout-to
%{targets}
(run %{bin} 1))))
(rule
(alias runtest)
(action (diff t1.expected.html t1.out.html)))
(alias runtest)
(action
(diff t1.expected.html t1.out.html)))
(rule
(targets t2.out.html)
(deps (:bin ./makehtml.exe))
(action (with-stdout-to %{targets} (run %{bin} 2))))
(targets t2.out.html)
(deps
(:bin ./makehtml.exe))
(action
(with-stdout-to
%{targets}
(run %{bin} 2))))
(rule
(alias runtest)
(action (diff t2.expected.html t2.out.html)))
(alias runtest)
(action
(diff t2.expected.html t2.out.html)))

65
tests/html/makehtml.ml
View file

@ -1,41 +1,52 @@
open Tiny_httpd_html
let spf = Printf.sprintf
let list_init n f =
let rec loop i =
if i=n then []
else f i :: loop (i+1)
in loop 0
if i = n then
[]
else
f i :: loop (i + 1)
in
loop 0
let t1() =
html [] [
head [] [];
body [] [
ul [A.style "list-style: circle"] (
li[][pre [] [txt "a"; pre[][txt "c"; txt"d"]; txt "b"]] ::
list_init 100 (fun i -> li [A.id (spf "l%d" i)] [txt (spf "item %d" i)])
)
let t1 () =
html []
[
head [] [];
body []
[
ul
[ A.style "list-style: circle" ]
(li [] [ pre [] [ txt "a"; pre [] [ txt "c"; txt "d" ]; txt "b" ] ]
:: list_init 100 (fun i ->
li [ A.id (spf "l%d" i) ] [ txt (spf "item %d" i) ]));
];
]
]
let t2() =
html [] [
head [] [];
pre [] [txt "a"; txt "b"];
body [] [
ul' [A.style "list-style: circle"] [
sub_l @@ list_init 100 @@ fun i ->
li ~if_:(i<> 42) [A.id (spf "l%d" i)] [txt (spf "item %d" i)]
]
let t2 () =
html []
[
head [] [];
pre [] [ txt "a"; txt "b" ];
body []
[
ul'
[ A.style "list-style: circle" ]
[
(sub_l @@ list_init 100
@@ fun i ->
li ~if_:(i <> 42) [ A.id (spf "l%d" i) ] [ txt (spf "item %d" i) ]
);
];
];
]
]
let render t =
print_endline @@ to_string_top @@ t
let render t = print_endline @@ to_string_top @@ t
let () =
match Sys.argv.(1) with
| "1" -> render @@ t1()
| "2" -> render @@ t2()
| "1" -> render @@ t1 ()
| "2" -> render @@ t2 ()
| _ -> failwith "unknown cmd"