hop-2012/server/factory.ml

(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)

(* This file is part of Hop. *)

(* Hop is free software: you can redistribute it and/or modify it *)
(* 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. *)

(* Hop is distributed in the hope that it will be useful, but *)
(* 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 *)
(* along with Hop.  If not, see <http://www.gnu.org/licenses/>. *)

open Lwt
open Printf
open Sexp
open Datastructures

type factory_t = Sexp.t -> (Sexp.t, Sexp.t) Status.t Lwt.t

let classes = ref BytesMap.empty

let register_class name factory =
  if BytesMap.mem name !classes
  then (ignore (Log.error "Duplicate node class name" [Str name]);
	Server_control.shutdown_now [litstr "Duplicate node class name"; Str name];
	Lwt_unix.yield ())
  else (ignore (Log.info "Registered node class" [Str name]);
	classes := BytesMap.add name factory !classes;
	return ())

let all_class_names () =
  Datastructures.bytes_map_keys !classes

let lookup_class name =
  try Some (BytesMap.find name !classes)
  with Not_found -> None

let factory_handler n sexp =
  match Message.message_of_sexp sexp with
  | Message.Create (Str classname, arg, Str reply_sink, Str reply_name) ->
      lwt reply =
	match lookup_class classname with
	  | Some factory ->
	    (match_lwt factory arg with
	      | Status.Ok info ->
		ignore (Log.info "Node create ok"
			  [Str classname; arg; Str reply_sink; Str reply_name; info]);
		return (Message.create_ok info)
	      | Status.Problem explanation ->
		ignore (Log.info "Node create failed"
			  [Str classname; arg; Str reply_sink; Str reply_name; explanation]);
		return (Message.create_failed (Arr [litstr "constructor"; explanation])))
	  | None ->
	    ignore (Log.warn "Node class not found" [Str classname]);
	    return (Message.create_failed (Arr [litstr "factory"; litstr "class-not-found"]))
      in
      Node.post_ignore' reply_sink (Str reply_name) reply emptystr
  | m ->
      Util.message_not_understood "factory" m

let init () =
  Node.bind_ignore (Node.name_of_bytes (Bytes.of_string "factory"), Node.make (Bytes.of_string "factory") factory_handler)