Improve bin/cohttp_server_*

CHANGES

@@ -5,6 +5,9 @@
 * Add `Body.map` and `Body.as_pipe` to work with HTTP bodies more easily.
 * Move all the module type signatures into `Cohttp.S`.
 * [lwt] Remove the `Cohttp_lwt.Server.server` type synonym to `t`.
+* Improve `cohttp_server_lwt` and `cohttp_server_async` directory listings (#158)
+* Fix `Cohttp_async.resolve_local_file` directory traversal vulnerability (#158)
+* `cohttp_server_lwt` and `cohttp_server_async` now return better errors (#158)
 
 0.11.2 (2014-04-21)
 * Fix build by add a missing build-deps in _oasis.

async/cohttp_async.ml

@@ -251,7 +251,7 @@ module Server = struct
 
   let resolve_local_file ~docroot ~uri =
     (* This normalises the Uri and strips out .. characters *)
-    Uri.path (Uri.resolve "" (Uri.of_string "") uri)
+    Uri.path (Uri.resolve "" (Uri.of_string "/") uri)
     |> Filename.concat docroot
 
   let error_body_default =

bin/cohttp_server_async.ml

@@ -1,5 +1,6 @@
 (*
  * Copyright (c) 2013 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2014 David Sheets <sheets@alum.mit.edu>
  *
  * Permission to use, copy, modify, and distribute this software for any
  * purpose with or without fee is hereby granted, provided that the above
@@ -19,51 +20,76 @@ open Core.Std
 open Async.Std
 open Cohttp_async
 
+let ( / ) = Filename.concat
+
 let serve_file ~docroot ~uri =
   Server.resolve_local_file ~docroot ~uri
   |> Server.respond_with_file
 
+let compare_kind = function
+  | Some `Directory, Some `Directory -> 0
+  | Some `Directory, _               -> -1
+  | _              , Some `Directory -> 1
+  | Some `File     , Some `File      -> 0
+  | Some `File     , _               -> 1
+  | _              , Some `File      -> -1
+  | _              , _               -> 0
+
+let sort = List.sort ~cmp:(fun (ka,a) (kb,b) ->
+  let c = compare_kind (ka,kb) in
+  if c <> 0 then c
+  else String.compare (String.lowercase a) (String.lowercase b)
+)
+
+let li l = sprintf "<li><a href=\"%s\">%s</a></li>" (Uri.to_string l)
+
 (** HTTP handler *)
 let rec handler ~info ~docroot ~verbose ~index ~body sock req =
   let uri = Cohttp.Request.uri req in
   let path = Uri.path uri in
-  (* Get a canonical filename from the URL and docroot *)
-  let file_name = Server.resolve_local_file ~docroot ~uri in
-  Unix.stat file_name
-  >>= fun stat ->
   (* Log the request to the console *)
-  printf "%s %s %s\n" 
+  printf "%s %s%!"
     (Cohttp.(Code.string_of_method (Request.meth req)))
-    path
-    (match verbose with
-     | true -> Sexp.to_string_hum (Unix.Stats.sexp_of_t stat)
-     | false -> ""
-    );
-  match stat.Unix.Stats.kind with
-  (* Get a list of current files and map to HTML *)
-  | `Directory -> begin
+    path;
+  (* Get a canonical filename from the URL and docroot *)
+  let file_name = Server.resolve_local_file ~docroot ~uri in
+  try_with (fun () ->
+    Unix.stat file_name
+    >>= fun stat ->
+    printf " %s\n%!" (if verbose
+      then Sexp.to_string_hum (Unix.Stats.sexp_of_t stat)
+      else "");
+    match stat.Unix.Stats.kind with
+    (* Get a list of current files and map to HTML *)
+    | `Directory -> begin
       (* Check if the index file exists *)
-      Sys.file_exists (Filename.concat file_name index)
+      Sys.file_exists (file_name / index)
       >>= function
       | `Yes -> (* Serve the index file directly *)
-        let uri = Uri.with_path uri (Filename.concat path index) in
+        let uri = Uri.with_path uri (path / index) in
         Server.respond_with_redirect uri
       | `No | `Unknown -> (* Do a directory listing *)
         Sys.ls_dir file_name
         >>= Deferred.List.map ~f:(fun f ->
-            let file_name = Filename.concat file_name f in
+          let file_name = file_name / f in
+          try_with (fun () ->
             Unix.stat file_name
-            >>= fun stat ->
-            let li l = sprintf "<li><a href=\"%s\">%s</a></li>" (Uri.to_string l) in
-            let link = Uri.with_path uri (Filename.concat path f) in
-            match stat.Unix.Stats.kind with
-            | `Directory -> return (li link (sprintf "<i>%s/</i>" f))
-            | `File -> return (li link f)
-            | `Socket|`Block|`Fifo|`Char|`Link -> return (sprintf "<s>%s</s>" f))
+            >>| fun stat -> (Some stat.Unix.Stats.kind, f)
+          ) >>| function Ok v -> v | Error _ -> (None, f))
+        >>= fun listing ->
+        let html = List.map ~f:(fun (kind, f) ->
+          let link = Uri.with_path uri (path / f) in
+          match kind with
+          | Some `Directory -> li link (sprintf "<i>%s/</i>" f)
+          | Some `File -> li link f
+          | Some (`Socket|`Block|`Fifo|`Char|`Link) ->
+            sprintf "<li><s>%s</s></li>" f
+          | None -> sprintf "<li>Error with file: %s</li>" f
+        ) (sort ((Some `Directory,"..")::listing))
+        in
         (* Concatenate the HTML into a response *)
