diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index 3ff6347a..7b0cfe67 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -2,14 +2,209 @@ type input_stream = (bytes -> int -> int -> int) * (unit -> unit) (** An input stream is a function to read bytes into a buffer, and a function to close *) -type output_stream = (bytes -> int -> int -> unit) * (unit -> unit) * (unit -> unit) +type output_stream = (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) (** An output stream is a function to output bytes, a function to [flush], and a function to close. *) -module Input_stream = struct +module Buf_ = struct + type t = { + mutable bytes: bytes; + mutable i: int; + } + let create ?(size=4_096) () : t = + { bytes=Bytes.make size ' '; i=0 } + + let size self = self.i + let clear self : unit = + 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 = + let new_buf = Bytes.make new_size ' ' in + Bytes.blit self.bytes 0 new_buf 0 self.i; + self.bytes <- new_buf + + let ensure_size self n : unit = + if Bytes.length self.bytes < n then ( + resize self n; + ) + + let add_string (self:t) s i len : unit = + if Bytes.length self.bytes < self.i + len then ( + resize self (self.i + self.i / 8 + len + 10); + ); + Bytes.blit_string s i self.bytes self.i len; + self.i <- self.i + len + + let read_once (self:t) ~read : int = + (* resize if needed *) + if self.i = Bytes.length self.bytes then ( + resize self (self.i + self.i / 8 + 10); + ); + let n_rd = read self.bytes self.i (Bytes.length self.bytes - self.i) in + self.i <- self.i + n_rd; + n_rd + + (* remove the first [i] bytes *) + let remove_prefix (self:t) (i:int) : unit = + if i > self.i then invalid_arg "Buf_.contents_slice"; + if i self.i then invalid_arg "Buf_.contents_slice"; + Bytes.sub_string self.bytes i len + + let contents_and_clear (self:t) : string = + let x = contents self in + clear self; + x end +module Input_stream = struct + type t = input_stream + + let close (_,cl : t) = cl () + let of_chan ic : t = input ic, fun () -> close_in ic + let of_chan_close_noerr ic : t = input ic, fun () -> close_in_noerr ic + + let of_buf_ ?(i=0) ?len ~get_len ~blit s : t = + let off = ref i in + let s_len = match len with + | Some n -> min n (get_len s-i) + | None -> get_len s-i + in + let read buf i len = + let n = min len (s_len - !off) in + if n > 0 then ( + blit s !off buf i n; + off := !off + n; + ); + n + in + read, (fun () -> ()) + + let of_string ?i ?len s : t = + of_buf_ ?i ?len ~get_len:String.length ~blit:Bytes.blit_string s + + let of_bytes ?i ?len s : t = + of_buf_ ?i ?len ~get_len:Bytes.length ~blit:Bytes.blit s + + let with_file file f = + let ic = open_in file in + try + let x = f (of_chan_close_noerr ic) in + close_in ic; + x + with e -> + close_in_noerr ic; + raise e + + let read_all ?(buf=Buf_.create()) (self:t) : string = + let (read, _) = self in + let continue = ref true in + while !continue do + let n_rd = Buf_.read_once buf ~read in + if n_rd = 0 then ( + continue := false + ) + done; + Buf_.contents_and_clear buf + + let read_exactly ~too_short ?buf (self:t) (n:int) : unit = + let buf = match buf with + | Some buf -> + Buf_.ensure_size buf n; + buf + | None -> Buf_.create ~size:n () + in + let i = ref 0 in + while !i < n do + let is_read, _ = self in + let n_read = is_read buf.bytes !i (n- !i) in + if n_read=0 then too_short(); + i := !i + n_read + done + + let read_line ?(buf=Buf_.create()) (self:t) : string = + let rec read_chunk acc = + Buf_.clear buf; + let is_read, _ = self in + let _n = Buf_.read_once buf ~read:is_read in + match Bytes.index buf.Buf_.bytes '\n' with + | i -> + let s = Buf_.contents_slice buf 0 i in + Buf_.remove_prefix buf (i+1); + s :: acc + | exception Not_found -> + read_chunk (Buf_.contents_and_clear buf :: acc) + in + match read_chunk [] with + | [] -> "" + | [s] -> s + | [s1;s2] -> s1^s2 + | l -> String.concat "" l + +end + +module Output_stream = struct + type t = output_stream + + let of_chan oc : t = + (output_substring oc, (fun () -> flush oc), (fun () -> close_out oc)) + + let of_chan_close_noerr oc : t = + (output_substring oc, (fun () -> flush oc), (fun () -> close_out_noerr oc)) + + let of_buf (buf:Buf_.t) : t = + let wr b i len = + Buf_.add_string buf b i len + in + (wr, (fun()->()), (fun()->())) + + let with_file file f = + let oc = open_out file in + try + let x = f (of_chan_close_noerr oc) in + close_out oc; + x + with e -> + close_out_noerr oc; + raise e + + let write (self:t) s = + let wr, _, _ = self in + wr s 0 (String.length s) + let flush self : unit = let _, fl, _ = self in fl() + let close self : unit = let _, _, cl = self in cl() +end + +let pipe ?(buf=Buf_.create()) (is:input_stream) (os:output_stream) : unit = + let continue = ref true in + while !continue do + Buf_.clear buf; + let rd, _ = is in + let n = Buf_.read_once buf ~read:rd in + if n=0 then ( + continue := false + ) else ( + let wr, _, _ = os in + wr (Bytes.unsafe_to_string buf.bytes) 0 n + ) + done; + Output_stream.flush os; + Input_stream.close is; + Output_stream.close os; + () + + exception Bad_req of int * string let bad_reqf c fmt = Printf.ksprintf (fun s ->raise (Bad_req (c,s))) fmt @@ -28,6 +223,8 @@ let _debug k = module Response_code = struct type t = int + let ok = 200 + let not_found = 404 let descr = function | 100 -> "Continue" | 200 -> "OK" @@ -50,7 +247,7 @@ module Response_code = struct | 500 -> "Internal server error" | 501 -> "Not implemented" | 503 -> "Service unavailable" - | _ -> "Unknown response" (* TODO *) + | n -> "Unknown response code " ^ string_of_int n (* TODO *) end type 'a resp_result = ('a, Response_code.t * string) result @@ -93,9 +290,9 @@ module Headers = struct let pp_pair out (k,v) = Format.fprintf out "@[%s: %s@]" k v in Format.fprintf out "@[%a@]" (Format.pp_print_list pp_pair) l - let parse_ (is:input_stream) : t = + let parse_ ~buf (is:input_stream) : t = let rec loop acc = - let line = input_line is.ic in + let line = Input_stream.read_line ~buf is in if line = "\r" then ( List.rev acc ) else ( @@ -132,24 +329,18 @@ module Request = struct (Meth.to_string self.meth) Headers.pp self.headers self.path self.body - let read_body (is:input_stream) (n:int) : string = + let read_body ~buf (is:input_stream) (n:int) : string = _debug (fun k->k "read body of size %d" n); - if Bytes.length is.buf < n then ( - is.buf <- Bytes.make n ' '; - ); - let i = ref 0 in - while !i < n do - let read = input is.ic is.buf !i (n- !i) in - if read=0 then bad_reqf 400 "body is too short"; - i := !i + read - done; - Bytes.sub_string is.buf 0 n + Input_stream.read_exactly ~buf is n + ~too_short:(fun () -> bad_reqf 400 "body is too short"); + Buf_.contents_and_clear buf - let read_body_chunked ~size:max_size (is:input_stream) : string = + let read_body_chunked ~buf:buf_line ~size:max_size (is:input_stream) : string = _debug (fun k->k "read body with chunked encoding (max-size: %d)" max_size); - let n = ref 0 in + let buf_res = Buf_.create() in (* store the accumulated chunks *) let rec read_chunks () = - let line = input_line is.ic in + Buf_.clear buf_line; + let line = Input_stream.read_line ~buf:buf_line is in (* parse chunk length, ignore extensions *) let chunk_size = if String.trim line = "" then 0 @@ -159,42 +350,34 @@ module Request = struct in _debug (fun k->k "chunk size: %d" chunk_size); if chunk_size = 0 then ( - Bytes.sub_string is.buf 0 !n (* done *) + Buf_.contents buf_res (* done *) ) else ( - let new_size = chunk_size + !n in + let new_size = chunk_size + Buf_.size buf_res in (* is the body bigger than expected? *) if max_size>0 && new_size > max_size then ( bad_reqf 413 "body size was supposed to be %d, but at least %d bytes received" max_size new_size ); - (* resize buffer if needed *) - if Bytes.length is.buf < new_size then ( - let new_buf = Bytes.make (new_size + 10) ' ' in - Bytes.blit is.buf 0 new_buf 0 !n; - is.buf <- new_buf; - ); - while !n < new_size do - let read = input is.ic is.buf !n (new_size - !n) in - if read=0 then bad_reqf 400 "body is too short"; - n := !n + read - done; - _debug (fun k->k "read a chunk"); + Input_stream.read_exactly + ~too_short:(fun () -> bad_reqf 400 "chunk is too short") + is ~buf:buf_res chunk_size; + _debug (fun k->k "read a chunk of size %d" chunk_size); read_chunks() ) in read_chunks() (* parse request, but not body (yet) *) - let parse_req_start (is:input_stream) : unit t option resp_result = + let parse_req_start ~buf (is:input_stream) : unit t option resp_result = try - let line = input_line is.ic in + let line = Input_stream.read_line ~buf is in let meth, path = try Scanf.sscanf line "%s %s HTTP/1.1\r" (fun x y->x,y) with _ -> raise (Bad_req (400, "Invalid request line")) in let meth = Meth.of_string meth in - let headers = Headers.parse_ is in + let headers = Headers.parse_ ~buf is in _debug (fun k->k "got meth: %s, path %S" (Meth.to_string meth) path); Ok (Some {meth; path; headers; body=()}) with @@ -204,7 +387,7 @@ module Request = struct Error (400, Printexc.to_string e) (* parse body, given the headers *) - let parse_body_ (is:input_stream) (req:_ t) : string t resp_result = + let parse_body_ ~buf (req:input_stream t) : string t resp_result = try let n = match List.assoc "Content-Length" req.headers |> int_of_string with @@ -214,10 +397,10 @@ module Request = struct in let body = match List.assoc "Transfer-Encoding" req.headers |> String.trim with - | "chunked" -> read_body_chunked ~size:n is (* body sent by chunks *) + | "chunked" -> read_body_chunked ~buf ~size:n req.body (* body sent by chunks *) | s -> bad_reqf 500 "cannot handle transfer encoding: %s" s | exception Not_found -> - read_body is n + read_body ~buf req.body n in Ok {req with body} with @@ -225,15 +408,18 @@ module Request = struct | Bad_req (c,s) -> Error (c,s) | e -> Error (400, Printexc.to_string e) + + let read_body_full ?buf (self:input_stream t) : string t = + try + let body = Input_stream.read_all ?buf self.body in + { self with body } + with + | Bad_req _ as e -> raise e + | e -> bad_reqf 500 "failed to read body: %s" (Printexc.to_string e) end module Response = struct - type out_stream = bytes -> int -> int -> int - type body = [ - | `String of string - | `Stream of out_stream - ] - + type body = [`String of string | `Stream of input_stream] type t = { code: Response_code.t; headers: Headers.t; @@ -250,15 +436,23 @@ module Response = struct in { code; headers; body=`String body; } - let make_raw_chunked ?(headers=[]) ~code body : t = + let make_raw_stream ?(headers=[]) ~code body : t = (* add content length to response *) let headers = Headers.set "Transfer-Encoding" "chunked" headers in { code; headers; body=`Stream body; } - let make ?headers r : t = match r with + let make_string ?headers r = match r with | Ok body -> make_raw ?headers ~code:200 body - | Error (code,msg) -> - make_raw ?headers ~code msg + | Error (code,msg) -> make_raw ?headers ~code msg + + let make_stream ?headers r = match r with + | Ok body -> make_raw_stream ?headers ~code:200 body + | Error (code,msg) -> make_raw ?headers ~code msg + + let make ?headers r : t = match r with + | Ok (`String body) -> make_raw ?headers ~code:200 body + | Ok (`Stream body) -> make_raw_stream ?headers ~code:200 body + | Error (code,msg) -> make_raw ?headers ~code msg let fail ?headers ~code fmt = Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt @@ -274,18 +468,20 @@ module Response = struct self.code Headers.pp self.headers pp_body self.body (* print a stream as a series of chunks *) - let output_stream_ (oc:out_channel) (str:out_stream) : unit = - let buf = Bytes.make 4096 ' ' in + let output_stream_ (oc:out_channel) (str:input_stream) : unit = + let buf = Buf_.create ~size:4096 () in let continue = ref true in while !continue do + Buf_.clear buf; (* next chunk *) - let n = str buf 0 (Bytes.length buf) in + let read, _ = str in + let n = Buf_.read_once buf ~read in _debug (fun k->k "send chunk of size %d" n); Printf.fprintf oc "%x\r\n" n; if n = 0 then ( continue := false; ) else ( - output oc buf 0 n; + output oc buf.bytes 0 n; ); output_string oc "\r\n"; done; @@ -308,11 +504,11 @@ type cb_path_handler = string Request.t -> Response.t type t = { addr: string; port: int; - fork: (unit -> unit) -> unit; + new_thread: (unit -> unit) -> unit; masksigpipe: bool; mutable handler: (string Request.t -> Response.t); mutable path_handlers : (unit Request.t -> cb_path_handler resp_result option) list; - mutable cb_decode_req: (string Request.t -> string Request.t option) list; + mutable cb_decode_req: (input_stream Request.t -> input_stream Request.t option) list; mutable cb_encode_resp: (string Request.t -> Response.t -> Response.t option) list; mutable running: bool; } @@ -346,10 +542,10 @@ let add_path_handler let create ?(masksigpipe=true) - ?(fork=(fun f -> ignore (Thread.create f () : Thread.t))) + ?(new_thread=(fun f -> ignore (Thread.create f () : Thread.t))) ?(addr="127.0.0.1") ?(port=8080) () : t = let handler _req = Response.fail ~code:404 "no top handler" in - { fork; addr; port; masksigpipe; handler; running= true; + { new_thread; addr; port; masksigpipe; handler; running= true; path_handlers=[]; cb_encode_resp=[]; cb_decode_req=[]; } @@ -368,12 +564,12 @@ let find_map f l = let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit = let ic = Unix.in_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 *) - let is = {ic; buf=Bytes.make 1024 ' '} in + let buf = Buf_.create() in + let is = Input_stream.of_chan ic in let continue = ref true in while !continue && self.running do _debug (fun k->k "read next request"); - match Request.parse_req_start is with + match Request.parse_req_start ~buf is with | Ok None -> continue := false | Error (c,s) -> let res = Response.make_raw ~code:c s in @@ -395,14 +591,15 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit = | s -> bad_reqf 417 "unknown expectation %s" s | exception Not_found -> () end; - (* modify request by reading body *) - let req = Request.parse_body_ is req |> unwrap_resp_result in - (* preprocess query *) + (* preprocess request's input stream *) + let req = {req with body=is} in let req = List.fold_left (fun req cb -> match cb req with None -> req | Some r' -> r') req self.cb_decode_req in + (* now actually read request's body *) + let req = Request.parse_body_ ~buf req |> unwrap_resp_result in let resp = handler req in (* post-process response *) List.fold_left @@ -439,7 +636,7 @@ let run (self:t) : (unit,_) result = Unix.listen sock 10; while self.running do let client_sock, _ = Unix.accept sock in - self.fork + self.new_thread (fun () -> handle_client_ self client_sock); done; Ok () diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index ab94e536..df6a454b 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -2,24 +2,51 @@ type input_stream = (bytes -> int -> int -> int) * (unit -> unit) (** An input stream is a function to read bytes into a buffer, and a function to close *) -type output_stream = (bytes -> int -> int -> unit) * (unit -> unit) * (unit -> unit) +type output_stream = (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) (** An output stream is a function to output bytes, a function to [flush], and a function to close. *) +(** {2 Tiny buffer implementation} *) +module Buf_ : sig + type t + val clear : t -> unit + val create : ?size:int -> unit -> t + val contents : t -> string +end + +(** {2 Generic input stream} *) module Input_stream : sig type t = input_stream val of_chan : in_channel -> t - val of_string : string -> t - val of_bytes : bytes -> t + val of_chan_close_noerr : in_channel -> t + val of_string : ?i:int -> ?len:int -> string -> t + val of_bytes : ?i:int -> ?len:int -> bytes -> t + val close : t -> unit + val with_file : string -> (t -> 'a) -> 'a + (** Open a file with given name, and obtain an input stream *) + + val read_line : ?buf:Buf_.t -> t -> string + val read_all : ?buf:Buf_.t -> t -> string end +(** {2 Generic output stream} *) module Output_stream : sig type t = output_stream - val of_chan : out_channel -> t + val of_chan_close_noerr : out_channel -> t + val of_buf : Buf_.t -> t + val write : t -> string -> unit + val flush : t -> unit + val close : t -> unit + + val with_file : string -> (t -> 'a) -> 'a + (** Open a file with given name, and obtain an output stream *) end +val pipe : ?buf:Buf_.t -> input_stream -> output_stream -> unit +(** [pipe is os] pipes the content of [is] into [os]. *) + module Meth : sig type t = [ | `GET @@ -57,16 +84,18 @@ module Request : sig val meth : _ t -> Meth.t val path : _ t -> string val body : 'b t -> 'b + val read_body_full : ?buf:Buf_.t -> input_stream t -> string t end module Response_code : sig type t = int - + val ok : t + val not_found : t val descr : t -> string end module Response : sig - type out_stream = bytes -> int -> int -> int + type body = [`String of string | `Stream of input_stream] type t val make_raw : @@ -75,16 +104,24 @@ module Response : sig string -> t - val make_raw_chunked : + val make_raw_stream : ?headers:Headers.t -> code:Response_code.t -> - out_stream -> + input_stream -> t val make : + ?headers:Headers.t -> + (body, Response_code.t * string) result -> t + + val make_string : ?headers:Headers.t -> (string, Response_code.t * string) result -> t + val make_stream : + ?headers:Headers.t -> + (input_stream, Response_code.t * string) result -> t + val fail : ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a (** Make the current request fail with the given code and message. @@ -104,25 +141,32 @@ type t val create : ?masksigpipe:bool -> - ?fork:((unit -> unit) -> unit) -> + ?new_thread:((unit -> unit) -> unit) -> ?addr:string -> ?port:int -> unit -> t +(** TODO: document *) val addr : t -> string val port : t -> int -val add_decode_request_cb : t -> (string Request.t -> string Request.t option) -> unit +val add_decode_request_cb : + t -> + (input_stream Request.t -> input_stream Request.t option) -> unit (** Add a callback for every request. 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]. *) -val add_encode_response_cb: t -> (string 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. Similarly to {!add_encode_response_cb} the callback can return a new - response, for example to compress it. *) + response, for example to compress it. + The callback is given the fully parsed query as well as the current + response. +*) val set_top_handler : t -> (string Request.t -> Response.t) -> unit (** Setup a handler called by default. @@ -149,8 +193,13 @@ val add_path_handler : *) val stop : t -> unit -val run : t -> (unit, exn) result +(** Ask the server to stop. This might not have an immediate effect + as {!run} might currently be waiting on IO. *) +val run : t -> (unit, exn) result +(** Run the main loop of the server, listening on a socket + described at the server's creation time, using [new_thread] to + start a thread for each new client. *) (**/**) diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 7f9819f2..af03327b 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -63,7 +63,7 @@ let serve ~config (dir:string) : _ result = if contains_dot_dot path then ( S.Response.fail_raise ~code:403 "invalid path in delete" ); - S.Response.make + S.Response.make_string (try Sys.remove (dir // path); Ok "file deleted successfully" with e -> Error (500, Printexc.to_string e)) @@ -114,11 +114,11 @@ let serve ~config (dir:string) : _ result = let parent = Filename.(dirname path) in let parent = if parent <> path then Some parent else None in let body = html_list_dir ~top:dir path ~parent in - S.Response.make ~headers:[header_html] (Ok body) + S.Response.make_string ~headers:[header_html] (Ok body) ) else ( try let ic = open_in full_path in - S.Response.make_raw_chunked ~code:200 (input ic) + S.Response.make_raw_stream ~code:200 (S.Input_stream.of_chan ic) with e -> S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e) )); diff --git a/src/dune b/src/dune index d332719a..202dbcb0 100644 --- a/src/dune +++ b/src/dune @@ -3,4 +3,5 @@ (name tiny_httpd) (public_name tiny_httpd) (libraries threads) + (flags :standard -safe-string) (wrapped false)) diff --git a/src/examples/echo.ml b/src/examples/echo.ml index 1ca2a74a..83f11a0d 100644 --- a/src/examples/echo.ml +++ b/src/examples/echo.ml @@ -10,10 +10,10 @@ let () = let server = S.create () in (* say hello *) S.add_path_handler ~meth:`GET server - "/hello/%s@/" (fun name _req -> S.Response.make (Ok ("hello " ^name ^"!\n"))); + "/hello/%s@/" (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n"))); (* echo request *) 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_string (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req))); S.add_path_handler ~meth:`PUT server "/upload/%s" (fun path req -> debug_ (fun k->k "start upload %S\n%!" path); @@ -21,7 +21,7 @@ let () = let oc = open_out @@ "/tmp/" ^ path in output_string oc req.S.Request.body; flush oc; - S.Response.make (Ok "uploaded file") + S.Response.make_string (Ok "uploaded file") with e -> S.Response.fail ~code:500 "couldn't upload file: %s" (Printexc.to_string e) );