2012-03-07 18:23:41 +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-03-07 18:23:41 +00:00
|
|
|
|
2012-05-01 21:36:38 +00:00
|
|
|
(* Hop is free software: you can redistribute it and/or modify it *)
|
2012-03-07 18:23:41 +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-03-07 18:23:41 +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-03-07 18:23:41 +00:00
|
|
|
|
2012-05-05 22:18:23 +00:00
|
|
|
open Lwt
|
2012-01-08 17:41:04 +00:00
|
|
|
open Printf
|
|
|
|
open Datastructures
|
2012-03-04 17:12:20 +00:00
|
|
|
open Status
|
2012-01-08 17:41:04 +00:00
|
|
|
|
2012-05-05 22:18:23 +00:00
|
|
|
type handle_message_t = t -> Sexp.t -> unit Lwt.t
|
2012-01-08 17:41:04 +00:00
|
|
|
and t = {
|
2012-05-06 03:06:53 +00:00
|
|
|
mutable names: StringSet.t;
|
|
|
|
mutable send_counter: int;
|
|
|
|
class_name: string;
|
|
|
|
handle_message: handle_message_t
|
|
|
|
}
|
2012-05-05 15:46:48 +00:00
|
|
|
and name = {
|
|
|
|
label: string;
|
|
|
|
mutable binding: t option
|
|
|
|
}
|
|
|
|
|
|
|
|
module NameTable = Weak.Make(struct
|
|
|
|
type t = name
|
|
|
|
let equal a b = (a.label = b.label)
|
|
|
|
let hash a = Hashtbl.hash a.label
|
|
|
|
end)
|
|
|
|
module NameSet = Set.Make(struct
|
|
|
|
type t = name
|
|
|
|
let compare a b = String.compare a.label b.label
|
|
|
|
end)
|
2012-01-08 17:41:04 +00:00
|
|
|
|
2012-05-05 15:46:48 +00:00
|
|
|
let name_table = NameTable.create 100
|
|
|
|
let directory = ref NameSet.empty
|
|
|
|
|
|
|
|
let name_of_string str =
|
2012-05-05 22:18:23 +00:00
|
|
|
let template = {label = str; binding = None} in
|
|
|
|
NameTable.merge name_table template
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let local_container_name () = "server"
|
|
|
|
|
|
|
|
let make class_name handler = {
|
|
|
|
names = StringSet.empty;
|
2012-05-06 03:06:53 +00:00
|
|
|
send_counter = 0;
|
2012-01-08 17:41:04 +00:00
|
|
|
class_name = class_name;
|
|
|
|
handle_message = handler
|
|
|
|
}
|
|
|
|
|
2012-05-05 15:46:48 +00:00
|
|
|
let lookup name = name.binding
|
2012-01-08 17:41:04 +00:00
|
|
|
|
2012-05-05 15:46:48 +00:00
|
|
|
let all_node_names () = NameSet.elements !directory
|
|
|
|
let all_node_name_strings () = List.map (fun x -> x.label) (all_node_names ())
|
2012-05-01 12:30:17 +00:00
|
|
|
|
2012-03-06 22:30:39 +00:00
|
|
|
(* Approximate because it doesn't lock or run in a transaction *)
|
2012-05-05 15:46:48 +00:00
|
|
|
let approx_exists name =
|
|
|
|
match name.binding with
|
|
|
|
| Some _ -> true
|
|
|
|
| None -> false
|
2012-03-04 17:12:20 +00:00
|
|
|
|
2012-01-08 17:41:04 +00:00
|
|
|
let bind (filter, node) =
|
2012-05-05 15:46:48 +00:00
|
|
|
if filter.label = ""
|
2012-05-05 22:18:23 +00:00
|
|
|
then (ignore (Log.warn "Binding to empty name forbidden" []); return false)
|
2012-01-08 17:41:04 +00:00
|
|
|
else
|
2012-05-10 01:51:47 +00:00
|
|
|
match filter.binding with
|
|
|
|
| None ->
|
|
|
|
filter.binding <- Some node;
|
|
|
|
directory := NameSet.add filter !directory;
|
|
|
|
node.names <- StringSet.add filter.label node.names;
|
|
|
|
ignore (Log.info "Node bound" [Sexp.Str filter.label; Sexp.Str node.class_name]);
|
|
|
|
return true
|
|
|
|
| Some _ ->
|
|
|
|
return false
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
(* For use in factory constructor functions, hence the odd return type and values *)
|
|
|
|
let make_named class_name node_name handler =
|
|
|
|
let node = make class_name handler in
|
2012-05-05 22:18:23 +00:00
|
|
|
match_lwt bind (node_name, node) with
|
|
|
|
| true -> return (Ok node)
|
|
|
|
| false -> return (Problem (Sexp.Str "bind-failed"))
|
2012-03-04 17:12:20 +00:00
|
|
|
|
|
|
|
(* For use in factory constructor functions, hence the odd return type and values *)
|
2012-05-06 03:00:10 +00:00
|
|
|
let make_idempotent_named class_name node_name if_new_node handler =
|
2012-03-04 17:12:20 +00:00
|
|
|
match lookup node_name with
|
|
|
|
| Some n ->
|
2012-05-05 22:18:23 +00:00
|
|
|
return (if n.class_name = class_name
|
2012-03-04 17:12:20 +00:00
|
|
|
then Ok n
|
2012-05-05 22:18:23 +00:00
|
|
|
else Problem (Sexp.Str "class-mismatch"))
|
2012-03-04 17:12:20 +00:00
|
|
|
| None ->
|
|
|
|
let node = make class_name handler in
|
2012-05-05 22:18:23 +00:00
|
|
|
match_lwt bind (node_name, node) with
|
2012-05-06 03:00:10 +00:00
|
|
|
| true -> lwt () = if_new_node () in return (Ok node)
|
2012-05-05 22:18:23 +00:00
|
|
|
| false -> return (Problem (Sexp.Str "bind-failed"))
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let unbind name =
|
2012-05-05 22:18:23 +00:00
|
|
|
match lookup name with
|
2012-05-05 15:46:48 +00:00
|
|
|
| Some n ->
|
2012-05-05 22:18:23 +00:00
|
|
|
ignore (Log.info "Node unbound" [Sexp.Str name.label; Sexp.Str n.class_name]);
|
|
|
|
n.names <- StringSet.remove name.label n.names;
|
|
|
|
name.binding <- None;
|
|
|
|
directory := NameSet.remove name !directory;
|
|
|
|
return true
|
2012-05-05 15:46:48 +00:00
|
|
|
| None ->
|
2012-05-05 22:18:23 +00:00
|
|
|
return false
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let unbind_all n =
|
2012-05-05 22:18:23 +00:00
|
|
|
lwt () =
|
|
|
|
Lwt_list.iter_s
|
|
|
|
(fun name -> lwt _ = unbind (name_of_string name) in return ())
|
|
|
|
(StringSet.elements n.names)
|
|
|
|
in
|
|
|
|
n.names <- StringSet.empty;
|
|
|
|
return ()
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let send name body =
|
|
|
|
match lookup name with
|
2012-05-05 22:18:23 +00:00
|
|
|
| Some n ->
|
2012-05-06 03:06:53 +00:00
|
|
|
lwt () =
|
2012-05-05 22:18:23 +00:00
|
|
|
(try_lwt n.handle_message n body
|
|
|
|
with e ->
|
|
|
|
Log.warn "Node message handler raised exception"
|
|
|
|
[Sexp.Str name.label;
|
2012-05-06 03:06:53 +00:00
|
|
|
Sexp.Str (Printexc.to_string e)])
|
|
|
|
in
|
|
|
|
n.send_counter <- n.send_counter + 1;
|
|
|
|
lwt () =
|
|
|
|
if n.send_counter >= 1000
|
|
|
|
then (n.send_counter <- 0; Lwt_unix.yield ())
|
|
|
|
else return ()
|
|
|
|
in
|
2012-05-05 22:18:23 +00:00
|
|
|
return true
|
|
|
|
| None ->
|
|
|
|
return false
|
2012-01-08 17:41:04 +00:00
|
|
|
|
2012-05-05 15:46:48 +00:00
|
|
|
let send' str body = send (name_of_string str) body
|
|
|
|
|
2012-01-08 17:41:04 +00:00
|
|
|
let post name label body token =
|
|
|
|
send name (Message.post (label, body, token))
|
|
|
|
|
2012-05-05 15:46:48 +00:00
|
|
|
let post' str label body token = post (name_of_string str) label body token
|
|
|
|
|
2012-01-08 17:41:04 +00:00
|
|
|
let bind_ignore (filter, node) =
|
2012-05-05 22:18:23 +00:00
|
|
|
match_lwt bind (filter, node) with
|
|
|
|
| true -> return ()
|
|
|
|
| false -> Log.warn "Duplicate binding" [Sexp.Str filter.label]
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let send_ignore name body =
|
2012-05-05 22:18:23 +00:00
|
|
|
match_lwt send name body with
|
|
|
|
| true -> return ()
|
|
|
|
| false ->
|
|
|
|
if name.label = ""
|
|
|
|
then return ()
|
|
|
|
else Log.warn "send to missing node" [Sexp.Str name.label; body]
|
2012-05-05 15:46:48 +00:00
|
|
|
|
|
|
|
let send_ignore' str body = send_ignore (name_of_string str) body
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let post_ignore name label body token =
|
|
|
|
send_ignore name (Message.post (label, body, token))
|
2012-05-05 15:46:48 +00:00
|
|
|
|
|
|
|
let post_ignore' str label body token = post_ignore (name_of_string str) label body token
|