2012-04-28 21:17:04 +00:00
|
|
|
(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
|
|
|
|
|
2012-05-01 21:36:38 +00:00
|
|
|
(* This file is part of Hop. *)
|
2012-04-28 21:17:04 +00:00
|
|
|
|
2012-05-01 21:36:38 +00:00
|
|
|
(* Hop is free software: you can redistribute it and/or modify it *)
|
2012-04-28 21:17:04 +00:00
|
|
|
(* under the terms of the GNU General Public License as published by the *)
|
|
|
|
(* Free Software Foundation, either version 3 of the License, or (at your *)
|
|
|
|
(* option) any later version. *)
|
|
|
|
|
2012-05-01 21:36:38 +00:00
|
|
|
(* Hop is distributed in the hope that it will be useful, but *)
|
2012-04-28 21:17:04 +00:00
|
|
|
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
|
|
|
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
|
|
|
|
(* General Public License for more details. *)
|
|
|
|
|
|
|
|
(* You should have received a copy of the GNU General Public License *)
|
2012-05-01 21:36:38 +00:00
|
|
|
(* along with Hop. If not, see <http://www.gnu.org/licenses/>. *)
|
2012-04-28 21:17:04 +00:00
|
|
|
|
|
|
|
open Html
|
2012-05-01 12:06:30 +00:00
|
|
|
open Hof
|
2012-05-01 12:30:17 +00:00
|
|
|
open Datastructures
|
2012-04-28 21:17:04 +00:00
|
|
|
|
2012-04-28 22:08:15 +00:00
|
|
|
let dispatch_table = ref []
|
|
|
|
|
2012-04-29 10:57:49 +00:00
|
|
|
let longest_prefix_first (p1, _) (p2, _) =
|
|
|
|
String.length p2 - String.length p1
|
|
|
|
|
2012-04-28 22:08:15 +00:00
|
|
|
let register_dispatcher (prefix, handler) =
|
2012-04-29 10:57:49 +00:00
|
|
|
dispatch_table := List.sort longest_prefix_first ((prefix, handler) :: !dispatch_table)
|
2012-04-28 22:08:15 +00:00
|
|
|
|
2012-04-29 20:34:52 +00:00
|
|
|
let handle_dynamic_req id r =
|
2012-04-28 22:08:15 +00:00
|
|
|
let rec search_table table =
|
|
|
|
match table with
|
|
|
|
| [] ->
|
|
|
|
Httpd.http_error_html 404 "Not found"
|
|
|
|
[Html.tag "p" [] [Html.text ("No route for URL path "^r.Httpd.path)]]
|
|
|
|
| (prefix, handler) :: rest ->
|
2012-05-01 12:30:17 +00:00
|
|
|
let wholepath = r.Httpd.path in
|
|
|
|
if Util.starts_with wholepath prefix
|
|
|
|
then
|
|
|
|
(let wholepath_len = String.length wholepath in
|
|
|
|
let prefix_len = String.length prefix in
|
|
|
|
let suffix = String.sub wholepath prefix_len (wholepath_len - prefix_len) in
|
|
|
|
handler suffix id r)
|
2012-04-28 22:08:15 +00:00
|
|
|
else search_table rest
|
|
|
|
in
|
|
|
|
search_table !dispatch_table
|
2012-04-28 21:17:04 +00:00
|
|
|
|
2012-04-29 20:34:52 +00:00
|
|
|
let handle_req id r =
|
2012-04-28 21:17:04 +00:00
|
|
|
if Util.starts_with r.Httpd.path "/_"
|
2012-04-29 20:34:52 +00:00
|
|
|
then handle_dynamic_req id r
|
2012-04-28 21:17:04 +00:00
|
|
|
else
|
|
|
|
match r.Httpd.verb with
|
2012-04-29 10:57:24 +00:00
|
|
|
| "GET" | "HEAD" -> Httpd_file.resp_file (Filename.concat "./web" r.Httpd.path)
|
2012-04-28 21:17:04 +00:00
|
|
|
| _ -> Httpd.http_error_html 400 ("Unsupported HTTP method "^r.Httpd.verb) []
|
|
|
|
|
2012-05-01 19:37:39 +00:00
|
|
|
let cleanup_req id exn =
|
2012-04-29 20:34:52 +00:00
|
|
|
match Node.lookup id with
|
|
|
|
| Some n -> Node.unbind_all n
|
|
|
|
| None -> ()
|
|
|
|
|
2012-04-28 21:17:04 +00:00
|
|
|
let start (s, peername) =
|
2012-04-29 20:34:52 +00:00
|
|
|
let id = "http-" ^ Uuid.create () in
|
2012-04-28 21:17:04 +00:00
|
|
|
Util.create_thread (Connections.endpoint_name peername ^ " HTTP service")
|
2012-04-29 20:34:52 +00:00
|
|
|
(Some (cleanup_req id))
|
|
|
|
(Httpd.main (handle_req id))
|
2012-04-28 21:17:04 +00:00
|
|
|
(s, peername)
|
|
|
|
|
2012-04-28 22:08:15 +00:00
|
|
|
let boot_time = Unix.time ()
|
2012-05-01 12:30:17 +00:00
|
|
|
let api_server_stats _ id r =
|
2012-04-29 12:40:24 +00:00
|
|
|
Json.resp_ok [] (Json.Rec
|
|
|
|
["connection_count", Json.Num (float_of_int !Connections.connection_count);
|
|
|
|
"boot_time", Json.Num boot_time;
|
2012-04-30 01:47:01 +00:00
|
|
|
"uptime", Json.Num (Unix.time () -. boot_time);
|
|
|
|
"classes", Json.Arr (List.map Json.str (Factory.all_class_names ()))])
|
2012-05-01 12:06:30 +00:00
|
|
|
|> Httpd.add_date_header
|
2012-04-29 23:41:28 +00:00
|
|
|
|
2012-05-01 12:30:17 +00:00
|
|
|
let api_nodes _ id r =
|
|
|
|
Json.resp_ok [] (Json.Rec ["nodes", Json.Arr (List.map Json.str (Node.all_node_names ()))])
|
|
|
|
|> Httpd.add_date_header
|
|
|
|
|
|
|
|
let api_node_info suffix id r =
|
|
|
|
(match Node.lookup suffix with
|
|
|
|
| Some n ->
|
|
|
|
Json.resp_ok [] (Json.Rec
|
|
|
|
["names", Json.Arr (List.map Json.str (StringSet.elements n.Node.names));
|
|
|
|
"class_name", Json.Str n.Node.class_name])
|
|
|
|
| None ->
|
|
|
|
Json.resp 404 "No such node name" [] Json.Nil)
|
|
|
|
|> Httpd.add_date_header
|
|
|
|
|
2012-04-28 21:17:04 +00:00
|
|
|
let init () =
|
2012-04-29 20:34:52 +00:00
|
|
|
register_dispatcher ("/_/server_stats", api_server_stats);
|
2012-05-01 12:30:17 +00:00
|
|
|
register_dispatcher ("/_/nodes", api_nodes);
|
|
|
|
register_dispatcher ("/_/node/", api_node_info);
|
2012-05-01 19:37:39 +00:00
|
|
|
ignore (Util.create_daemon_thread "HTTP listener" None (Net.start_net "HTTP" 5678) start)
|