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

feat: add Route.t construct, deprecate scanf, add more structured path

Browse source 
- Request now contains a path split into components
- Request now contains the query part already transformed into an assoc list
- Route.t uses a simple GADT for mapping `/`-split paths into routes,
  passing some components of type string or int to the handler
- deprecate scanf-based routing, as being too error prone
This commit is contained in:
Simon Cruanes 2020-05-27 19:52:57 -04:00
parent eaa2c9b3b7
commit b640c0da30
7 changed files with 231 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

120
src/Tiny_httpd.ml
View file

@ -344,6 +344,8 @@ module Request = struct
host: string;
headers: Headers.t;
path: string;
path_components: string list;
query: (string*string) list;
body: 'body;
}
@ -355,24 +357,30 @@ module Request = struct
let non_query_path self = Tiny_httpd_util.get_non_query_path self.path
let query self =
match Tiny_httpd_util.(parse_query @@ get_query self.path) with
| Ok l -> l
| Error e -> bad_reqf 400 "invalid query: %s" e
let query self = self.query
let get_header ?f self h = Headers.get ?f h self.headers
let get_header_int self h = match get_header self h with
| Some x -> (try Some (int_of_string x) with _ -> None)
| None -> None
let set_header self k v = {self with headers=Headers.set k v self.headers}
let pp_comp_ out comp =
Format.fprintf out "[%s]"
(String.concat ";" @@ List.map (Printf.sprintf "%S") comp)
let pp_query out q =
Format.fprintf out "[%s]"
(String.concat ";" @@
List.map (fun (a,b) -> Printf.sprintf "%S,%S" a b) q)
let pp_ out self : unit =
Format.fprintf out "{@[meth=%s;@ host=%s;@ headers=%a;@ path=%S;@ body=?@]}"
Format.fprintf out "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ \
path=%S;@ body=?;@ path_components=%a;@ query=%a@]}"
(Meth.to_string self.meth) self.host Headers.pp self.headers self.path
pp_comp_ self.path_components pp_query self.query
let pp out self : unit =
Format.fprintf out "{@[meth=%s;@ host=%s;@ headers=%a;@ path=%S;@ body=%S@]}"
Format.fprintf out "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ \
body=%S;@ path_components=%a;@ query=%a@]}"
(Meth.to_string self.meth) self.host Headers.pp self.headers
self.path self.body
self.path self.body pp_comp_ self.path_components pp_query self.query
(* decode a "chunked" stream into a normal stream *)
let read_stream_chunked_ ?(buf=Buf_.create()) (bs:byte_stream) : byte_stream =
@ -472,7 +480,15 @@ module Request = struct
| None -> bad_reqf 400 "No 'Host' header in request"
| Some h -> h
in
Ok (Some {meth; host; path; headers; body=()})
let path_components, query = Tiny_httpd_util.split_query path in
let path_components = Tiny_httpd_util.split_on_slash path_components in
let query =
match Tiny_httpd_util.(parse_query query) with
| Ok l -> l
| Error e -> bad_reqf 400 "invalid query: %s" e
in
Ok (Some {meth; query; host; path; path_components;
headers; body=()})
with
| End_of_file | Sys_error _ -> Ok None
| Bad_req (c,s) -> Error (c,s)
@ -582,7 +598,7 @@ module Response = struct
| `String s -> Format.fprintf out "%S" s
| `Stream _ -> Format.pp_print_string out "<stream>"
in
Format.fprintf out "{@[code=%d;@ headers=%a;@ body=%a@]}"
Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}"
self.code Headers.pp self.headers pp_body self.body
(* print a stream as a series of chunks *)
@ -644,6 +660,55 @@ end
type cb_path_handler = byte_stream Request.t -> Response.t
module Route = struct
type path = string list (* split on '/' *)
type (_, _) comp =
| Exact : string -> ('a, 'a) comp
| Int : (int -> 'a, 'a) comp
| String : (string -> 'a, 'a) comp
| String_urlencoded : (string -> 'a, 'a) comp
type (_, _) t =
| Fire : ('b, 'b) t
| Compose: ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t
let return = Fire
let (@/) a b = Compose (a,b)
let string = String
let string_urlencoded = String_urlencoded
let int = Int
let exact (s:string) = Exact s
let rec eval :
type a b. path -> (a,b) t -> a -> b option =
fun path route f ->
begin match path, route with
| [], Fire -> Some f
| _, Fire -> None
| (c1 :: path'), Compose (comp, route') ->
begin match comp with
| Int ->
begin match int_of_string c1 with
| i -> eval path' route' (f i)
| exception _ -> None
end
| String ->
eval path' route' (f c1)
| String_urlencoded ->
begin match Tiny_httpd_util.percent_decode c1 with
| None -> None
| Some s -> eval path' route' (f s)
end
| Exact s ->
if s = c1 then eval path' route' f else None
end
| [], Compose (String, Fire) -> Some (f "") (* trailing *)
| [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *)
| [], Compose _ -> None
end
end
type t = {
addr: string;
port: int;
@ -668,7 +733,7 @@ let set_top_handler self f = self.handler <- f
let add_path_handler_
?(accept=fun _req -> Ok ())
?meth ~tr_req self fmt f =
let ph req: cb_path_handler resp_result option =
let ph req : cb_path_handler resp_result option =
match meth with
| Some m when m <> req.Request.meth -> None (* ignore *)
| _ ->
@ -685,12 +750,40 @@ let add_path_handler_
in
self.path_handlers <- ph :: self.path_handlers
let add_path_handler ?accept ?meth self fmt f=
(* TODO: remove *)
let add_path_handler ?accept ?meth self fmt f =
add_path_handler_ ?accept ?meth ~tr_req:Request.read_body_full self fmt f
let add_path_handler_stream ?accept ?meth self fmt f=
(* TODO: remove *)
let add_path_handler_stream ?accept ?meth self fmt f =
add_path_handler_ ?accept ?meth ~tr_req:(fun x->x) self fmt f
let add_route_handler_
?(accept=fun _req -> Ok ())
?meth ~tr_req self (route:_ Route.t) f =
let ph req : cb_path_handler resp_result option =
match meth with
| Some m when m <> req.Request.meth -> None (* ignore *)
| _ ->
begin match Route.eval req.Request.path_components route f with
| Some handler ->
(* we have a handler, do we accept the request based on its headers? *)
begin match accept req with
| Ok () -> Some (Ok (fun req -> handler @@ tr_req req))
| Error _ as e -> Some e
end
| None ->
None (* path didn't match *)
end
in
self.path_handlers <- ph :: self.path_handlers
let add_route_handler ?accept ?meth self route f =
add_route_handler_ ?accept ?meth ~tr_req:Request.read_body_full self route f
let add_route_handler_stream ?accept ?meth self route f =
add_route_handler_ ?accept ?meth ~tr_req:(fun x->x) self route f
let create
?(masksigpipe=true)
?(max_connections=32)
@ -733,6 +826,7 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit =
end;
continue := false
| Ok (Some req) ->
_debug (fun k->k "req: %s" (Format.asprintf "@[%a@]" Request.pp_ req));
let res =
try
(* is there a handler for this path? *)

62
src/Tiny_httpd.mli
View file

@ -216,6 +216,8 @@ module Request : sig
host: string;
headers: Headers.t;
path: string;
path_components: string list;
query: (string*string) list;
body: 'body;
}
(** A request with method, path, host, headers, and a body, sent by a client.
@ -223,7 +225,13 @@ module Request : sig
The body is polymorphic because the request goes through
several transformations. First it has no body, as only the request
and headers are read; then it has a stream body; then the body might be
entirely read as a string via {!read_body_full}. *)
entirely read as a string via {!read_body_full}.
The field [query] was added @since NEXT_RELEASE and contains
the query parameters in ["?foo=bar,x=y"]
The field [path_components] is the part of the path that precedes [query]
and is split on ["/"] and was added @since NEXT_RELEASE
*)
val pp : Format.formatter -> string t -> unit
(** Pretty print the request and its body *)
@ -362,6 +370,37 @@ module Response : sig
(** Pretty print the response. *)
end
(** {2 Routing}
Basic type-safe routing.
@since NEXT_RELEASE *)
module Route : sig
type ('a, 'b) comp
(** An atomic component of a path *)
type ('a, 'b) t
(** A route, composed of path components *)
val int : (int -> 'a, 'a) comp
(** Matches an integer. *)
val string : (string -> 'a, 'a) comp
(** Matches a string and binds it as is. *)
val string_urlencoded : (string -> 'a, 'a) comp
(** Matches a URL-encoded string, and decodes it. *)
val exact : string -> ('a, 'a) comp
(** [exact "s"] matches ["s"] and nothing else. *)
val return : ('a, 'a) t
(** Matches the empty path. *)
val (@/) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t
(** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"],
and [route] matches ["bar/…"]. *)
end
(** {2 Server} *)
type t
@ -436,6 +475,7 @@ val add_path_handler :
('a, Scanf.Scanning.in_channel,
'b, 'c -> string Request.t -> Response.t, 'a -> 'd, 'd) format6 ->
'c -> unit
[@@ocaml.deprecated "use add_route_handler instead"]
(** [add_path_handler server "/some/path/%s@/%d/" f]
calls [f "foo" 42 request] when a request with path "some/path/foo/42/"
is received.
@ -457,6 +497,13 @@ val add_path_handler :
filter uploads that are too large before the upload even starts.
*)
val add_route_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?meth:Meth.t ->
t ->
('a, string Request.t -> Response.t) Route.t -> 'a ->
unit
val add_path_handler_stream :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?meth:Meth.t ->
@ -464,12 +511,25 @@ val add_path_handler_stream :
('a, Scanf.Scanning.in_channel,
'b, 'c -> byte_stream Request.t -> Response.t, 'a -> 'd, 'd) format6 ->
'c -> unit
[@@ocaml.deprecated "use add_route_handler_stream instead"]
(** Similar to {!add_path_handler}, but where the body of the request
is a stream of bytes that has not been read yet.
This is useful when one wants to stream the body directly into a parser,
json decoder (such as [Jsonm]) or into a file.
@since 0.3 *)
val add_route_handler_stream :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?meth:Meth.t ->
t ->
('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.
This is useful when one wants to stream the body directly into a parser,
json decoder (such as [Jsonm]) or into a file.
@since NEXT_RELEASE *)
val stop : t -> unit
(** Ask the server to stop. This might not have an immediate effect
as {!run} might currently be waiting on IO. *)

30
src/Tiny_httpd_util.ml
View file

@ -80,6 +80,36 @@ let get_query s : string =
let split_query s = get_non_query_path s, get_query s
let split_on_slash s : _ list =
let l = ref [] in
let i = ref 0 in
let n = String.length s in
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;
);
i := n (* done *)
| j ->
if j > !i then (
l := String.sub s !i (j - !i) :: !l;
);
i := j+1;
done;
List.rev !l
(*$= & ~printer:Q.Print.(list string)
["a"; "b"] (split_on_slash "/a/b")
["coucou"; "lol"] (split_on_slash "/coucou/lol")
["a"; "b"; "c"] (split_on_slash "/a/b//c/")
["a"; "b"] (split_on_slash "//a/b/")
["a"] (split_on_slash "/a//")
[] (split_on_slash "/")
[] (split_on_slash "//")
*)
let parse_query s : (_ list, string) result=
let pairs = ref [] in
let is_sep_ = function '&' | ';' -> true | _ -> false in

4
src/Tiny_httpd_util.mli
View file

@ -17,6 +17,10 @@ val split_query : string -> string * string
(** Split a path between the path and the query
@since 0.5 *)
val split_on_slash : string -> string list
(** Split a string on ['/'], remove the trailing ['/'] if any.
@since NEXT_RELEASE *)
val get_non_query_path : string -> string
(** get the part of the path that is not the query parameters.
@since 0.5 *)

32
src/bin/http_of_dir.ml
View file

@ -39,8 +39,7 @@ let human_size (x:int) : string =
let header_html = "Content-Type", "text/html"
let (//) = Filename.concat
let encode_path s =
U.percent_encode ~skip:(fun c -> c='/') s
let encode_path s = U.percent_encode s
let is_hidden s = String.length s>0 && s.[0] = '.'
@ -56,7 +55,8 @@ let html_list_dir ~top ~parent d : string =
begin match parent with
| None -> ()
| Some p ->
Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n" p;
Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n"
(encode_path p);
end;
Printf.bprintf body "<ul>\n";
let hidden_stop = ref 0 in
@ -112,24 +112,26 @@ let serve ~config (dir:string) : _ result =
Printf.printf "serve directory %s on http://%(%s%):%d\n%!"
dir (if S.is_ipv6 server then "[%s]" else "%s") config.addr config.port;
if config.delete then (
S.add_path_handler server ~meth:`DELETE "/%s"
S.add_route_handler server ~meth:`DELETE
S.Route.(string_urlencoded @/ return)
(fun path _req ->
match U.percent_decode path with
| None -> S.Response.fail_raise ~code:404 "invalid percent encoding"
| Some path when contains_dot_dot path ->
if contains_dot_dot path then (
S.Response.fail_raise ~code:403 "invalid path in delete"
| Some path ->
) else (
S.Response.make_string
(try
Sys.remove (dir // path); Ok "file deleted successfully"
with e -> Error (500, Printexc.to_string e))
)
);
) else (
S.add_path_handler server ~meth:`DELETE "/%s"
S.add_route_handler server ~meth:`DELETE
S.Route.(string @/ return)
(fun _ _ -> S.Response.make_raw ~code:405 "delete not allowed");
);
if config.upload then (
S.add_path_handler_stream server ~meth:`PUT "/%s"
S.add_route_handler_stream server ~meth:`PUT
S.Route.(string_urlencoded @/ return)
~accept:(fun req ->
match S.Request.get_header_int req "Content-Length" with
| Some n when n > config.max_upload_size ->
@ -154,15 +156,13 @@ let serve ~config (dir:string) : _ result =
S.Response.make_raw ~code:201 "upload successful"
)
) else (
S.add_path_handler server ~meth:`PUT "/%s"
S.add_route_handler server ~meth:`PUT
S.Route.(string @/ return)
(fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed");
);
S.add_path_handler server ~meth:`GET "/%s"
S.add_route_handler server ~meth:`GET
S.Route.(string_urlencoded @/ return)
(fun path req ->
let path = match U.percent_decode path with
| None -> S.Response.fail_raise ~code:404 "invalid path"
| Some p -> p
in
let full_path = dir // path in
let mtime = lazy (
try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime

1
src/examples/dune
View file

@ -1,4 +1,5 @@
(executables
(names echo)
(flags :standard -warn-error -a+8)
(libraries tiny_httpd tiny_httpd_camlzip))

20
src/examples/echo.ml
View file

@ -13,10 +13,12 @@ let () =
let server = S.create ~port:!port_ ~max_connections:!j () in
Tiny_httpd_camlzip.setup server;
(* say hello *)
S.add_path_handler ~meth:`GET server
"/hello/%s@/" (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
S.add_path_handler ~meth:`GET server
"/zcat/%s" (fun path _req ->
S.add_route_handler ~meth:`GET server
S.Route.(exact "hello" @/ string @/ return)
(fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
S.add_route_handler ~meth:`GET server
S.Route.(exact "zcat" @/ string @/ return)
(fun path _req ->
let path = match Tiny_httpd_util.percent_decode path with
| Some s -> s
| None -> S.Response.fail_raise ~code:404 "invalid path %S" path
@ -36,16 +38,18 @@ let () =
S.Response.make_stream ~headers:mime_type (Ok str)
);
(* echo request *)
S.add_path_handler server
"/echo" (fun req ->
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)));
S.add_path_handler_stream ~meth:`PUT server
"/upload/%s" (fun path req ->
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