JSON configuration

server/amqp_relay.ml

@@ -449,4 +449,5 @@ let init () =
   lwt () = Node.send_ignore' "factory" (Message.create (Sexp.Str "fanout",
 							Sexp.Arr [Sexp.Str "amq.fanout"],
 							Sexp.Str "", Sexp.Str "")) in
-  Util.create_daemon_thread "AMQP listener" None (Net.start_net "AMQP" Amqp_spec.port) start
+  let port = Config.get_int "amqp.port" Amqp_spec.port in
+  Util.create_daemon_thread "AMQP listener" None (Net.start_net "AMQP" port) start

server/config.ml

@@ -17,20 +17,40 @@
 
 open Hof
 
-let config = ref []
+let config = ref (Json.Rec ["config-file", Json.Str "hop.config"])
 
 let get key =
-  try Some (List.assoc key !config) with Not_found -> None
+  try Some (Json.lookup_str key !config) with Not_found -> None
 
 let get' key default_value =
-  try (List.assoc key !config) with Not_found -> default_value
+  try (Json.lookup_str key !config) with Not_found -> default_value
 
-let push k v =
-  config := (k, v) :: !config
+let get_str key default_value =
+  match get key with
+    | Some (Json.Str s) -> s
+    | _ -> default_value
 
-let get_all key =
-  List.filter (fun (k, v) -> k = key) !config
-  |> List.rev_map (fun (k, v) -> v)
+let get_num key default_value =
+  match get key with
+    | Some (Json.Num n) -> n
+    | _ -> default_value
+
+let get_int key default_value =
+  match get key with
+    | Some (Json.Num n) -> int_of_float n
+    | _ -> default_value
+
+let get_bool key default_value =
+  match get key with
+    | Some v -> Json.truish v
+    | _ -> default_value
+
+let conditional key default_value f =
+  if get_bool key default_value
+  then f () else Lwt.return ()
+
+let set k v =
+  config := Json.update_str k v !config
 
 let init () =
   let argv = Sys.argv in
@@ -42,6 +62,22 @@ let init () =
       (let opt = argv.(index) in
       if Util.starts_with opt "--"
       then loop (index + 1) (String.sub opt 2 (String.length opt - 2))
-      else (push current_key opt;
-	    loop (index + 1) current_key))
-  in loop 1 ""
+      else
+	let v = (try Json.of_string opt with _ -> Json.Str opt) in
+	ignore (Log.info "Setting command-line parameter"
+		  [Sexp.Str current_key; Sexpjson.sexp_of_json v]);
+	set current_key v;
+	loop (index + 1) current_key)
+  in
+  loop 1 "";
+  (match get "config-file" with
+    | Some (Json.Str config_filename) ->
+      ignore (Log.info "Reading configuration file" [Sexp.Str config_filename]);
+      let file_config = try Json.load config_filename with Sys_error _ -> Json.Rec [] in
+      config := Json.merge_right file_config !config
+    | _ ->
+      ignore (Log.info "No configuration file" []);
+      ());
+  if Json.truish_some (get "dump-config")
+  then print_endline (Json.pretty_string !config)
+  else ()

server/gpath.ml

