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-03-04 17:12:20 +00:00
|
|
|
open Sexp
|
|
|
|
open Datastructures
|
|
|
|
open Status
|
|
|
|
|
|
|
|
type t = {
|
2012-05-05 15:46:48 +00:00
|
|
|
name: Node.name;
|
2012-03-04 17:12:20 +00:00
|
|
|
subscriptions: Subscription.set_t;
|
|
|
|
mutable routing_table: UuidSet.t StringMap.t;
|
|
|
|
}
|
|
|
|
|
|
|
|
let classname = "direct"
|
|
|
|
|
|
|
|
let unsubscribe info uuid =
|
2012-05-05 22:18:23 +00:00
|
|
|
match_lwt Subscription.delete info.name info.subscriptions uuid with
|
|
|
|
| Some sub ->
|
|
|
|
(match sub.Subscription.filter with
|
|
|
|
| Str binding_key ->
|
|
|
|
(try
|
|
|
|
let old_set = StringMap.find binding_key info.routing_table in
|
|
|
|
let new_set = UuidSet.remove sub.Subscription.uuid old_set in
|
|
|
|
if UuidSet.is_empty new_set
|
|
|
|
then info.routing_table <- StringMap.remove binding_key info.routing_table
|
|
|
|
else info.routing_table <- StringMap.add binding_key new_set info.routing_table
|
|
|
|
with Not_found ->
|
|
|
|
());
|
|
|
|
return ()
|
|
|
|
| _ -> return ())
|
|
|
|
| None -> return ()
|
2012-03-04 17:12:20 +00:00
|
|
|
|
|
|
|
let route_message info n sexp =
|
|
|
|
match Message.message_of_sexp sexp with
|
2012-05-05 22:18:23 +00:00
|
|
|
| Message.Post (Str name, body, token) ->
|
2012-03-04 17:12:20 +00:00
|
|
|
let routing_snapshot = info.routing_table in
|
|
|
|
let matching = (try StringMap.find name routing_snapshot with Not_found -> UuidSet.empty) in
|
2012-05-05 22:18:23 +00:00
|
|
|
Lwt_list.iter_s
|
2012-03-04 17:12:20 +00:00
|
|
|
(fun (uuid) ->
|
|
|
|
match Subscription.lookup info.subscriptions uuid with
|
2012-05-05 22:18:23 +00:00
|
|
|
| Some sub ->
|
|
|
|
lwt _ = Subscription.send_to_subscription' sub body (unsubscribe info) in
|
|
|
|
return ()
|
|
|
|
| None ->
|
|
|
|
return ())
|
|
|
|
(UuidSet.elements matching)
|
|
|
|
| Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) ->
|
|
|
|
lwt sub =
|
|
|
|
Subscription.create
|
|
|
|
info.name info.subscriptions filter sink name reply_sink reply_name in
|
|
|
|
let old_set =
|
|
|
|
(try StringMap.find binding_key info.routing_table with Not_found -> UuidSet.empty) in
|
|
|
|
let new_set = UuidSet.add sub.Subscription.uuid old_set in
|
|
|
|
info.routing_table <- StringMap.add binding_key new_set info.routing_table;
|
|
|
|
return ()
|
|
|
|
| Message.Unsubscribe (Str token) ->
|
2012-03-04 17:12:20 +00:00
|
|
|
unsubscribe info token
|
2012-05-05 22:18:23 +00:00
|
|
|
| m ->
|
2012-03-04 17:12:20 +00:00
|
|
|
Util.message_not_understood classname m
|
|
|
|
|
|
|
|
let factory arg =
|
|
|
|
match arg with
|
2012-05-05 22:18:23 +00:00
|
|
|
| (Arr [Str name_str]) ->
|
2012-03-04 17:12:20 +00:00
|
|
|
let info = {
|
2012-05-05 15:46:48 +00:00
|
|
|
name = Node.name_of_string name_str;
|
2012-03-04 17:12:20 +00:00
|
|
|
subscriptions = Subscription.new_set ();
|
|
|
|
routing_table = StringMap.empty;
|
|
|
|
} in
|
2012-05-05 15:46:48 +00:00
|
|
|
replace_ok
|
2012-05-06 03:00:10 +00:00
|
|
|
(Node.make_idempotent_named classname info.name return (route_message info))
|
2012-05-05 15:46:48 +00:00
|
|
|
(Str name_str)
|
2012-05-05 22:18:23 +00:00
|
|
|
| _ ->
|
|
|
|
return (Problem (Str "bad-arg"))
|
2012-03-04 17:12:20 +00:00
|
|
|
|
|
|
|
let init () =
|
|
|
|
Factory.register_class classname factory
|