mirror of
https://github.com/c-cube/tiny_httpd.git
synced 2025-12-06 19:25:32 -05:00
wip: new IO API with streams
This commit is contained in:
Simon Cruanes
parent
76408b7e39
commit
939b183a50
5 changed files with 330 additions and 83 deletions
|
|
@ -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 (
|
||||
Bytes.blit self.bytes i self.bytes 0 (self.i - i);
|
||||
);
|
||||
self.i <- self.i - i
|
||||
|
||||
let contents (self:t) : string = Bytes.sub_string self.bytes 0 self.i
|
||||
|
||||
let contents_slice (self:t) i len : string =
|
||||
if i+len > 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 "@[<h>%s: %s@]" k v in
|
||||
Format.fprintf out "@[<v>%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 ()
|
||||
|
|
|
|||
|
|
@ -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. *)
|
||||
|
||||
(**/**)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
));
|
||||
|
|
|
|||
1
src/dune
1
src/dune
|
|
@ -3,4 +3,5 @@
|
|||
(name tiny_httpd)
|
||||
(public_name tiny_httpd)
|
||||
(libraries threads)
|
||||
(flags :standard -safe-string)
|
||||
(wrapped false))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue