diff --git a/server/node.ml b/server/node.ml index 138fc8d..d88da53 100644 --- a/server/node.ml +++ b/server/node.ml @@ -49,6 +49,17 @@ let name_of_string str = let template = {label = str; binding = None} in NameTable.merge name_table template +let caching_name_of_string () = + let cache = ref None in + fun str -> + match !cache with + | Some ({label = k} as n) when k = str -> + n + | _ -> + let n = name_of_string str in + cache := Some n; + n + let local_container_name () = "server" let make class_name handler = { diff --git a/server/relay.ml b/server/relay.ml index 64295c9..6de2275 100644 --- a/server/relay.ml +++ b/server/relay.ml @@ -28,10 +28,11 @@ let send_error ch message details = let send_sexp_syntax_error ch explanation = send_error ch explanation (Str "http://people.csail.mit.edu/rivest/Sexp.txt") -let dispatch_message n ch m = - match m with +let dispatch_message n ch = + let lookup = Node.caching_name_of_string () in + function | Message.Post (Str name, body, token) -> - Node.send_ignore' name body + Node.send_ignore (lookup name) body | Message.Subscribe (Str filter, sink, name, Str reply_sink, Str reply_name) -> (match_lwt Node.bind (Node.name_of_string filter, n) with | true -> @@ -46,7 +47,7 @@ let dispatch_message n ch m = (match_lwt Node.unbind (Node.name_of_string token) with | true -> return () | false -> Log.warn "Unbind failed" [Str token]) - | _ -> + | m -> send_error ch "Message not understood" (Message.sexp_of_message m) let issue_banner cin cout = @@ -66,9 +67,10 @@ let relay_handler (_, mtx, _, cout) _ m = let relay_mainloop (peername, mtx, cin, cout) n = let write_sexp sexp = Lwt_mutex.with_lock mtx (fun () -> output_sexp cout sexp) in (try_lwt + let dispatcher = dispatch_message n write_sexp in while_lwt true do lwt message_sexp = Sexp.input_sexp cin in - dispatch_message n write_sexp (Message.message_of_sexp message_sexp) + dispatcher (Message.message_of_sexp message_sexp) done with | Sexp.Syntax_error explanation ->