@@ -0,0 +1,102 @@
+(* 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/>. *)
+
+type 'a t =
+  | Index of int
+  | Field of string
+  | Push
+
+type 'a adapter_t = {
+  get_index: 'a -> int -> 'a;
+  set_index: 'a -> int -> 'a -> 'a;
+  push: 'a -> 'a -> 'a;
+  empty_array: unit -> 'a;
+
+  get_field: string -> 'a -> 'a;
+  set_field: string -> 'a -> 'a -> 'a;
+  empty_record: unit -> 'a;
+}
+
+exception Syntax_error of string
+
+let parse_fieldref b =
+  let s = Ibuffer.until_pred (function Some x -> x = '[' || x = '.' | None -> true) b in
+  Field s
+
+let parse_single b =
+  match Ibuffer.peek_char b with 
+    | '[' ->
+      Ibuffer.skip_byte b; (* drop the open bracket *)
+      let istr = Ibuffer.until_char ']' b in
+      Ibuffer.skip_byte b; (* drop the close bracket *)
+      (match istr with
+	| "+" -> Push
+	| _ -> Index (int_of_string istr))
+    | '.' ->
+      Ibuffer.skip_byte b;
+      parse_fieldref b
+    | _ ->
+      parse_fieldref b
+
+let rec parse b =
+  try
+    let step = parse_single b in
+    step :: parse b
+  with End_of_file ->
+    []
+
+let of_string s = parse (Ibuffer.of_string s)
+
+let to_string ps =
+  let rec walk is_first ps =
+    match ps with
+      | [] -> ""
+      | Index i :: rest -> "[" ^ string_of_int i ^ "]" ^ walk false rest
+      | Field s :: rest -> (if is_first then "" else ".") ^ s ^ walk false rest
+      | Push :: rest -> "[+]" ^ walk false rest
+  in walk true ps
+
+let run1 adapter v p =
+  match p with
+    | Index i -> adapter.get_index v i
+    | Field s -> adapter.get_field s v
+    | Push -> failwith "Gpath.run1"
+
+let run adapter ps v =
+  List.fold_left (run1 adapter) v ps
+
+let set adapter ps newval v =
+  let rec walk ps v =
+    match ps with
+      | [] -> failwith "empty path in Gpath.set"
+      | [Index i] -> adapter.set_index v i newval
+      | [Field s] -> adapter.set_field s newval v
+      | [Push] -> adapter.push v newval
+      | (Index i) :: rest -> adapter.set_index v i (walk rest (adapter.get_index v i))
+      | (Field s) :: rest ->
+	(match try Some (adapter.get_field s v) with _ -> None with
+	  | Some v' -> adapter.set_field s (walk rest v') v
+	  | None -> adapter.set_field s (stub rest) v)
+      | (Push) :: rest -> adapter.push v (stub rest)
+  and stub ps =
+    match ps with
+      | [] -> newval
+      | (Index 0) :: rest -> adapter.push (adapter.empty_array ()) (stub rest)
+      | (Index _) :: rest -> failwith "non-zero index in stub in Gpath.set"
+      | (Field s) :: rest -> adapter.set_field s (stub rest) (adapter.empty_record ())
+      | (Push) :: rest -> adapter.push (adapter.empty_array ()) (stub rest)
+  in walk ps v

server/hop.config

@@ -0,0 +1,15 @@
+// -*- javascript -*-
+{
+    "amqp": {
+	"enabled": true,
+	"port": 5672,
+    },
+    "http": {
+	"enabled": true,
+	"port": 5678,
+    },
+    "hop": {
+	"enabled": true,
+	"port": 5671,
+    },
+}

server/hop_server.ml

@@ -29,9 +29,12 @@ let hook_log () =
 
 let create_ready_file () =
   match Config.get "ready-file" with
-    | Some ready_file_path ->
+    | Some (Json.Str ready_file_path) ->
       ignore (Log.info "Creating ready file" [Sexp.Str ready_file_path]);
       return (close_out (open_out ready_file_path))
+    | Some other ->
+      ignore (Log.error "Ready file path not a string" [Sexpjson.sexp_of_json other]);
+      return ()
     | None ->
       return ()
 
@@ -52,13 +55,19 @@ lwt _ =
   lwt () = Directnode.init () in
   lwt () = Meta.init () in
   hook_log ();
-  ignore (Amqp_relay.init ());
-  ignore (Ui_main.init ());
-  ignore (Ui_relay.init ());
-  ignore (Relay.init ());
-  lwt () = Server_control.run_until "AMQP ready" in
-  lwt () = Server_control.run_until "HTTP ready" in
-  lwt () = Server_control.run_until "Hop ready" in
+  lwt () = Config.conditional "amqp.enabled" true (fun () ->
+    ignore (Amqp_relay.init ());
+    Server_control.run_until "AMQP ready")
+  in
+  lwt () = Config.conditional "http.enabled" true (fun () ->
+    ignore (Ui_main.init ());
+    ignore (Ui_relay.init ());
+    Server_control.run_until "HTTP ready")
+  in
+  lwt () = Config.conditional "hop.enabled" true (fun () ->
+    ignore (Relay.init ());
+    Server_control.run_until "Hop ready")
+  in
   ignore (console_watcher ());
   if Server_control.is_running ()
   then (lwt () = create_ready_file () in

server/hopstr.ml

@@ -0,0 +1,26 @@
+(* 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/>. *)
+
+let string_of_revlist acc len =
+  let buf = String.make len ' ' in
+  let rec fill cs i =
+    match cs with
+    | [] -> ()
+    | c :: cs' -> (String.set buf i c; fill cs' (i - 1))
+  in
+  fill acc (len - 1);
+  buf

