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

- 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

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 =
+  let query self = self.query
-    match Tiny_httpd_util.(parse_query @@ get_query self.path) with
-    | Ok l -> l
-    | Error e -> bad_reqf 400 "invalid query: %s" e
-
   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? *)

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. *)

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

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 *)

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 =
+let encode_path s = U.percent_encode  s
-  U.percent_encode ~skip:(fun c -> c='/') 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
+         if contains_dot_dot path then (
-         | None -> S.Response.fail_raise ~code:404 "invalid percent encoding"
-         | Some path when contains_dot_dot path ->
            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

src/examples/dune

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

src/examples/echo.ml

@@ -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
+  S.add_route_handler ~meth:`GET server
-    "/hello/%s@/" (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
+    S.Route.(exact "hello" @/ string @/ return)
-  S.add_path_handler ~meth:`GET server
+    (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n")));
-    "/zcat/%s" (fun path _req ->
+  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
+  S.add_route_handler server
-    "/echo" (fun req ->
+    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
+  S.add_route_handler_stream ~meth:`PUT server
-    "/upload/%s" (fun path req ->
+    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