/server/dispatch.ml
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