-        >>= fun html ->
         String.concat ~sep:"\n" html
-        |> fun contents ->
+      |> fun contents ->
         sprintf "
          <html>
            <body>
@@ -72,19 +98,37 @@ let rec handler ~info ~docroot ~verbose ~index ~body sock req =
            <hr>%s
            </body>
          </html>"
-          file_name contents info
-        |> Server.respond_with_string
+          path contents info
+      |> Server.respond_with_string
     end
-  (* Serve the local file contents *)
-  | `File -> serve_file ~docroot ~uri
-  (* Any other file type is simply forbidden *)
-  | `Socket | `Block | `Fifo | `Char | `Link ->
-    Server.respond_with_string ~code:`Forbidden
-      "<html><body><h2>Forbidden</h2>
-        <p>This is not a normal file or directory</p></body></html>"
+    (* Serve the local file contents *)
+    | `File -> serve_file ~docroot ~uri
+    (* Any other file type is simply forbidden *)
+    | `Socket | `Block | `Fifo | `Char | `Link ->
+      Server.respond_with_string ~code:`Forbidden
+        (sprintf "<html><body><h2>Forbidden</h2>
+         <p><b>%s</b> is not a normal file or directory</p>
+         <hr />%s</body></html>" path info)
+  )
+  >>= (function
+  | Ok res -> return res
+  | Error exn ->
+    printf "\n%!"; (* Close the request logging line. *)
+    begin match Monitor.extract_exn exn with
+    | Unix.Unix_error (Unix.ENOENT, "stat", p) as e ->
+      if p = ("((filename "^file_name^"))") (* Really? *)
+      then Server.respond_with_string ~code:`Not_found
+        (sprintf "<html><body><h2>Not Found</h2>
+         <p><b>%s</b> was not found on this server</p>
+         <hr />%s</body></html>" path info)
+      else raise exn
+    | _e -> raise exn
+    end
+  )
+
 
 let start_server docroot port host index verbose () =
-  printf "Listening for HTTP requests on: %s %d\n" host port;
+  printf "Listening for HTTP requests on: %s %d\n%!" host port;
   let info = sprintf "Served by Cohttp/Async listening on %s:%d" host port in
   Unix.Inet_addr.of_string_or_getbyname host
   >>= fun host ->
@@ -94,7 +138,7 @@ let start_server docroot port host index verbose () =
       ~listening_on:(fun _ -> port)
   in
   Server.create
-    ~on_handler_error:`Ignore 
+    ~on_handler_error:`Ignore
     listen_on 
     (handler ~info ~docroot ~index ~verbose)
   >>= fun _ -> never ()

bin/cohttp_server_lwt.ml

@@ -1,6 +1,7 @@
 (*
  * Copyright (c) 2014 Romain Calascibetta <romain.calascibetta@gmail.com>
  * Copyright (c) 2014 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2014 David Sheets <sheets@alum.mit.edu>
  *
  * Permission to use, copy, modify, and distribute this software for any
  * purpose with or without fee is hereby granted, provided that the above
@@ -16,76 +17,113 @@
  *
  *)
 
+open Printf
+
 open Lwt
 open Cohttp
 open Cohttp_lwt_unix
 
+let ( / ) = Filename.concat
+
 let serve_file ~docroot ~uri =
   let fname = Server.resolve_local_file ~docroot ~uri in
   Server.respond_file ~fname ()
 
+let compare_kind = function
+  | Some Unix.S_DIR, Some Unix.S_DIR -> 0
+  | Some Unix.S_DIR, _               -> -1
+  | _              , Some Unix.S_DIR -> 1
+  | Some Unix.S_REG, Some Unix.S_REG -> 0
+  | Some Unix.S_REG, _               -> 1
+  | _              , Some Unix.S_REG -> -1
+  | _              , _               -> 0
+
+let sort = List.sort (fun (ka,a) (kb,b) ->
+  let c = compare_kind (ka,kb) in
+  if c <> 0 then c
+  else String.compare (String.lowercase a) (String.lowercase b)
+)
+
+let li l = sprintf "<li><a href=\"%s\">%s</a></li>" (Uri.to_string l)
+
 let ls_dir dir =
-  Lwt_stream.to_list (Lwt_unix.files_of_directory dir)
+  Lwt_stream.to_list
+    (Lwt_stream.filter ((<>) ".")
+       (Lwt_unix.files_of_directory dir))
 
 let rec handler ~info ~docroot ~verbose ~index sock req body =
   let uri = Cohttp.Request.uri req in
   let path = Uri.path uri in
-  (* Get a canonical filename from the URL and docroot *)
-  let file_name = Server.resolve_local_file ~docroot ~uri in
-  Lwt_unix.stat file_name
-  >>= fun stat ->
   (* Log the request to the console *)
-  Printf.printf "%s %s %s"
+  printf "%s %s %s\n%!"
     (Cohttp.(Code.string_of_method (Request.meth req)))
     path
     (match verbose with
-     | true -> ""
-     | false -> ""
+    | true -> ""
+    | false -> ""
     );
-  match stat.Unix.st_kind with
-  | Unix.S_DIR -> begin
-      match Sys.file_exists (Filename.concat file_name index) with
-      | true -> let uri = Uri.with_path uri (Filename.concat path index) in
-        Server.respond_redirect uri ()
+  (* Get a canonical filename from the URL and docroot *)
+  let file_name = Server.resolve_local_file ~docroot ~uri in
+  catch (fun () ->
+    Lwt_unix.stat file_name
+    >>= fun stat ->
+    match stat.Unix.st_kind with
+    | Unix.S_DIR -> begin
+      match Sys.file_exists (file_name / index) with
+      | true -> let uri = Uri.with_path uri (path / index) in
+                Server.respond_redirect uri ()
       | false ->
         ls_dir file_name
         >>= Lwt_list.map_s (fun f ->
-            let file_name = Filename.concat file_name f in
-            Lwt.try_bind
-              (fun () -> Lwt_unix.stat file_name)
-              (fun stat ->
-                 let li l = Printf.sprintf "<li><a href=\"%s\">%s</a></li>" (Uri.to_string l) in
-                 let link = Uri.with_path uri (Filename.concat path f) in
-                 match stat.Unix.st_kind with
-                 | Unix.S_DIR -> Lwt.return (li link (Printf.sprintf "<i>%s/</i>" f))
-                 | Unix.S_REG -> Lwt.return (li link f)
-                 | _ -> Lwt.return (Printf.sprintf "<s>%s</s>" f))
-              (fun exn ->
-                 Lwt.return (Printf.sprintf "<li>Error with file: %s</li>" file_name)))
-        >>= fun html ->
+          let file_name = file_name / f in
+          Lwt.try_bind
+            (fun () -> Lwt_unix.stat file_name)
+            (fun stat -> return (Some stat.Unix.st_kind, f))
+            (fun exn -> return (None, f)))
+        >>= fun listing ->
+        let html = List.map (fun (kind, f) ->
+          let link = Uri.with_path uri (path / f) in
+          match kind with
+          | Some Unix.S_DIR -> li link (sprintf "<i>%s/</i>" f)
+          | Some Unix.S_REG -> li link f
+          | Some _ -> sprintf "<li><s>%s</s></li>" f
+          | None -> sprintf "<li>Error with file: %s</li>" f
+        ) (sort listing) in
         let contents = String.concat "\n" html in
-        let body = Printf.sprintf "
+        let body = sprintf "
               <html>
                 <body>
                 <h2>Directory Listing for %s</h2>
                 <ul>%s</ul>
-                <hr>%s
+                <hr />%s
                 </body>
               </html>"
-          file_name contents info in
+          path contents info in
         Server.respond_string ~status:`OK ~body ()
     end
-  | Unix.S_REG -> serve_file ~docroot ~uri
-  | _ ->
-    Server.respond_string ~status:`Forbidden
-      ~body:"<html><body><h2>Forbidden</h2>
-        <p>This is not a normal file or directory</p></body>/html>"
+    | Unix.S_REG -> serve_file ~docroot ~uri
+    | _ ->
+      Server.respond_string ~status:`Forbidden
+        ~body:(sprintf "<html><body><h2>Forbidden</h2>
+        <p><b>%s</b> is not a normal file or directory</p>
+        <hr />%s</body></html>" path info)
+        ()
+  ) (function
+  | Unix.Unix_error(Unix.ENOENT, "stat", p) as e ->
+    if p = file_name
+    then Server.respond_string ~status:`Not_found
+      ~body:(sprintf "<html><body><h2>Not Found</h2>
+      <p><b>%s</b> was not found on this server</p>
+      <hr />%s</body></html>" path info)
       ()
+    else fail e
+  | e -> fail e
+  )
 
 let start_server docroot port host index verbose () =
-  Printf.printf "Listening for HTTP request on: %s %d\n" host port;
-  let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in
-  let conn_closed id () = Printf.printf "connection %s closed\n%!"
+  printf "Listening for HTTP request on: %s %d\n%!" host port;
+  let info = sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in
+  let conn_closed id () = printf "connection %s closed\n%!"
       (Connection.to_string id) in
   let callback = handler ~info ~docroot ~verbose ~index in
   let config = { Server.callback; conn_closed } in

lwt/cohttp_lwt.ml

@@ -265,7 +265,9 @@ module Make_server(IO:Cohttp.S.IO with type 'a t = 'a Lwt.t)
   module Transfer_IO = Transfer_io.Make(IO)
 
   let resolve_local_file ~docroot ~uri =
-    Filename.concat docroot (Uri.path (Uri.resolve "" (Uri.of_string "") uri))
+    let path = Uri.path (Uri.resolve "http" (Uri.of_string "/") uri) in
+    let rel_path = String.sub path 1 (String.length path - 1) in
+    Filename.concat docroot rel_path
 
   let respond ?headers ?(flush=false) ~status ~body () =
     let encoding = Cohttp_lwt_body.transfer_encoding body in