From fcafadb591c99fd2424b67d4fa26a2903bd8eac9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 29 May 2012 16:06:57 +0100 Subject: [PATCH] JSON configuration --- server/amqp_relay.ml | 3 +- server/config.ml | 58 +++++++++++++++---- server/gpath.ml | 102 ++++++++++++++++++++++++++++++++++ server/hop.config | 15 +++++ server/hop_server.ml | 25 ++++++--- server/hopstr.ml | 26 +++++++++ server/ibuffer.ml | 16 ++++++ server/json.ml | 129 ++++++++++++++++++++++++++++++++++++------- server/relay.ml | 3 +- server/ui_main.ml | 3 +- server/util.ml | 34 ++++++++++++ 11 files changed, 373 insertions(+), 41 deletions(-) create mode 100644 server/gpath.ml create mode 100644 server/hop.config create mode 100644 server/hopstr.ml diff --git a/server/amqp_relay.ml b/server/amqp_relay.ml index 05a4d31..d91c1f2 100644 --- a/server/amqp_relay.ml +++ b/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 diff --git a/server/config.ml b/server/config.ml index 7f0f661..c0bf8ed 100644 --- a/server/config.ml +++ b/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 () diff --git a/server/gpath.ml b/server/gpath.ml new file mode 100644 index 0000000..44e5156 --- /dev/null +++ b/server/gpath.ml @@ -0,0 +1,102 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* 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 . *) + +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 diff --git a/server/hop.config b/server/hop.config new file mode 100644 index 0000000..660f3e4 --- /dev/null +++ b/server/hop.config @@ -0,0 +1,15 @@ +// -*- javascript -*- +{ + "amqp": { + "enabled": true, + "port": 5672, + }, + "http": { + "enabled": true, + "port": 5678, + }, + "hop": { + "enabled": true, + "port": 5671, + }, +} diff --git a/server/hop_server.ml b/server/hop_server.ml index ab9a886..cb71e80 100644 --- a/server/hop_server.ml +++ b/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 diff --git a/server/hopstr.ml b/server/hopstr.ml new file mode 100644 index 0000000..2028bcf --- /dev/null +++ b/server/hopstr.ml @@ -0,0 +1,26 @@ +(* Copyright 2012 Tony Garnock-Jones . *) + +(* 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 . *) + +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 diff --git a/server/ibuffer.ml b/server/ibuffer.ml index c2da17f..5ce1d58 100644 --- a/server/ibuffer.ml +++ b/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 diff --git a/server/json.ml b/server/json.ml index 82704e9..4c849c9 100644 --- a/server/json.ml +++ 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 diff --git a/server/relay.ml b/server/relay.ml index 6de2275..27ccd80 100644 --- a/server/relay.ml +++ b/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 diff --git a/server/ui_main.ml b/server/ui_main.ml index 47714fd..68bd21b 100644 --- a/server/ui_main.ml +++ b/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 diff --git a/server/util.ml b/server/util.ml index c48d002..7724d6e 100644 --- a/server/util.ml +++ b/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)