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-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
|
|
|
|
|
|
|
type handle_message_t = t -> Sexp.t -> unit
|
|
|
|
and t = {
|
|
|
|
mutable names: StringSet.t;
|
|
|
|
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-03-06 22:30:39 +00:00
|
|
|
let mutex = Mutex.create ()
|
2012-05-05 15:46:48 +00:00
|
|
|
let name_table = NameTable.create 100
|
|
|
|
let directory = ref NameSet.empty
|
|
|
|
|
|
|
|
let name_of_string str =
|
|
|
|
Util.with_mutex0 mutex (fun () ->
|
|
|
|
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;
|
|
|
|
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-01-08 19:48:07 +00:00
|
|
|
then (Log.warn "Binding to empty name forbidden" []; false)
|
2012-01-08 17:41:04 +00:00
|
|
|
else
|
2012-05-05 15:46:48 +00:00
|
|
|
Util.with_mutex0 mutex (fun () ->
|
|
|
|
filter.binding <- Some node;
|
|
|
|
directory := NameSet.add filter !directory;
|
|
|
|
node.names <- StringSet.add filter.label node.names;
|
|
|
|
Log.info "Node bound" [Sexp.Str filter.label; Sexp.Str node.class_name];
|
|
|
|
true)
|
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-03-04 17:12:20 +00:00
|
|
|
if bind (node_name, node) then Ok node else Problem (Sexp.Str "bind-failed")
|
|
|
|
|
|
|
|
(* For use in factory constructor functions, hence the odd return type and values *)
|
|
|
|
let make_idempotent_named class_name node_name handler =
|
|
|
|
match lookup node_name with
|
|
|
|
| Some n ->
|
|
|
|
if n.class_name = class_name
|
|
|
|
then Ok n
|
|
|
|
else Problem (Sexp.Str "class-mismatch")
|
|
|
|
| None ->
|
|
|
|
let node = make class_name handler in
|
|
|
|
if bind (node_name, node) then Ok node else Problem (Sexp.Str "bind-failed")
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let unbind name =
|
2012-05-05 15:46:48 +00:00
|
|
|
Util.with_mutex0 mutex (fun () ->
|
|
|
|
match lookup name with
|
|
|
|
| Some n ->
|
|
|
|
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;
|
|
|
|
true
|
|
|
|
| None ->
|
|
|
|
false)
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let unbind_all n =
|
2012-05-05 15:46:48 +00:00
|
|
|
StringSet.iter (fun name -> ignore (unbind (name_of_string name))) n.names;
|
2012-01-08 17:41:04 +00:00
|
|
|
n.names <- StringSet.empty
|
|
|
|
|
|
|
|
let send name body =
|
|
|
|
match lookup name with
|
2012-01-08 19:02:52 +00:00
|
|
|
| Some n ->
|
|
|
|
(try n.handle_message n body
|
|
|
|
with e ->
|
2012-01-08 19:48:07 +00:00
|
|
|
Log.warn "Node message handler raised exception"
|
2012-05-05 15:46:48 +00:00
|
|
|
[Sexp.Str name.label;
|
2012-01-08 19:48:07 +00:00
|
|
|
Sexp.Str (Printexc.to_string e)]);
|
2012-01-08 19:02:52 +00:00
|
|
|
true
|
2012-01-08 17:41:04 +00:00
|
|
|
| None -> false
|
|
|
|
|
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) =
|
|
|
|
if bind (filter, node)
|
|
|
|
then ()
|
2012-05-05 15:46:48 +00:00
|
|
|
else Log.warn "Duplicate binding" [Sexp.Str filter.label]
|
2012-01-08 17:41:04 +00:00
|
|
|
|
|
|
|
let send_ignore name body =
|
2012-05-05 15:46:48 +00:00
|
|
|
if send name body || name.label = ""
|
2012-01-08 17:41:04 +00:00
|
|
|
then ()
|
2012-05-05 15:46:48 +00:00
|
|
|
else Log.warn "send to missing node" [Sexp.Str name.label; body]
|
|
|
|
|
|
|
|
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
|