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

change API with accept pre-filter, use these before 100-continue

Browse source
This commit is contained in:
Simon Cruanes 2019-11-17 16:52:30 -06:00
parent 833a523cab
commit 193a9d9d31
4 changed files with 109 additions and 64 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
README.md
View file

@ -15,10 +15,10 @@ let () =
let server = S.create () in let server = S.create () in
(* say hello *) (* say hello *)
S.add_path_handler ~meth:`GET server S.add_path_handler ~meth:`GET server
"/hello/%s@/" (fun _req name () -> S.Response.make_ok ("hello " ^name ^"!\n")); "/hello/%s@/" (fun name _req -> S.Response.make_ok ("hello " ^name ^"!\n"));
(* echo request *) (* echo request *)
S.add_path_handler server S.add_path_handler server
"/echo" (fun req () -> S.Response.make_ok (Format.asprintf "echo:@ %a@." S.Request.pp req)); "/echo" (fun req -> S.Response.make_ok (Format.asprintf "echo:@ %a@." S.Request.pp req));
Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server); Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
match S.run server with match S.run server with
| Ok () -> () | Ok () -> ()
@ -34,7 +34,7 @@ $ curl -X GET http://localhost:8080/hello/quadrarotaphile
hello quadrarotaphile! hello quadrarotaphile!
# the path "echo" just prints the request. # the path "echo" just prints the request.
$ curl -X GET http://localhost:8080/echo --data "coucou lol" $ curl -X GET http://localhost:8080/echo --data "howdy y'all"
echo: echo:
{meth=GET; {meth=GET;
headers=Host: localhost:8080 headers=Host: localhost:8080
@ -42,7 +42,7 @@ echo:
Accept: */* Accept: */*
Content-Length: 10 Content-Length: 10
Content-Type: application/x-www-form-urlencoded; Content-Type: application/x-www-form-urlencoded;
path="/echo"; body="coucou lol"} path="/echo"; body="howdy y'all"}
``` ```
@ -55,7 +55,7 @@ It serves files from the current directory.
$ http_of_dir . -p 8080 & $ http_of_dir . -p 8080 &
$ curl -X GET http://localhost:8080 $ curl -X GET http://localhost:8080
... ...
some html <html list of current dir>
... ...
``` ```

115
src/Tiny_httpd.ml
View file

