diff --git a/CHANGES b/CHANGES index 22cac4667e..c3c8339680 100644 --- a/CHANGES +++ b/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. diff --git a/async/cohttp_async.ml b/async/cohttp_async.ml index e9ff71737d..da54c9b40b 100644 --- a/async/cohttp_async.ml +++ b/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 = diff --git a/bin/cohttp_server_async.ml b/bin/cohttp_server_async.ml index 0895f1efd5..0632caed22 100644 --- a/bin/cohttp_server_async.ml +++ b/bin/cohttp_server_async.ml @@ -1,5 +1,6 @@ (* * Copyright (c) 2013 Anil Madhavapeddy + * Copyright (c) 2014 David Sheets * * 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 "
  • %s
  • " (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 "
  • %s
  • " (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 "%s/" f)) - | `File -> return (li link f) - | `Socket|`Block|`Fifo|`Char|`Link -> return (sprintf "%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 "%s/" f) + | Some `File -> li link f + | Some (`Socket|`Block|`Fifo|`Char|`Link) -> + sprintf "
  • %s
  • " f + | None -> sprintf "
  • Error with file: %s
  • " f + ) (sort ((Some `Directory,"..")::listing)) + in (* Concatenate the HTML into a response *) - >>= fun html -> String.concat ~sep:"\n" html - |> fun contents -> + |> fun contents -> sprintf " @@ -72,19 +98,37 @@ let rec handler ~info ~docroot ~verbose ~index ~body sock req =
    %s " - 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 - "

    Forbidden

    -

    This is not a normal file or directory

    " + (* 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 "

    Forbidden

    +

    %s is not a normal file or directory

    +
    %s" 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 "

    Not Found

    +

    %s was not found on this server

    +
    %s" 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 () diff --git a/bin/cohttp_server_lwt.ml b/bin/cohttp_server_lwt.ml index 09d87b020e..247d8ea19f 100644 --- a/bin/cohttp_server_lwt.ml +++ b/bin/cohttp_server_lwt.ml @@ -1,6 +1,7 @@ (* * Copyright (c) 2014 Romain Calascibetta * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2014 David Sheets * * 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 "
  • %s
  • " (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 "
  • %s
  • " (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 "%s/" f)) - | Unix.S_REG -> Lwt.return (li link f) - | _ -> Lwt.return (Printf.sprintf "%s" f)) - (fun exn -> - Lwt.return (Printf.sprintf "
  • Error with file: %s
  • " 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 "%s/" f) + | Some Unix.S_REG -> li link f + | Some _ -> sprintf "
  • %s
  • " f + | None -> sprintf "
  • Error with file: %s
  • " f + ) (sort listing) in let contents = String.concat "\n" html in - let body = Printf.sprintf " + let body = sprintf "

    Directory Listing for %s

      %s
    -
    %s +
    %s " - 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:"

    Forbidden

    -

    This is not a normal file or directory

    /html>" + | Unix.S_REG -> serve_file ~docroot ~uri + | _ -> + Server.respond_string ~status:`Forbidden + ~body:(sprintf "

    Forbidden

    +

    %s is not a normal file or directory

    +
    %s" 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 "

    Not Found

    +

    %s was not found on this server

    +
    %s" 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 diff --git a/lwt/cohttp_lwt.ml b/lwt/cohttp_lwt.ml index 786927eaee..d1527812db 100644 --- a/lwt/cohttp_lwt.ml +++ b/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