PageRenderTime 35ms CodeModel.GetById 9ms app.highlight 18ms RepoModel.GetById 1ms app.codeStats 1ms

/server/dispatch.ml

http://github.com/hhughes/ocaml-frui
OCaml | 111 lines | 71 code | 14 blank | 26 comment | 0 complexity | 63b371cf6773307b85901723a984d4b4 MD5 | raw file
  1(*pp camlp4o -I `ocamlfind query lwt.syntax` lwt-syntax-options.cma lwt-syntax.cma *)
  2(*
  3 * Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
  4 *
  5 * Permission to use, copy, modify, and distribute this software for any
  6 * purpose with or without fee is hereby granted, provided that the above
  7 * copyright notice and this permission notice appear in all copies.
  8 *
  9 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 10 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 11 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 12 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 13 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 14 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 15 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 16 *)
 17 
 18open Printf
 19open Cohttp
 20open Cohttpserver
 21open Lwt
 22open Events
 23
 24module Resp = struct
 25  (* respond with an error *)
 26  (* HACK *)
 27  let root = "/home/henry/proj/ocaml-frui"
 28  let not_found req err = 
 29    let status = `Not_found in
 30    let headers = [ "Cache-control", "no-cache" ] in
 31    let resp = sprintf "<html><body><h1>Error</h1><p>%s</p></body></html>" err in
 32    let body = [`String resp] in
 33    Http_response.init ~body ~headers ~status ()
 34
 35  (* internal error *)
 36  let internal_error err = 
 37    let status = `Internal_server_error in
 38    let headers = [ "Cache-control", "no-cache" ] in
 39    let resp = sprintf "<html><body><h1>Internal Server Error</h1><p>%s</p></body></html>" err in
 40    let body = [`String resp] in
 41    Http_response.init ~body ~headers ~status ()
 42
 43  (* dynamic response *)
 44  let dyn req body =
 45    let status = `OK in
 46    let headers = [] in
 47    Http_response.init ~body ~headers ~status ()
 48
 49  let get_file file req = 
 50    let size = (Unix.stat file).Unix.st_size in
 51    let fd = Unix.openfile file [Unix.O_RDONLY] 0o444 in
 52    let ic = Lwt_io.of_unix_fd ~close:(fun () -> Unix.close fd; Lwt.return ()) ~mode:Lwt_io.input fd in
 53    let t,u = Lwt.wait () in
 54    let body = [`Inchan (Int64.of_int size,  ic, u)] in
 55    return (dyn req body)
 56
 57  let events = get_file "/home/henry/proj/ocaml-frui/src/visualiser/dummy.json"
 58  let pop file = get_file (sprintf "/home/henry/proj/datasources/worldbank/pop/%s" file)
 59  let gdp file = get_file (sprintf "/home/henry/proj/datasources/worldbank/gdp/%s" file)
 60  let life file = get_file (sprintf "/home/henry/proj/datasources/worldbank/life/%s" file)
 61  let tests file = get_file (sprintf "/home/henry/proj/ocaml-frui/tests/%s" file)
 62  let elec = get_file "/home/henry/proj/datasources/elec/primary-cs1-riser/G-lighting/S-m22-2011-01.json"
 63  let elec2 = get_file "/home/henry/proj/datasources/elec/primary-cs1-riser/F-lighting/S-m23-2011-01.json"
 64  let elec3 = get_file "/home/henry/proj/datasources/elec/primary-cs1-riser/S-lighting/S-m25-2011-01.json"
 65
 66  let next_msg req =
 67    let body = [`String (Thread_state.get_events ())] in
 68    return (dyn req body)
 69
 70  let reset req =
 71    let body = [`String ""] in
 72    Thread_state.reset ();
 73    return (dyn req body)
 74
 75  (* index page *)
 76  let index req =
 77    let body = [`String "HELLO WORLD"] in
 78    return (dyn req body)
 79
 80  (* dispatch non-file URLs *)
 81  let dispatch req = function
 82    | [], _
 83(*    | "" :: "index.html" :: [], _->
 84        index req *)
 85    | "" :: "events" :: [], _ -> events req
 86    | "" :: "pop" :: file :: [], _ -> pop file req
 87    | "" :: "gdp" :: file :: [], _ -> gdp file req
 88    | "" :: "life" :: file :: [], _ -> life file req
 89    | "" :: "tests" :: file :: [], _ -> tests file req
 90    | "" :: "elec" :: [], _ -> elec req      
 91    | "" :: "elec2" :: [], _ -> elec2 req      
 92    | "" :: "elec3" :: [], _ -> elec3 req      
 93    | "" :: "next_msg" :: [], _ -> next_msg req
 94    | "" :: "reset" :: [], _ -> reset req
 95    | _, path -> try get_file (root ^ path) req
 96      with _ -> return (not_found req "dispatch")
 97
 98end
 99
100(* main callback function *)
101let t con_id req =
102  let path = Http_request.path req in
103
104  printf "%s %s [%s]\n%!" (Http_common.string_of_method (Http_request.meth req)) path 
105    (String.concat "," (List.map (fun (h,v) -> sprintf "%s=%s" h v) 
106      (Http_request.params_get req)));
107
108  (* normalize path to strip out ../. and such *)
109  let path_elem = Neturl.norm_path (Pcre.split ~pat:"/" path) in
110  lwt resp = Resp.dispatch req (path_elem, path) in
111  Http_daemon.respond_with resp