server/ibuffer.ml

@@ -82,3 +82,19 @@ let next_sub b n =
   let v = sub b 0 n in
   b.pos <- b.pos + n;
   v
+
+let until_pred pred b =
+  let rec loop acc len =
+    if remaining b = 0
+    then
+      if pred None
+      then Hopstr.string_of_revlist acc len
+      else raise End_of_file
+    else
+      let ch = peek_char b in
+      if pred (Some ch)
+      then Hopstr.string_of_revlist acc len
+      else loop (next_char b :: acc) (len + 1)
+  in loop [] 0
+
+let until_char c b = until_pred (function Some x -> x = c | None -> false) b

server/json.ml

@@ -116,29 +116,18 @@ let accumulate_utf8 codepoint (acc, len) =
      Char.chr (0xFC lor ((codepoint lsr 30) land 0x1)) ::
      acc, len + 6)
 
-let string_of_revlist acc len =
-  let buf = String.make len ' ' in
-  let rec fill cs i =
-    match cs with
-    | [] -> ()
-    | c :: cs' -> (String.set buf i c; fill cs' (i - 1))
-  in
-  fill acc (len - 1);
-  buf
-
 let rec parse_num b (acc, len) =
-  match Ibuffer.peek_char b with
-  | '+' | '-' | 'e' | 'E' | '.'
-  | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
-      as c ->
-	Ibuffer.skip_byte b;
-	parse_num b (c :: acc, len + 1)
-  | _ ->
-      Num (float_of_string (string_of_revlist acc len))
+  match (try Ibuffer.peek_char b with End_of_file -> ' ') with
+    | '+' | '-' | 'e' | 'E' | '.'
+    | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' as c ->
+      Ibuffer.skip_byte b;
+      parse_num b (c :: acc, len + 1)
+    | _ ->
+      Num (float_of_string (Hopstr.string_of_revlist acc len))
 
 let rec parse_str b (acc, len) =
   match Ibuffer.next_char b with
-  | '\"' -> Str (string_of_revlist acc len)
+  | '\"' -> Str (Hopstr.string_of_revlist acc len)
   | '\\' ->
       (match Ibuffer.next_char b with
       | 'b' -> parse_str b (Char.chr 8 :: acc, len + 1)
@@ -150,6 +139,12 @@ let rec parse_str b (acc, len) =
       | c -> parse_str b (c :: acc, len + 1))
   | c -> parse_str b (c :: acc, len + 1)
 
+let rec skip_line_comment b =
+  match Ibuffer.next_byte b with
+    | 13 (* '\r' *) -> ()
+    | 10 (* '\n' *) -> ()
+    | _ -> skip_line_comment b
+
 let rec parse_arr b acc =
   Ibuffer.skip_ws b;
   match Ibuffer.peek_char b with
@@ -182,6 +177,7 @@ and parse b =
   | 't' -> if Ibuffer.next_chars b 3 = "rue" then Flg true else raise Syntax_error
   | 'f' -> if Ibuffer.next_chars b 4 = "alse" then Flg false else raise Syntax_error
   | 'n' -> if Ibuffer.next_chars b 3 = "ull" then Nil else raise Syntax_error
+  | '/' -> (* cheating *) skip_line_comment b; parse b
   | _ -> raise Syntax_error
 
 let of_string s = parse (Ibuffer.of_string s)
@@ -191,3 +187,98 @@ let resp code reason extra_headers j =
     ((Httpd.content_type_header_name, "application/json") :: extra_headers)
     (Httpd.Fixed (to_string j))
 let resp_ok extra_headers j = resp 200 "OK" extra_headers j
