dispatch.ml - This OCaml code sets up a web server using th…

/server/dispatch.ml

http://github.com/hhughes/ocaml-frui · OCaml · 111 lines · 71 code · 14 blank · 26 comment · 0 complexity · 63b371cf6773307b85901723a984d4b4 MD5 · raw file


(*pp camlp4o -I `ocamlfind query lwt.syntax` lwt-syntax-options.cma lwt-syntax.cma *)
(*
 * Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)
 
open Printf
open Cohttp
open Cohttpserver
open Lwt
open Events

module Resp = struct
  (* respond with an error *)
  (* HACK *)
  let root = "/home/henry/proj/ocaml-frui"
  let not_found req err = 
    let status = `Not_found in
    let headers = [ "Cache-control", "no-cache" ] in
    let resp = sprintf "<html><body><h1>Error</h1><p>%s</p></body></html>" err in
    let body = [`String resp] in
    Http_response.init ~body ~headers ~status ()

  (* internal error *)
  let internal_error err = 
    let status = `Internal_server_error in
    let headers = [ "Cache-control", "no-cache" ] in
    let resp = sprintf "<html><body><h1>Internal Server Error</h1><p>%s</p></body></html>" err in
    let body = [`String resp] in
    Http_response.init ~body ~headers ~status ()

  (* dynamic response *)
  let dyn req body =
    let status = `OK in
    let headers = [] in
    Http_response.init ~body ~headers ~status ()

  let get_file file req = 
    let size = (Unix.stat file).Unix.st_size in
    let fd = Unix.openfile file [Unix.O_RDONLY] 0o444 in
    let ic = Lwt_io.of_unix_fd ~close:(fun () -> Unix.close fd; Lwt.return ()) ~mode:Lwt_io.input fd in
    let t,u = Lwt.wait () in
    let body = [`Inchan (Int64.of_int size,  ic, u)] in
    return (dyn req body)

  let events = get_file "/home/henry/proj/ocaml-frui/src/visualiser/dummy.json"
  let pop file = get_file (sprintf "/home/henry/proj/datasources/worldbank/pop/%s" file)
  let gdp file = get_file (sprintf "/home/henry/proj/datasources/worldbank/gdp/%s" file)
  let life file = get_file (sprintf "/home/henry/proj/datasources/worldbank/life/%s" file)
  let tests file = get_file (sprintf "/home/henry/proj/ocaml-frui/tests/%s" file)
  let elec = get_file "/home/henry/proj/datasources/elec/primary-cs1-riser/G-lighting/S-m22-2011-01.json"
  let elec2 = get_file "/home/henry/proj/datasources/elec/primary-cs1-riser/F-lighting/S-m23-2011-01.json"
  let elec3 = get_file "/home/henry/proj/datasources/elec/primary-cs1-riser/S-lighting/S-m25-2011-01.json"

  let next_msg req =
    let body = [`String (Thread_state.get_events ())] in
    return (dyn req body)

  let reset req =
    let body = [`String ""] in
    Thread_state.reset ();
    return (dyn req body)

  (* index page *)
  let index req =
    let body = [`String "HELLO WORLD"] in
    return (dyn req body)

  (* dispatch non-file URLs *)
  let dispatch req = function
    | [], _
(*    | "" :: "index.html" :: [], _->
        index req *)
    | "" :: "events" :: [], _ -> events req
    | "" :: "pop" :: file :: [], _ -> pop file req
    | "" :: "gdp" :: file :: [], _ -> gdp file req
    | "" :: "life" :: file :: [], _ -> life file req
    | "" :: "tests" :: file :: [], _ -> tests file req
    | "" :: "elec" :: [], _ -> elec req      
    | "" :: "elec2" :: [], _ -> elec2 req      
    | "" :: "elec3" :: [], _ -> elec3 req      
    | "" :: "next_msg" :: [], _ -> next_msg req
    | "" :: "reset" :: [], _ -> reset req
    | _, path -> try get_file (root ^ path) req
      with _ -> return (not_found req "dispatch")

end

(* main callback function *)
let t con_id req =
  let path = Http_request.path req in

  printf "%s %s [%s]\n%!" (Http_common.string_of_method (Http_request.meth req)) path 
    (String.concat "," (List.map (fun (h,v) -> sprintf "%s=%s" h v) 
      (Http_request.params_get req)));

  (* normalize path to strip out ../. and such *)
  let path_elem = Neturl.norm_path (Pcre.split ~pat:"/" path) in
  lwt resp = Resp.dispatch req (path_elem, path) in
  Http_daemon.respond_with resp