A SimpleHTTPServer with Lwt

_oasis

@@ -201,7 +201,7 @@ Executable test_net_async_server
   Install:            false
   BuildDepends:       cohttp, cohttp.async, oUnit (>= 1.0.2)
 
-Executable "cohttp-server"
+Executable "cohttp-server-async"
   Path:               bin
   MainIs:             cohttp_server_async.ml
   Build$:             flag(async)
@@ -210,6 +210,15 @@ Executable "cohttp-server"
   Install:            true
   BuildDepends:       cohttp, cohttp.async
 
+Executable "cohttp-server-lwt"
+  Path:               bin
+  MainIs:             cohttp_server_lwt.ml
+  Build$:             flag(lwt)
+  Custom:             true
+  CompiledObject:     best
+  Install:            true
+  BuildDepends:       cohttp, cohttp.lwt
+
 Executable "async-hello-world"
   Path:               examples/async
   MainIs:             hello_world.ml

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: b06facdaaf27136c8f4b5c20b9bfe79f)
+# DO NOT EDIT (digest: 1b2b864273887ce54377364050d2ef95)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -62,10 +62,6 @@
 <lwt/*.ml{,i}>: use_cohttp_lwt
 # Library cohttp_async
 "async/cohttp_async.cmxs": use_cohttp_async
-<async/cohttp_async.{cma,cmxa}>: oasis_library_cohttp_async_byte
-<async/*.ml{,i}>: oasis_library_cohttp_async_byte
-<async/cohttp_async.{cma,cmxa}>: oasis_library_cohttp_async_native
-<async/*.ml{,i}>: oasis_library_cohttp_async_native
 <async/*.ml{,i}>: pkg_async
 <async/*.ml{,i}>: pkg_async_ssl
 <async/*.ml{,i}>: pkg_fieldslib
@@ -315,7 +311,7 @@
 <lib_test/*.ml{,i}>: use_cohttp
 <lib_test/*.ml{,i}>: use_cohttp_async
 <lib_test/test_net_async_server.{native,byte}>: custom
-# Executable cohttp-server
+# Executable cohttp-server-async
 <bin/cohttp_server_async.{native,byte}>: pkg_async
 <bin/cohttp_server_async.{native,byte}>: pkg_async_ssl
 <bin/cohttp_server_async.{native,byte}>: pkg_fieldslib
@@ -331,18 +327,43 @@
 <bin/cohttp_server_async.{native,byte}>: use_cohttp_async
 <bin/*.ml{,i}>: pkg_async
 <bin/*.ml{,i}>: pkg_async_ssl
+<bin/*.ml{,i}>: pkg_threads
+<bin/*.ml{,i}>: use_cohttp_async
+<bin/cohttp_server_async.{native,byte}>: custom
+# Executable cohttp-server-lwt
+<bin/cohttp_server_lwt.{native,byte}>: pkg_fieldslib
+<bin/cohttp_server_lwt.{native,byte}>: pkg_fieldslib.syntax
+<bin/cohttp_server_lwt.{native,byte}>: pkg_lwt
+<bin/cohttp_server_lwt.{native,byte}>: pkg_lwt.ssl
+<bin/cohttp_server_lwt.{native,byte}>: pkg_lwt.syntax
+<bin/cohttp_server_lwt.{native,byte}>: pkg_lwt.unix
+<bin/cohttp_server_lwt.{native,byte}>: pkg_re.emacs
+<bin/cohttp_server_lwt.{native,byte}>: pkg_sexplib
+<bin/cohttp_server_lwt.{native,byte}>: pkg_sexplib.syntax
+<bin/cohttp_server_lwt.{native,byte}>: pkg_stringext
+<bin/cohttp_server_lwt.{native,byte}>: pkg_unix
+<bin/cohttp_server_lwt.{native,byte}>: pkg_uri
+<bin/cohttp_server_lwt.{native,byte}>: pkg_uri.services
+<bin/cohttp_server_lwt.{native,byte}>: use_cohttp
+<bin/cohttp_server_lwt.{native,byte}>: use_cohttp_lwt
+<bin/cohttp_server_lwt.{native,byte}>: use_cohttp_lwt_unix
 <bin/*.ml{,i}>: pkg_fieldslib
 <bin/*.ml{,i}>: pkg_fieldslib.syntax
+<bin/*.ml{,i}>: pkg_lwt
+<bin/*.ml{,i}>: pkg_lwt.ssl
+<bin/*.ml{,i}>: pkg_lwt.syntax
+<bin/*.ml{,i}>: pkg_lwt.unix
 <bin/*.ml{,i}>: pkg_re.emacs
 <bin/*.ml{,i}>: pkg_sexplib
 <bin/*.ml{,i}>: pkg_sexplib.syntax
 <bin/*.ml{,i}>: pkg_stringext
-<bin/*.ml{,i}>: pkg_threads
+<bin/*.ml{,i}>: pkg_unix
 <bin/*.ml{,i}>: pkg_uri
 <bin/*.ml{,i}>: pkg_uri.services
 <bin/*.ml{,i}>: use_cohttp
-<bin/*.ml{,i}>: use_cohttp_async
-<bin/cohttp_server_async.{native,byte}>: custom
+<bin/*.ml{,i}>: use_cohttp_lwt
+<bin/*.ml{,i}>: use_cohttp_lwt_unix
+<bin/cohttp_server_lwt.{native,byte}>: custom
 # Executable async-hello-world
 <examples/async/hello_world.{native,byte}>: pkg_async
 <examples/async/hello_world.{native,byte}>: pkg_async_ssl

bin/cohttp_server_lwt.ml

@@ -0,0 +1,100 @@
+open Lwt
+open Cohttp
+open Cohttp_lwt_unix
+
+let serve_file ~docroot ~uri =
+  Server.resolve_local_file ~docroot ~uri
+  |> (fun x -> Server.respond_file ~fname:x ())
+
+let ls_dir dir =
+  Lwt_unix.files_of_directory dir
+  |> Lwt_stream.to_list
+
+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"
+    (Cohttp.(Code.string_of_method (Request.meth req)))
+    path
+    (match verbose with
+     | 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 ()
+      | 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 ->
+        String.concat "\n" html
+        |> fun contents ->
+        Printf.sprintf "
+              <html>
+                <body>
+                <h2>Directory Listing for %s</h2>
+                <ul>%s</ul>
+                <hr>%s
+                </body>
+              </html>"
+          file_name contents info
+        |> (fun x -> Server.respond_string ~status:`OK ~body:x ())
+    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>"
+      ()
+
+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%!"
+      (Connection.to_string id) in
+  let callback = handler ~info ~docroot ~verbose ~index in
+  let config = { Server.callback; conn_closed } in
+  Server.create ~address:host ~port:port config
+
+let host = ref "0.0.0.0"
+let port = ref 8080
+let index = ref "index.html"
+let verbose = ref false
+let rest = ref []
+
+let usage = "usage " ^ Sys.argv.(0) ^ " input [-o output]"
+
+let arglist = [
+  ("-p", Arg.Int (fun i -> port := i), ": TCP port to listen on");
+  ("-s", Arg.String (fun s -> host := s), ": IP address to listen on");
+  ("-i", Arg.String (fun s -> index := s), ": Name of index file in directory");
+  ("-v", Arg.Bool (fun b -> verbose := b), ": logging output to console");
+]
+
+let _ =
+  try Arg.parse arglist (fun x -> rest := x :: !rest) usage;
+    if List.length !rest = 0
+    then Lwt_unix.run (start_server "." !port !host !index !verbose ())
+    else Lwt_unix.run (start_server (List.hd !rest) !port !host !index !verbose ())
+  with
+  | Failure s -> print_endline s
+  | Sys_error s -> print_endline s

lwt/cohttp_lwt.ml

@@ -220,6 +220,8 @@ module type Server = sig
       Cohttp.Connection.t -> unit -> unit;
   }
 
+  val resolve_local_file : docroot:string -> uri:Uri.t -> string
+
   val respond :
     ?headers:Cohttp.Header.t ->
     ?flush:bool ->
@@ -270,6 +272,10 @@ module Make_server(IO:Cohttp.IO.S with type 'a t = 'a Lwt.t)
 
   module Transfer_IO = Transfer_io.Make(IO)
 
+  let resolve_local_file ~docroot ~uri =
+    Uri.path (Uri.resolve "" (Uri.of_string "") uri)
+    |> Filename.concat docroot
+
   let respond ?headers ?(flush=false) ~status ~body () =
     let encoding = Cohttp_lwt_body.transfer_encoding body in
     let res = Response.make ~status ~flush ~encoding ?headers () in

lwt/cohttp_lwt.mli

@@ -150,6 +150,9 @@ module type Server = sig
       Cohttp.Connection.t -> unit -> unit;
   }
 
+  (** Resolve a URI and a docroot into a concrete local filename. *)
+  val resolve_local_file : docroot:string -> uri:Uri.t -> string
+
   val respond :
     ?headers:Cohttp.Header.t ->
     ?flush:bool ->

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 72cf2d13942cacfc33091904e4c642cf) *)
+(* DO NOT EDIT (digest: 52c11beeb42a0bfb5136fda0433f4835) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -603,58 +603,20 @@ let package_default =
           ("cohttp_async", ["async"], [])
        ];
      lib_c = [];
-     flags =
-       [
-          (["oasis_library_cohttp_async_byte"; "ocaml"; "link"; "byte"],
-            [
-               (OASISExpr.EBool true,
-                 S [A "-ppopt"; A "-let"; A "-ppopt"; A "ssl=true"])
-            ]);
-          (["oasis_library_cohttp_async_native"; "ocaml"; "link"; "native"],
-            [
-               (OASISExpr.EBool true,
-                 S [A "-ppopt"; A "-let"; A "-ppopt"; A "ssl=true"])
-            ]);
-          (["oasis_library_cohttp_async_byte"; "ocaml"; "ocamldep"; "byte"],
-            [
-               (OASISExpr.EBool true,
-                 S [A "-ppopt"; A "-let"; A "-ppopt"; A "ssl=true"])
-            ]);
-          ([
-              "oasis_library_cohttp_async_native";
-              "ocaml";
-              "ocamldep";
-              "native"
-           ],
-            [
-               (OASISExpr.EBool true,
-                 S [A "-ppopt"; A "-let"; A "-ppopt"; A "ssl=true"])
-            ]);
-          (["oasis_library_cohttp_async_byte"; "ocaml"; "compile"; "byte"],
-            [
-               (OASISExpr.EBool true,
-                 S [A "-ppopt"; A "-let"; A "-ppopt"; A "ssl=true"])
-            ]);
-          (["oasis_library_cohttp_async_native"; "ocaml"; "compile"; "native"
-           ],
-            [
-               (OASISExpr.EBool true,
-                 S [A "-ppopt"; A "-let"; A "-ppopt"; A "ssl=true"])
-            ])
-       ];
+     flags = [];
      includes =
        [
           ("lwt", ["cohttp"]);
           ("lib_test", ["async"; "cohttp"; "lwt"]);
           ("examples/async", ["async"; "cohttp"]);
-          ("bin", ["async"; "cohttp"]);
+          ("bin", ["async"; "cohttp"; "lwt"]);
           ("async", ["cohttp"])
        ]
   }
   ;;
 
 let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
 
-# 659 "myocamlbuild.ml"
+# 621 "myocamlbuild.ml"
 (* OASIS_STOP *)
 Ocamlbuild_plugin.dispatch dispatch_default;;