+
+let load filename = of_string (Util.file_contents filename)
+
+let get j i =
+  match j with
+    | Arr js -> List.nth js i
+    | _ -> failwith "Json.get"
+
+let find s j =
+  match j with
+    | Rec kvs -> List.assoc s kvs
+    | _ -> failwith "Json.find"
+
+let set j i v =
+  match j with
+    | Arr js ->
+      (match Util.split_at js i with
+	| (prefix, _ :: suffix) -> Arr (prefix @ v :: suffix)
+	| _ -> failwith "Json.set")
+    | _ ->
+      failwith "Json.set"
+
+let add k v j =
+  match j with
+    | Rec kvs -> Rec (List.remove_assoc k kvs @ [k, v])
+    | _ -> failwith "Json.add"
+
+let push j v =
+  match j with
+    | Arr js ->
+      Arr (js @ [v])
+    | _ ->
+      failwith "Json.push"
+
+let gpath_adapter = {
+  Gpath.get_index = get;
+  Gpath.set_index = set;
+  Gpath.push = push;
+  Gpath.empty_array = (fun () -> Arr []);
+  Gpath.get_field = find;
+  Gpath.set_field = add;
+  Gpath.empty_record = (fun () -> Rec []);
+}
+
+let lookup path j = Gpath.run gpath_adapter path j
+let lookup_str path_str j = lookup (Gpath.of_string path_str) j
+
+let update path v j = Gpath.set gpath_adapter path v j
+let update_str path_str v j = update (Gpath.of_string path_str) v j
+
+let path_fold seed f g j =
+  let rec walk seed prefixrev j =
+    match j with
+      | Arr js ->
+	let rec loop seed js =
+	  match js with
+	    | [] -> seed
+	    | j' :: js' -> loop (walk seed (Gpath.Push :: prefixrev) j') js'
+	in loop (g (List.rev prefixrev) (Arr []) seed) js
+      | Rec kvs ->
+	let rec loop seed kvs =
+	  match kvs with
+	    | [] -> seed
+	    | (k, v) :: kvs' -> loop (walk seed (Gpath.Field k :: prefixrev) v) kvs'
+	in loop (g (List.rev prefixrev) (Rec []) seed) kvs
+      | other ->
+	f (List.rev prefixrev) other seed
+  in walk seed [] j
+
+let merge_right under over =
+  let ensure_compatible path node j =
+    try
+      match (Gpath.run gpath_adapter path j, node) with
+	| Arr _, Arr _ -> j
+	| Rec _, Rec _ -> j
+	| _, _ -> Gpath.set gpath_adapter path node j
+    with _ ->
+      Gpath.set gpath_adapter path node j
+  in
+  path_fold under update ensure_compatible over
+
+let truish j =
+  match j with
+    | Num 0.0 -> false
+    | Str "" -> false
+    | Arr [] -> false
+    | Rec [] -> false
+    | Flg false -> false
+    | Nil -> false
+    | _ -> true
+
+let truish_some v =
+  match v with
+    | Some j -> truish j
+    | None -> false

server/relay.ml

@@ -83,4 +83,5 @@ let start (s, peername) =
     relay_boot relay_handler relay_mainloop (s, peername)
 
 let init () =
-  Util.create_daemon_thread "Hop listener" None (Net.start_net "Hop" 5671) start
+  let port = Config.get_int "hop.port" 5671 in
+  Util.create_daemon_thread "Hop listener" None (Net.start_net "Hop" port) start

server/ui_main.ml

@@ -98,4 +98,5 @@ let init () =
   register_dispatcher ("/_/server_stats", api_server_stats);
   register_dispatcher ("/_/nodes", api_nodes);
   register_dispatcher ("/_/node/", api_node_info);
-  Util.create_daemon_thread "HTTP listener" None (Net.start_net "HTTP" 5678) start
+  let port = Config.get_int "http.port" 5678 in
+  Util.create_daemon_thread "HTTP listener" None (Net.start_net "HTTP" port) start

server/util.ml

@@ -103,3 +103,37 @@ let stream_generator f =
   ignore (lwt () = f yield in
 	  Lwt_mvar.put mbox None);
   Lwt_stream.from (fun () -> Lwt_mvar.take mbox)
+
+let file_contents filename =
+  let ch = open_in filename in
+  let len = in_channel_length ch in
+  let buf = String.make len ' ' in
+  really_input ch buf 0 len;
+  close_in ch;
+  buf
+
+let rec split_at xs n =
+  match n with
+    | 0 -> ([], xs)
+    | _ ->
+      match xs with
+	| [] -> raise (Failure "Util.split_at")
+	| x :: xs' ->
+	  let (hs, ts) = split_at xs' (n - 1) in
+	  (x :: hs, ts)
+
+let rec list_make n v =
+  match n with
+    | 0 -> []
+    | _ -> v :: list_make (n - 1) v
+
+let rec split_at_fill v xs n =
+  match n with
+    | 0 -> ([], xs)
+    | _ ->
+      match xs with
+	| [] ->
+	  (list_make n v, [])
+	| x :: xs' ->
+	  let (hs, ts) = split_at_fill v xs' (n - 1) in
+	  (x :: hs, ts)