@ -8,13 +8,17 @@ type input_stream = {
exception Bad_req of int * string exception Bad_req of int * string
let bad_reqf c fmt = Printf.ksprintf (fun s ->raise (Bad_req (c,s))) fmt let bad_reqf c fmt = Printf.ksprintf (fun s ->raise (Bad_req (c,s))) fmt
let _debug_on = ref (
match String.trim @@ Sys.getenv "HTTP_DBG" with
| "" -> false | _ -> true | exception _ -> false
)
let _enable_debug b = _debug_on := b
let _debug k = let _debug k =
match Sys.getenv "HTTP_DBG" with if !_debug_on then (
| _ ->
k (fun fmt-> k (fun fmt->
Printf.fprintf stdout "[thread %d]: " Thread.(id @@ self()); Printf.fprintf stdout "[thread %d]: " Thread.(id @@ self());
Printf.kfprintf (fun oc -> Printf.fprintf oc "\n%!") stdout fmt) Printf.kfprintf (fun oc -> Printf.fprintf oc "\n%!") stdout fmt)
| exception _ -> () )
module Response_code = struct module Response_code = struct
type t = int type t = int
@ -85,11 +89,11 @@ module Headers = struct
end end
module Request = struct module Request = struct
type t = { type 'body t = {
meth: Meth.t; meth: Meth.t;
headers: Headers.t; headers: Headers.t;
path: string; path: string;
body: string body: 'body;
} }
let headers self = self.headers let headers self = self.headers
@ -97,6 +101,11 @@ module Request = struct
let path self = self.path let path self = self.path
let body self = self.body let body self = self.body
let get_header self h = Headers.get 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 pp out self : unit = let pp out self : unit =
Format.fprintf out "{@[meth=%s;@ headers=%a;@ path=%S;@ body=%S@]}" Format.fprintf out "{@[meth=%s;@ headers=%a;@ path=%S;@ body=%S@]}"
(Meth.to_string self.meth) Headers.pp self.headers (Meth.to_string self.meth) Headers.pp self.headers
@ -115,8 +124,8 @@ module Request = struct
done; done;
Bytes.sub_string is.buf 0 n Bytes.sub_string is.buf 0 n
let read_body_chunked (is:input_stream) : string = let read_body_chunked ~size:max_size (is:input_stream) : string =
_debug (fun k->k "read body with chunked encoding"); _debug (fun k->k "read body with chunked encoding (max-size: %d)" max_size);
let n = ref 0 in let n = ref 0 in
let rec read_chunks () = let rec read_chunks () =
let line = input_line is.ic in let line = input_line is.ic in
@ -132,6 +141,12 @@ module Request = struct
Bytes.sub_string is.buf 0 !n (* done *) Bytes.sub_string is.buf 0 !n (* done *)
) else ( ) else (
let new_size = chunk_size + !n in let new_size = chunk_size + !n in
(* is the body bigger than expected? *)
if max_size>0 && new_size > max_size then (
bad_reqf 400
"body size was supposed to be %d, but at least %d bytes received"
max_size new_size
);
(* resize buffer if needed *) (* resize buffer if needed *)
if Bytes.length is.buf < new_size then ( if Bytes.length is.buf < new_size then (
let new_buf = Bytes.make (new_size + 10) ' ' in let new_buf = Bytes.make (new_size + 10) ' ' in
@ -150,7 +165,7 @@ module Request = struct
read_chunks() read_chunks()
(* parse request, but not body (yet) *) (* parse request, but not body (yet) *)
let parse_req_start (is:input_stream) : t option resp_result = let parse_req_start (is:input_stream) : unit t option resp_result =
try try
let line = input_line is.ic in let line = input_line is.ic in
let meth, path = let meth, path =
@ -160,7 +175,7 @@ module Request = struct
let meth = Meth.of_string meth in let meth = Meth.of_string meth in
let headers = Headers.parse_ is in let headers = Headers.parse_ is in
_debug (fun k->k "got meth: %s, path %S" (Meth.to_string meth) path); _debug (fun k->k "got meth: %s, path %S" (Meth.to_string meth) path);
Ok (Some {meth; path; headers; body=""}) Ok (Some {meth; path; headers; body=()})
with with
| End_of_file | Sys_error _ -> Ok None | End_of_file | Sys_error _ -> Ok None
| Bad_req (c,s) -> Error (c,s) | Bad_req (c,s) -> Error (c,s)
@ -168,19 +183,21 @@ module Request = struct
Error (400, Printexc.to_string e) Error (400, Printexc.to_string e)
(* parse body, given the headers *) (* parse body, given the headers *)
let parse_body_ (is:input_stream) (req:t) : t resp_result = let parse_body_ (is:input_stream) (req:_ t) : string t resp_result =
try try
let body = match List.assoc "Content-Length" req.headers |> int_of_string with let n =
| 0 -> "" match List.assoc "Content-Length" req.headers |> int_of_string with
| n -> read_body is n (* body of fixed size *) | n -> n (* body of fixed size *)
| exception Not_found -> | exception Not_found -> 0
begin match List.assoc "Transfer-Encoding" req.headers |> String.trim with
| "chunked" -> read_body_chunked is (* body sent by chunks *)
| s -> bad_reqf 500 "cannot handle transfer encoding: %s" s
| exception Not_found -> ""
end
| exception _ -> bad_reqf 400 "invalid content-length" | exception _ -> bad_reqf 400 "invalid content-length"
in in
let body =
match List.assoc "Transfer-Encoding" req.headers |> String.trim with
| "chunked" -> read_body_chunked ~size:n is (* body sent by chunks *)
| s -> bad_reqf 500 "cannot handle transfer encoding: %s" s
| exception Not_found ->
read_body is n
in
Ok {req with body} Ok {req with body}
with with
| End_of_file -> Error (400, "unexpected end of file") | End_of_file -> Error (400, "unexpected end of file")
@ -224,6 +241,8 @@ module Response = struct
let fail ?headers ~code fmt = let fail ?headers ~code fmt =
Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt
let fail_raise ~code fmt =
Printf.ksprintf (fun msg -> raise (Bad_req (code,msg))) fmt
let pp out self : unit = let pp out self : unit =
let pp_body out = function let pp_body out = function
@ -263,32 +282,44 @@ module Response = struct
flush oc flush oc
end end
type cb_path_handler = string Request.t -> Response.t
type t = { type t = {
addr: string; addr: string;
port: int; port: int;
fork: (unit -> unit) -> unit; fork: (unit -> unit) -> unit;
masksigpipe: bool; masksigpipe: bool;
mutable handler: (Request.t -> Response.t); mutable handler: (string Request.t -> Response.t);
mutable path_handlers : (Request.t -> (unit -> Response.t) option) list; mutable path_handlers : (unit Request.t -> cb_path_handler resp_result option) list;
mutable req_cbs: (Request.t -> Request.t option) list; mutable cb_decode_req: (string Request.t -> string Request.t option) list;
mutable res_cbs: (Request.t -> Response.t -> Response.t option) list; mutable cb_encode_resp: (string Request.t -> Response.t -> Response.t option) list;
mutable running: bool; mutable running: bool;
} }
let addr self = self.addr let addr self = self.addr
let port self = self.port let port self = self.port
let add_request_cb self f = self.req_cbs <- f :: self.req_cbs let add_decode_request_cb self f = self.cb_decode_req <- f :: self.cb_decode_req
let add_response_cb self f = self.res_cbs <- f :: self.res_cbs let add_encode_response_cb self f = self.cb_encode_resp <- f :: self.cb_encode_resp
let set_top_handler self f = self.handler <- f let set_top_handler self f = self.handler <- f
let add_path_handler ?meth self fmt f = let add_path_handler
let ph req: (unit -> Response.t) option = ?(accept=fun _req -> Ok ())
?meth self fmt f =
let ph req: cb_path_handler resp_result option =
match meth with match meth with
| Some m when m <> req.Request.meth -> None (* ignore *) | Some m when m <> req.Request.meth -> None (* ignore *)
| _ -> | _ ->
try Some (Scanf.sscanf req.Request.path fmt (f req)) begin match Scanf.sscanf req.Request.path fmt f with
with _ -> None | handler ->
(* we have a handler, do we accept the request based on its headers? *)
begin match accept req with
| Ok () -> Some (Ok handler)
| Error _ as e -> Some e
end
| exception _ ->
None (* path didn't match *)
end
in in
self.path_handlers <- ph :: self.path_handlers self.path_handlers <- ph :: self.path_handlers
@ -299,7 +330,7 @@ let create
let handler _req = Response.fail ~code:404 "no top handler" in let handler _req = Response.fail ~code:404 "no top handler" in
{ fork; addr; port; masksigpipe; handler; running= true; { fork; addr; port; masksigpipe; handler; running= true;
path_handlers=[]; path_handlers=[];
req_cbs=[]; res_cbs=[]; cb_encode_resp=[]; cb_decode_req=[];
} }
let stop s = s.running <- false let stop s = s.running <- false
@ -318,8 +349,6 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit =
let oc = Unix.out_channel_of_descr client_sock in let oc = Unix.out_channel_of_descr client_sock in
(* wrap [ic] in a stream with a reusable buffer *) (* wrap [ic] in a stream with a reusable buffer *)
let is = {ic; buf=Bytes.make 1024 ' '} in let is = {ic; buf=Bytes.make 1024 ' '} in
let handler = self.handler in
let ph_handlers = self.path_handlers in
let continue = ref true in let continue = ref true in
while !continue && self.running do while !continue && self.running do
_debug (fun k->k "read next request"); _debug (fun k->k "read next request");
@ -331,6 +360,12 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit =
| Ok (Some req) -> | Ok (Some req) ->
let res = let res =
try try
(* is there a handler for this path? *)
let handler =
match find_map (fun ph -> ph req) self.path_handlers with
| Some f -> unwrap_resp_result f
| None -> self.handler
in
(* handle expectations *) (* handle expectations *)
begin match List.assoc "Expect" req.Request.headers with begin match List.assoc "Expect" req.Request.headers with
| "100-continue" -> | "100-continue" ->
@ -341,23 +376,19 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit =
end; end;
(* modify request by reading body *) (* modify request by reading body *)
let req = Request.parse_body_ is req |> unwrap_resp_result in let req = Request.parse_body_ is req |> unwrap_resp_result in
(* request callbacks *) (* preprocess query *)
let req = let req =
List.fold_left List.fold_left
(fun req cb -> match cb req with None -> req | Some r' -> r') (fun req cb -> match cb req with None -> req | Some r' -> r')
req self.req_cbs req self.cb_decode_req
in in
let run_handler = let resp = handler req in
match find_map (fun ph -> ph req) ph_handlers with (* post-process response *)
| Some f -> f
| None -> (fun () -> handler req)
in
let resp = run_handler() in
(* response callbacks *)
List.fold_left List.fold_left
(fun resp cb -> match cb req resp with None -> resp | Some r' -> r') (fun resp cb -> match cb req resp with None -> resp | Some r' -> r')
resp self.res_cbs resp self.cb_encode_resp
with with
| Bad_req _ as e -> raise e
| e -> | e ->
Response.fail ~code:500 "server error: %s" (Printexc.to_string e) Response.fail ~code:500 "server error: %s" (Printexc.to_string e)
in in

42
src/Tiny_httpd.mli
View file

@ -20,19 +20,21 @@ module Headers : sig
end end
module Request : sig module Request : sig
type t = { type 'body t = {
meth: Meth.t; meth: Meth.t;
headers: Headers.t; headers: Headers.t;
path: string; path: string;
body: string body: 'body;
} }
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> string t -> unit
val headers : t -> Headers.t val headers : _ t -> Headers.t
val meth : t -> Meth.t val get_header : _ t -> string -> string option
val path : t -> string val get_header_int : _ t -> string -> int option
val body : t -> string val meth : _ t -> Meth.t
val path : _ t -> string
val body : 'b t -> 'b
end end
module Response_code : sig module Response_code : sig
@ -67,10 +69,15 @@ module Response : sig
Example: [fail ~code:404 "oh noes, %s not found" "waldo"] Example: [fail ~code:404 "oh noes, %s not found" "waldo"]
*) *)
val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a
(** Similar to {!fail} but raises an exception that exits the current handler.
This should not be used outside of a (path) handler.
Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()]
*)
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
end end
type t type t
val create : val create :
@ -84,25 +91,28 @@ val create :
val addr : t -> string val addr : t -> string
val port : t -> int val port : t -> int
val add_request_cb : t -> (Request.t -> Request.t option) -> unit val add_decode_request_cb : t -> (string Request.t -> string Request.t option) -> unit
(** Add a callback for every request. (** Add a callback for every request.
The callback can modify the request by returning [Some r'] where [r'] The callback can modify the request by returning [Some r'] where [r']
is the new request, or just perform side effects (logging?) and return [None]. is the new request, or just perform side effects (logging?) and return [None].
*) *)
val add_response_cb : t -> (Request.t -> Response.t -> Response.t option) -> unit val add_encode_response_cb: t -> (string Request.t -> Response.t -> Response.t option) -> unit
(** Add a callback for every request/response pair. (** Add a callback for every request/response pair.
Similarly to {!add_request_cb} the callback can modify the response. *) Similarly to {!add_encode_response_cb} the callback can return a new
response, for example to compress it. *)
val set_top_handler : t -> (Request.t -> Response.t) -> unit val set_top_handler : t -> (string Request.t -> Response.t) -> unit
(** Setup a handler called by default. (** Setup a handler called by default.
If not installed, unhandled paths will return a 404 not found. *) If not installed, unhandled paths will return a 404 not found. *)
val add_path_handler : val add_path_handler :
?accept:(unit Request.t -> (unit, Response_code.t * string) result) ->
?meth:Meth.t -> ?meth:Meth.t ->
t -> t ->
('a, Scanf.Scanning.in_channel, 'b, 'c -> unit -> Response.t, 'a -> 'd, 'd) format6 -> ('a, Scanf.Scanning.in_channel,
(Request.t -> 'c) -> unit 'b, 'c -> string Request.t -> Response.t, 'a -> 'd, 'd) format6 ->
'c -> unit
(** [add_path_handler server "/some/path/%s@/%d/" f] (** [add_path_handler server "/some/path/%s@/%d/" f]
calls [f request "foo" 42 ()] when a request with path "some/path/foo/42/" calls [f request "foo" 42 ()] when a request with path "some/path/foo/42/"
is received. is received.
@ -111,6 +121,9 @@ val add_path_handler :
scope with a ["@/"] delimiter. The "@" before a character indicates it's scope with a ["@/"] delimiter. The "@" before a character indicates it's
a separator. a separator.
@param meth if provided, only accept requests with the given method @param meth if provided, only accept requests with the given method
@param accept should return [true] if the given request (before its body
is read) should be accepted, [false] if it's to be rejected (e.g. because
its content is too big, or for some permission error).
*) *)
val stop : t -> unit val stop : t -> unit
@ -120,6 +133,7 @@ val run : t -> (unit, exn) result
(**/**) (**/**)
val _debug : ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit val _debug : ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit
val _enable_debug: bool -> unit
(**/**) (**/**)

6
src/examples/echo.ml
View file

@ -10,12 +10,12 @@ let () =
let server = S.create () in let server = S.create () in
(* say hello *) (* say hello *)
S.add_path_handler ~meth:`GET server S.add_path_handler ~meth:`GET server
"/hello/%s@/" (fun _req name () -> S.Response.make (Ok ("hello " ^name ^"!\n"))); "/hello/%s@/" (fun name _req -> S.Response.make (Ok ("hello " ^name ^"!\n")));
(* echo request *) (* echo request *)
S.add_path_handler server S.add_path_handler server
"/echo" (fun req () -> S.Response.make (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req))); "/echo" (fun req -> S.Response.make (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req)));
S.add_path_handler ~meth:`PUT server S.add_path_handler ~meth:`PUT server
"/upload/%s" (fun req path () -> "/upload/%s" (fun path req ->
debug_ (fun k->k "start upload %S\n%!" path); debug_ (fun k->k "start upload %S\n%!" path);
try try
let oc = open_out @@ "/tmp/" ^ path in let oc = open_out @@ "/tmp/" ^ path in