diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index 3da79a7c..73dadceb 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -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 "" 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? *) diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 488c9616..a8f5fb44 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -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. *) diff --git a/src/Tiny_httpd_util.ml b/src/Tiny_httpd_util.ml index d2507b01..259dae2d 100644 --- a/src/Tiny_httpd_util.ml +++ b/src/Tiny_httpd_util.ml @@ -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 diff --git a/src/Tiny_httpd_util.mli b/src/Tiny_httpd_util.mli index 39b1148e..10fd30d7 100644 --- a/src/Tiny_httpd_util.mli +++ b/src/Tiny_httpd_util.mli @@ -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 *) diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index b7c2a8fa..63776338 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -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 " (parent directory) \n" p; + Printf.bprintf body " (parent directory) \n" + (encode_path p); end; Printf.bprintf body "